P281424
/
AMR
mirror of https://github.com/msberends/AMR
1
0
Fork 0
Code Releases Activity

(v1.3.0.9023) optimalisation

Browse Source
pull/67/head
dr. M.S. (Matthijs) Berends 3 years ago
parent 4e40e42011
commit d049cce69b
30 changed files with 104 additions and 578 deletions
Show Stats Download Patch File Download Diff File

2
.github/workflows/lintr.yaml vendored
Unescape Escape View File

@ -62,5 +62,5 @@ jobs:
shell: Rscript {0}
- name: Lint
run: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_usage_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_functions_dplyr.R"))
run: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_usage_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_pm_functions.R"))
shell: Rscript {0}

4
DESCRIPTION
Unescape Escape View File

@ -1,6 +1,6 @@
Package: AMR
Version: 1.3.0.9022
Date: 2020-09-18
Version: 1.3.0.9023
Date: 2020-09-19
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(role = c("aut", "cre"),

4
NEWS.md
Unescape Escape View File

@ -1,5 +1,5 @@
# AMR 1.3.0.9022
## <small>Last updated: 18 September 2020</small>
# AMR 1.3.0.9023
## <small>Last updated: 19 September 2020</small>
Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscipt to. We are those reviewers very grateful for going through our code so thoroughly!

2
R/aa_helper_functions.R
Unescape Escape View File

@ -26,7 +26,7 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
if (is.na(by)) {
stop_("no common column found for pm_left_join()")
}
join_message(by)
pm_join_message(by)
} else if (!is.null(names(by))) {
by <- unname(c(names(by), by))
}

530
R/aa_helper_pm_functions.R
Unescape Escape View File

@ -36,7 +36,7 @@
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software
# is furnished to do so', given that a copyright notice is given in the software.
#
# Copyright notice on 18 September 2020, the day this code was downloaded, as found on
# Copyright notice on 19 September 2020, the day this code was downloaded, as found on
# https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/LICENSE:
# YEAR: 2020
# COPYRIGHT HOLDER: Nathan Eastwood
@ -67,28 +67,6 @@ pm_between <- function(x, left, right) {
if (!is.double(x)) x <- as.numeric(x)
x >= as.numeric(left) & x <= as.numeric(right)
}
pm_coalesce <- function(...) {
if (missing(..1)) stop("At least one argument must be supplied.")
vectors <- list(...)
vectors_lens <- unique(lengths(vectors))
if (length(vectors_lens) > 2L || (length(vectors_lens) == 2L & !1 %in% vectors_lens)) {
stop("Vectors must all be of length 1 and/or pm_n")
}
max_len <- max(vectors_lens)
len_one <- lengths(vectors) == 1L
vectors[len_one] <- lapply(vectors[len_one], function(x) rep(x, max_len))
x <- vectors[[1]]
vectors <- vectors[-1]
for (i in seq_along(vectors)) {
x_miss <- is.na(x)
x[x_miss] <- vectors[[i]][x_miss]
}
x
}
pm_context <- new.env()
# Data
@ -288,23 +266,6 @@ pm_filter.grouped_data <- function(.data, ...) {
res <- pm_apply_grouped_function("pm_filter", .data, drop = TRUE, ...)
res[rows[rows %in% rownames(res)], ]
}
pm_glimpse <- function(x, width = getOption("width"), ...) {
if ("grouped_data" %in% class(.data)) {
pm_glimpse.grouped_data(.data, ...)
} else {
pm_glimpse.default(.data, ...)
}
}
pm_glimpse.default <- function (x, width = getOption("width"), max.level = 3, ...) {
utils::str(x, width = width, max.level = max.level, ...)
invisible(x)
}
pm_glimpse.data.frame <- function(x, width = getOption("width"), ...) {
utils::str(x, width = width, ...)
invisible(x)
}
pm_group_by <- function(.data, ..., .add = FALSE) {
pm_check_is_dataframe(.data)
pre_groups <- pm_get_groups(.data)
@ -481,6 +442,27 @@ pm_if_else <- function(condition, true, false, missing = NULL) {
res
}
pm_anti_join <- function(x, y, by = NULL) {
pm_filter_join_worker(x, y, by, type = "anti")
}
pm_semi_join <- function(x, y, by = NULL) {
pm_filter_join_worker(x, y, by, type = "semi")
}
pm_filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
if (is.null(by)) {
by <- intersect(names(x), names(y))
pm_join_message(by)
}
rows <- interaction(x[, by]) %in% interaction(y[, by])
if (type == "anti") rows <- !rows
res <- x[rows, , drop = FALSE]
rownames(res) <- NULL
res
}
pm_inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
pm_join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE)
}
@ -520,27 +502,6 @@ pm_join_message <- function(by) {
message("Joining, by = \"", by, "\"\n", sep = "")
}
}
pm_anti_join <- function(x, y, by = NULL) {
pm_filter_join_worker(x, y, by, type = "anti")
}
pm_semi_join <- function(x, y, by = NULL) {
pm_filter_join_worker(x, y, by, type = "semi")
}
pm_filter_join_worker <- function(x, y, by = NULL, type = c("anti", "semi")) {
type <- match.arg(type, choices = c("anti", "semi"), several.ok = FALSE)
if (is.null(by)) {
by <- intersect(names(x), names(y))
pm_join_message(by)
}
rows <- interaction(x[, by]) %in% interaction(y[, by])
if (type == "anti") rows <- !rows
res <- x[rows,, drop = FALSE]
rownames(res) <- NULL
res
}
pm_lag <- function(x, pm_n = 1L, default = NA) {
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::pm_lag()`?")
if (length(pm_n) != 1L || !is.numeric(pm_n) || pm_n < 0L) stop("`pm_n` must be a nonnegative integer scalar")
@ -630,163 +591,6 @@ pm_pull <- function(.data, var = -1) {
}
.data[, var]
}
pm_recode <- function(.x, ..., .default = NULL, .missing = NULL) {
if ("grouped_data" %in% class(.data)) {
pm_recode.grouped_data(.data, ...)
} else {
pm_recode.default(.data, ...)
}
}
pm_recode.numeric <- function(.x, ..., .default = NULL, .missing = NULL) {
values <- pm_dotdotdot(...)
nms <- pm_have_name(values)
if (all(nms)) {
vals <- as.double(names(values))
} else if (all(!nms)) {
vals <- seq_along(values)
} else {
stop("Either all values must be named, or none must be named.")
}
pm_n <- length(.x)
template <- pm_find_template(values, .default, .missing)
res <- template[rep(NA_integer_, pm_n)]
replaced <- rep(FALSE, pm_n)
for (i in seq_along(values)) {
res <- pm_replace_with(res, .x == vals[i], values[[i]], paste0("Vector ", i))
replaced[.x == vals[i]] <- TRUE
}
.default <- pm_validate_recode_default(.default, .x, res, replaced)
res <- pm_replace_with(res, !replaced & !is.na(.x), .default, "`.default`")
res <- pm_replace_with(res, is.na(.x), .missing, "`.missing`")
res
}
pm_recode.character <- function(.x, ..., .default = NULL, .missing = NULL) {
.x <- as.character(.x)
values <- pm_dotdotdot(...)
val_names <- names(values)
have_names <- pm_have_name(values)
if (!all(have_names)) {
bad <- which(!have_names) + 1L
stop("Argument", if (length(bad) > 1L) "s", " ", paste(bad, sep = ", "), " must be named, not unnamed.")
}
pm_n <- length(.x)
template <- pm_find_template(values, .default, .missing)
res <- template[rep(NA_integer_, pm_n)]
replaced <- rep(FALSE, pm_n)
for (nm in val_names) {
res <- pm_replace_with(res, .x == nm, values[[nm]], paste0("`", nm, "`"))
replaced[.x == nm] <- TRUE
}
.default <- pm_validate_recode_default(.default, .x, res, replaced)
res <- pm_replace_with(res, !replaced & !is.na(.x), .default, "`.default`")
res <- pm_replace_with(res, is.na(.x), .missing, "`.missing`")
res
}
pm_recode.factor <- function(.x, ..., .default = NULL, .missing = NULL) {
values <- pm_dotdotdot(...)
if (length(values) == 0) stop("No replacements provided.")
have_names <- pm_have_name(values)
if (!all(have_names)) {
bad <- which(!have_names) + 1
stop(bad, " must be named, not unnamed.")
}
if (!is.null(.missing)) {
stop("`.missing` is not supported for factors.")
}
pm_n <- length(levels(.x))
template <- pm_find_template(values, .default, .missing)
res <- template[rep(NA_integer_, pm_n)]
replaced <- rep(FALSE, pm_n)
for (nm in names(values)) {
res <- pm_replace_with(res, levels(.x) == nm, values[[nm]], paste0("`", nm, "`"))
replaced[levels(.x) == nm] <- TRUE
}
.default <- pm_validate_recode_default(.default, .x, res, replaced)
res <- pm_replace_with(res, !replaced, .default, "`.default`")
if (is.character(res)) {
levels(.x) <- res
.x
} else {
res[as.integer(.x)]
}
}
pm_have_name <- function(x) {
nms <- names(x)
if (is.null(nms)) rep(FALSE, length(x)) else !(nms == "" | is.na(nms))
}
pm_compact <- function(.x) Filter(length, .x)
pm_find_template <- function(values, .default = NULL, .missing = NULL) {
x <- pm_compact(c(values, .default, .missing))
if (length(x) == 0L) {
stop("No replacements provided.")
}
x[[1]]
}
pm_validate_recode_default <- function(default, x, res, replaced) {
default <- pm_recode_default(x, default, res)
if (is.null(default) && sum(replaced & !is.na(x)) < length(res[!is.na(x)])) {
warning(
"Unreplaced values treated as NA as .x is not compatible. ",
"Please specify replacements exhaustively or supply .default",
call. = FALSE
)
}
default
}
pm_recode_default <- function(x, default, res) {
if ("grouped_data" %in% class(.data)) {
pm_recode_default.grouped_data(.data, ...)
} else {
pm_recode_default.default(.data, ...)
}
}
pm_recode_default.default <- function(x, default, res) {
same_type <- identical(typeof(x), typeof(res))
if (is.null(default) && same_type) x else default
}
pm_recode_default.factor <- function(x, default, res) {
if (is.null(default)) {
if ((is.character(res) || is.factor(res)) && is.factor(x)) {
levels(x)
} else {
res[NA_integer_]
}
} else {
default
}
}
pm_recode_factor <- function(.x, ..., .default = NULL, .missing = NULL, .ordered = FALSE) {
recoded <- pm_recode(.x, ..., .default = .default, .missing = .missing)
values <- pm_dotdotdot(...)
all_levels <- unique(c(values, pm_recode_default(.x, .default, recoded), .missing))
recoded_levels <- if (is.factor(recoded)) levels(recoded) else unique(recoded)
levels <- intersect(all_levels, recoded_levels)
factor(recoded, levels, ordered = .ordered)
}
pm_set_names <- function(object = nm, nm) {
names(object) <- nm
object
@ -860,35 +664,6 @@ pm_rename_with <- function(.data, .fn, .cols = pm_everything(), ...) {
if (grouped) .data <- pm_set_groups(.data, colnames(.data)[grp_pos])
.data
}
pm_replace_na <- function(data, replace, ...) {
if ("grouped_data" %in% class(.data)) {
pm_replace_na.grouped_data(.data, ...)
} else {
pm_replace_na.default(.data, ...)
}
}
pm_replace_na.default <- function(data, replace = NA, ...) {
pm_check_replacement(replace, deparse(substitute(data)))
data[is.na(data)] <- replace
data
}
pm_replace_na.data.frame <- function(data, replace = list(), ...) {
stopifnot(is.list(replace))
replace_vars <- intersect(names(replace), names(data))
for (var in replace_vars) {
pm_check_replacement(replace[[var]], var)
data[[var]][is.na(data[[var]])] <- replace[[var]]
}
data
}
pm_check_replacement <- function(x, var) {
pm_n <- length(x)
if (pm_n == 1L) return()
stop("Replacement for `", var, "` is length ", pm_n, ", not length 1")
}
pm_replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) return(x)
pm_check_length(val, x, arg_name)
@ -937,20 +712,6 @@ pm_rownames_to_column <- function(.data, var = "rowname") {
rownames(.data) <- NULL
.data[, c(var, setdiff(col_names, var))]
}
pm_select <- function(.data, ...) {
col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
map_names <- names(col_pos)
map_names_length <- nchar(map_names)
if (any(map_names_length == 0L)) {
no_new_names <- which(map_names_length == 0L)
map_names[no_new_names] <- colnames(.data)[no_new_names]
}
res <- .data[, col_pos, drop = FALSE]
if (!is.null(map_names) && all(col_pos > 0L)) colnames(res) <- map_names
if (pm_has_groups(.data)) res <- pm_set_groups(res, pm_get_groups(.data))
res
}
pm_starts_with <- function(match, ignore.case = TRUE, vars = pm_peek_vars()) {
grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case)
}
@ -1161,243 +922,18 @@ pm_select_env$get_colnames <- function() colnames(pm_select_env$.data)
pm_select_env$get_nrow <- function() nrow(pm_select_env$.data)
pm_select_env$get_ncol <- function() ncol(pm_select_env$.data)
pm_slice <- function(.data, ...) {
pm_check_is_dataframe(.data)
if ("grouped_data" %in% class(.data)) {
pm_slice.grouped_data(.data, ...)
} else {
pm_slice.default(.data, ...)
}
}
pm_slice.data.frame <- function(.data, ...) {
if (nrow(.data) == 0L) return(.data)
pos <- pm_slice_positions(.data, ...)
.data[pos, , drop = FALSE]
}
pm_slice.grouped_data <- function(.data, ...) {
pm_apply_grouped_function("pm_slice", .data, drop = TRUE, ...)
}
pm_slice_head <- function(.data, ..., pm_n, prop) {
if ("grouped_data" %in% class(.data)) {
pm_slice_head.grouped_data(.data, ...)
} else {
pm_slice_head.default(.data, ...)
}
}
pm_slice_head.data.frame <- function(.data, ..., pm_n, prop) {
size <- pm_check_slice_size(pm_n, prop)
idx <- switch(
size$type,
pm_n = function(pm_n) seq2(1, min(size$pm_n, pm_n)),
prop = function(pm_n) seq2(1, min(size$prop * pm_n, pm_n))
)
pm_slice(.data, idx(AMR:::pm_n()))
}
pm_slice_head.grouped_data <- function(.data, ..., pm_n, prop) {
pm_apply_grouped_function("pm_slice_head", .data, drop = TRUE, pm_n = pm_n, prop = prop, ...)
}
pm_slice_tail <- function(.data, ..., pm_n, prop) {
if ("grouped_data" %in% class(.data)) {
pm_slice_tail.grouped_data(.data, ...)
} else {
pm_slice_tail.default(.data, ...)
}
}
pm_slice_tail.data.frame <- function(.data, ..., pm_n, prop) {
size <- pm_check_slice_size(pm_n, prop)
idx <- switch(
size$type,
pm_n = function(pm_n) seq2(max(pm_n - size$pm_n + 1, 1), pm_n),
prop = function(pm_n) seq2(max(ceiling(pm_n - size$prop * pm_n) + 1, 1), pm_n)
)
pm_slice(.data, idx(AMR:::pm_n()))
}
pm_slice_tail.grouped_data <- function(.data, ..., pm_n, prop) {
pm_apply_grouped_function("pm_slice_tail", .data, drop = TRUE, pm_n = pm_n, prop = prop, ...)
}
pm_slice_min <- function(.data, order_by, ..., pm_n, prop, with_ties = TRUE) {
if ("grouped_data" %in% class(.data)) {
pm_slice_min.grouped_data(.data, ...)
} else {
pm_slice_min.default(.data, ...)
}
}
pm_slice_min.data.frame <- function(.data, order_by, ..., pm_n, prop, with_ties = TRUE) {
if (missing(order_by)) stop("argument `order_by` is missing, with no default.")
size <- pm_check_slice_size(pm_n, prop)
idx <- if (isTRUE(with_ties)) {
switch(
size$type,
pm_n = function(x, pm_n) pm_vec_head(order(x), pm_smaller_ranks(x, size$pm_n)),
prop = function(x, pm_n) pm_vec_head(order(x), pm_smaller_ranks(x, size$prop * pm_n))
)
} else {
switch(
size$type,
pm_n = function(x, pm_n) pm_vec_head(order(x), size$pm_n),
prop = function(x, pm_n) pm_vec_head(order(x), size$prop * pm_n)
)
}
order_by <- .data[, pm_deparse_var(order_by)]
pm_slice(.data, idx(order_by, AMR:::pm_n()))
}
pm_slice_min.grouped_data <- function(.data, order_by, ..., pm_n, prop, with_ties = TRUE) {
pm_eval_env$env <- environment()
on.exit(rm(list = "env", envir = pm_eval_env), add = TRUE)
pm_apply_grouped_function(
"pm_slice_min", .data, drop = TRUE, order_by = order_by, pm_n = pm_n, prop = prop, with_ties = with_ties, ...
)
}
pm_slice_max <- function(.data, order_by, ..., pm_n, prop, with_ties = TRUE) {
if ("grouped_data" %in% class(.data)) {
pm_slice_max.grouped_data(.data, ...)
} else {
pm_slice_max.default(.data, ...)
}
}
pm_slice_max.data.frame <- function(.data, order_by, ..., pm_n, prop, with_ties = TRUE) {
if (missing(order_by)) stop("argument `order_by` is missing, with no default.")
size <- pm_check_slice_size(pm_n, prop)
idx <- if (isTRUE(with_ties)) {
switch(
size$type,
pm_n = function(x, pm_n) pm_vec_head(order(x, decreasing = TRUE), pm_smaller_ranks(pm_desc(x), size$pm_n)),
prop = function(x, pm_n) pm_vec_head(order(x, decreasing = TRUE), pm_smaller_ranks(pm_desc(x), size$prop * pm_n))
)
} else {
switch(
size$type,
pm_n = function(x, pm_n) pm_vec_head(order(x, decreasing = TRUE), size$pm_n),
prop = function(x, pm_n) pm_vec_head(order(x, decreasing = TRUE), size$prop * pm_n)
)
}
order_by <- .data[, pm_deparse_var(order_by)]
pm_slice(.data, idx(order_by, AMR:::pm_n()))
}
pm_slice_max.grouped_data <- function(.data, order_by, ..., pm_n, prop, with_ties = TRUE) {
pm_eval_env$env <- environment()
on.exit(rm(list = "env", envir = pm_eval_env), add = TRUE)
pm_apply_grouped_function(
"pm_slice_max", .data, drop = TRUE, order_by = order_by, pm_n = pm_n, prop = prop, with_ties = with_ties, ...
)
}
pm_slice_sample <- function(.data, ..., pm_n, prop, weight_by = NULL, replace = FALSE) {
if ("grouped_data" %in% class(.data)) {
pm_slice_sample.grouped_data(.data, ...)
} else {
pm_slice_sample.default(.data, ...)
}
}
pm_slice_sample.data.frame <- function(.data, ..., pm_n, prop, weight_by = NULL, replace = FALSE) {
size <- pm_check_slice_size(pm_n, prop)
idx <- switch(
size$type,
pm_n = function(x, pm_n) pm_sample_int(pm_n, size$pm_n, replace = replace, wt = x),
prop = function(x, pm_n) pm_sample_int(pm_n, size$prop * pm_n, replace = replace, wt = x),
)
weight_by <- pm_deparse_var(weight_by)
if (!is.null(weight_by)) weight_by <- .data[, weight_by]
pm_slice(.data, idx(weight_by, AMR:::pm_n()))
}
pm_slice_sample.grouped_data <- function(.data, ..., pm_n, prop, weight_by = NULL, replace = FALSE) {
pm_eval_env$env <- environment()
on.exit(rm(list = "env", envir = pm_eval_env), add = TRUE)
pm_apply_grouped_function(
"pm_slice_sample", .data, drop = TRUE, pm_n = pm_n, prop = prop, weight_by = weight_by, replace = replace, ...
)
}
# helpers ----------------------------------------------------------------------
pm_slice_positions <- function(.data, ...) {
conditions <- pm_dotdotdot(...)
pm_context$setup(.data)
on.exit(pm_context$clean(), add = TRUE)
if (length(conditions) == 0L) return(seq_len(pm_n()))
frame <- parent.frame(2L)
rows <- lapply(
conditions,
function(cond, frame) {
res <- eval(cond, pm_context$.data, frame)
if (is.logical(res) && all(is.na(res))) {
res <- integer()
} else if (is.numeric(res)) {
res <- as.integer(res)
} else if (!is.integer(res)) {
stop("`pm_slice()` expressions should return indices (positive or negative integers).")
}
},
frame = frame
)
rows <- do.call(c, rows)
if (length(rows) == 0L) {
# do nothing
} else if (all(rows >= 0, na.rm = TRUE)) {
rows <- rows[!is.na(rows) & rows <= pm_n() & rows > 0]
} else if (all(rows <= 0, na.rm = TRUE)) {
rows <- setdiff(seq_len(pm_n()), -rows)
} else {
stop("`pm_slice()` expressions should return either all positive or all negative.")
}
rows
}
pm_check_slice_size <- function(pm_n, prop) {
if (missing(pm_n) && missing(prop)) {
list(type = "pm_n", pm_n = 1L)
} else if (!missing(pm_n) && missing(prop)) {
if (!is.numeric(pm_n) || length(pm_n) != 1) {
stop("`pm_n` must be a single number.")
}
if (is.na(pm_n) || pm_n < 0) {
stop("`pm_n` must be a non-missing positive number.")
}
list(type = "pm_n", pm_n = pm_n)
} else if (!missing(prop) && missing(pm_n)) {
if (!is.numeric(prop) || length(prop) != 1) {
stop("`prop` must be a single number.")
}
if (is.na(prop) || prop < 0) {
stop("`prop` must be a non-missing positive number.")
}
list(type = "prop", prop = prop)
} else {
stop("Must supply exactly one of `pm_n` and `prop` arguments.")
}
}
pm_sample_int <- function(pm_n, size, replace = FALSE, wt = NULL) {
if (isTRUE(replace)) {
sample.int(pm_n, size, prob = wt, replace = TRUE)
} else {
sample.int(pm_n, min(size, pm_n), prob = wt)
pm_select <- function(.data, ...) {
col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
map_names <- names(col_pos)
map_names_length <- nchar(map_names)
if (any(map_names_length == 0L)) {
no_new_names <- which(map_names_length == 0L)
map_names[no_new_names] <- colnames(.data)[no_new_names]
}
}
pm_smaller_ranks <- function(x, y) {
sum(pm_min_rank(x) <= y, na.rm = TRUE)
res <- .data[, col_pos, drop = FALSE]
if (!is.null(map_names) && all(col_pos > 0L)) colnames(res) <- map_names
if (pm_has_groups(.data)) res <- pm_set_groups(res, pm_get_groups(.data))
res
}
pm_summarise <- function(.data, ...) {
pm_check_is_dataframe(.data)

12
R/ab.R
Unescape Escape View File

@ -104,7 +104,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
x_bak_clean <- generalise_antibiotic_name(x_bak_clean)
}
x <- unique(x_bak_clean)
x <- unique(x_bak_clean) # this means that every x is in fact generalise_antibiotic_name(x)
x_new <- rep(NA_character_, length(x))
x_unknown <- character(0)
@ -174,7 +174,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
# exact LOINC code
loinc_found <- unlist(lapply(AB_lookup$generalised_loinc,
function(s) generalise_antibiotic_name(x[i]) %in% s))
function(s) x[i] %in% s))
found <- antibiotics$ab[loinc_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@ -183,7 +183,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
# exact synonym
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms,
function(s) generalise_antibiotic_name(x[i]) %in% s))
function(s) x[i] %in% s))
found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@ -192,7 +192,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
# exact abbreviation
abbr_found <- unlist(lapply(AB_lookup$generalised_abbreviations,
function(s) generalise_antibiotic_name(x[i]) %in% s))
function(s) x[i] %in% s))
found <- antibiotics$ab[abbr_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@ -244,7 +244,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
# and try if any synonym starts with it
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms,
function(s) any(generalise_antibiotic_name(s) %like% paste0("^", x_spelling))))
function(s) any(s %like% paste0("^", x_spelling))))
found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
@ -532,7 +532,7 @@ generalise_antibiotic_name <- function(x) {
# remove part between brackets if that's followed by another string
x <- gsub("(.*)+ [(].*[)]", "\\1", x)
# keep only max 1 space
x <- trimws(gsub(" +", " ", x))
x <- trimws2(gsub(" +", " ", x))
# non-character, space or number should be a slash
x <- gsub("[^A-Z0-9 -]", "/", x)
# spaces around non-characters must be removed: amox + clav -> amox/clav

2
R/bug_drug_combinations.R
Unescape Escape View File

@ -199,7 +199,7 @@ format.bug_drug_combinations <- function(x,
select_ab_vars() %pm>%
pm_arrange(ab_group, ab_txt)
y <- y %pm>%
create_var(ab_group = ifelse(y$ab_group != lag(y$ab_group) | is.na(pm_lag(y$ab_group)), y$ab_group, ""))
create_var(ab_group = ifelse(y$ab_group != pm_lag(y$ab_group) | is.na(pm_lag(y$ab_group)), y$ab_group, ""))
if (add_ab_group == FALSE) {
y <- y %pm>%

4
R/mo.R
Unescape Escape View File

@ -109,10 +109,10 @@
#' 3. The level of uncertainty \eqn{U} needed to get to the result, as stated above (1 to 3);
#' 4. The [Levenshtein distance](https://en.wikipedia.org/wiki/Levenshtein_distance) \eqn{L} is the distance between the user input and all taxonomic full names, with the text length of the user input being the maximum distance. A modified version of the Levenshtein distance \eqn{L'} based on the text length of the full name \eqn{F} is calculated as:
#'
#' \deqn{L' = F - \frac{0.5 \times L}{F}}{L' = F - (0.5 * L) / F}
#' \deqn{L' = F - \frac{0.5L}{F}}{L' = (F - 0.5L) / F}
#'
#' The final matching score \eqn{M} is calculated as:
#' \deqn{M = L' \times \frac{1}{P \times K} * \frac{1}{U}}{M = L' * (1 / (P * K)) * (1 / U)}
#' \deqn{M = L' \times \frac{1}{P K U} = \frac{F - 0.5L}{F P K U}}{M = L' * (1 / (P * K * U)) = (F - 0.5L) / (F * P * K * U)}
#'
#' All matches are sorted descending on their matching score and for all user input values, the top match will be returned.
#' @inheritSection catalogue_of_life Catalogue of Life

23
R/mo_matching_score.R
Unescape Escape View File

@ -32,10 +32,10 @@
#' 3. The level of uncertainty \eqn{U} that is needed to get to a result (1 to 3, see [as.mo()]);
#' 4. The [Levenshtein distance](https://en.wikipedia.org/wiki/Levenshtein_distance) \eqn{L} is the distance between the user input and all taxonomic full names, with the text length of the user input being the maximum distance. A modified version of the Levenshtein distance \eqn{L'} based on the text length of the full name \eqn{F} is calculated as:
#'
#' \deqn{L' = F - \frac{0.5 \times L}{F}}{L' = F - (0.5 * L) / F}
#' \deqn{L' = F - \frac{0.5L}{F}}{L' = (F - 0.5L) / F}
#'
#' The final matching score \eqn{M} is calculated as:
#' \deqn{M = L' \times \frac{1}{P \times K} * \frac{1}{U}}{M = L' * (1 / (P * K)) * (1 / U)}
#' \deqn{M = L' \times \frac{1}{P K U} = \frac{F - 0.5L}{F P K U}}{M = L' * (1 / (P * K * U)) = (F - 0.5L) / (F * P * K * U)}
#'
#' @export
#' @examples
@ -55,9 +55,18 @@ mo_matching_score <- function(x, fullname, uncertainty = 1) {
levenshtein[i] <- min(as.double(utils::adist(x[i], fullname[i], ignore.case = FALSE)),
nchar(fullname[i]))
}
# self-made score between 0 and 1 (for % certainty, so 0 means huge distance, 1 means no distance)
dist <- (nchar(fullname) - 0.5 * levenshtein) / nchar(fullname)
prevalence_kingdom_index <- tryCatch(MO_lookup[match(fullname, MO_lookup$fullname), "prevalence_kingdom_index", drop = TRUE],
error = function(e) rep(1, length(fullname)))
dist * (1 / prevalence_kingdom_index) * (1 / uncertainty)
# F = length of fullname
var_F <- nchar(fullname)
# L = modified Levenshtein distance
var_L <- levenshtein
# P = Prevalence (1 to 3)
var_P <- MO_lookup[match(fullname, MO_lookup$fullname), "prevalence", drop = TRUE]
# K = kingdom index (Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5)
var_K <- MO_lookup[match(fullname, MO_lookup$fullname), "kingdom_index", drop = TRUE]
# U = uncertainty level (1 to 3), as per as.mo()
var_U <- uncertainty
# matching score:
(var_F - 0.5 * L) / (var_F * var_P * var_K * var_U)
}

2
R/rsi_calc.R
Unescape Escape View File

@ -268,7 +268,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res))
res <- set_groups(res, groups[groups %in% colnames(res)])
res <- pm_set_groups(res, groups[groups %in% colnames(res)])
}
res
}

2
R/zzz.R
Unescape Escape View File

@ -84,8 +84,6 @@ create_MO_lookup <- function() {
# all the rest
MO_lookup[which(is.na(MO_lookup$kingdom_index)), "kingdom_index"] <- 5
MO_lookup$prevalence_kingdom_index <- MO_lookup$prevalence * MO_lookup$kingdom_index
# use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
MO_lookup$fullname_lower <- tolower(trimws(paste(MO_lookup$genus,
MO_lookup$species,

8
data-raw/reproduction_of_poorman.R
Unescape Escape View File

@ -7,9 +7,11 @@ files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/
rvest::html_attr("href")
# get full URLs of all raw R files
files <- paste0("https://raw.githubusercontent.com", gsub("blob/", "", files[files %like% "/R/.*.R$"]))
files <- sort(paste0("https://raw.githubusercontent.com", gsub("blob/", "", files[files %like% "/R/.*.R$"])))
# remove files with only pkg specific code
files <- files[!files %like% "(zzz.R|init.R)"]
files <- files[!files %like% "(zzz|init)[.]R$"]
# also, there's a lot of functions we don't use
files <- files[!files %like% "(slice|glimpse|recode|replace_na|coalesce)[.]R$"]
# add our prepend file, containing info about the source of the data
intro <- readLines("data-raw/poorman_prepend.R")
@ -68,8 +70,6 @@ contents <- gsub("context", "pm_context", contents, fixed = TRUE)
contents <- gsub("(pm_)+", "pm_", contents)
# special case for pm_distinct(), we need '.keep_all' to work
contents <- gsub("pm_distinct <- function(.data, ..., .keep_all = FALSE)", "pm_distinct <- function(.data, ...)", contents, fixed = TRUE)
# removes unnecessary calls to package
contents <- gsub("poorman::", "AMR:::", contents, fixed = TRUE)
# who needs US spelling?
contents <- contents[!grepl("summarize", contents)]

2
docs/404.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR/index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

2
docs/LICENSE-text.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

2
docs/articles/index.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

2
docs/authors.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

2
docs/index.html
Unescape Escape View File

@ -43,7 +43,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

12
docs/news/index.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>
@ -236,13 +236,13 @@
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
</div>
<div id="amr-1309022" class="section level1">
<h1 class="page-header" data-toc-text="1.3.0.9022">
<a href="#amr-1309022" class="anchor"></a>AMR 1.3.0.9022<small> Unreleased </small>
<div id="amr-1309023" class="section level1">
<h1 class="page-header" data-toc-text="1.3.0.9023">
<a href="#amr-1309023" class="anchor"></a>AMR 1.3.0.9023<small> Unreleased </small>
</h1>
<div id="last-updated-18-september-2020" class="section level2">
<div id="last-updated-19-september-2020" class="section level2">
<h2 class="hasAnchor">
<a href="#last-updated-18-september-2020" class="anchor"></a><small>Last updated: 18 September 2020</small>
<a href="#last-updated-19-september-2020" class="anchor"></a><small>Last updated: 19 September 2020</small>
</h2>
<p>Note: some changes in this version were suggested by anonymous reviewers from the journal we submitted our manuscipt to. We are those reviewers very grateful for going through our code so thoroughly!</p>
<div id="new" class="section level3">

2
docs/pkgdown.yml
Unescape Escape View File

@ -2,7 +2,7 @@ pandoc: 2.7.3
pkgdown: 1.5.1.9000
pkgdown_sha: eae56f08694abebf93cdfc0dd8e9ede06d8c815f
articles: []
last_built: 2020-09-18T14:05Z
last_built: 2020-09-19T09:53Z
urls:
reference: https://msberends.github.io/AMR/reference
article: https://msberends.github.io/AMR/articles

6
docs/reference/as.mo.html
Unescape Escape View File

@ -82,7 +82,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>
@ -376,9 +376,9 @@
<li><p>The <a href='https://en.wikipedia.org/wiki/Levenshtein_distance'>Levenshtein distance</a> \(L\) is the distance between the user input and all taxonomic full names, with the text length of the user input being the maximum distance. A modified version of the Levenshtein distance \(L'\) based on the text length of the full name \(F\) is calculated as:</p></li>
</ol>
<p>$$L' = F - \frac{0.5 \times L}{F}$$</p>
<p>$$L' = F - \frac{0.5L}{F}$$</p>
<p>The final matching score \(M\) is calculated as:
$$M = L' \times \frac{1}{P \times K} * \frac{1}{U}$$</p>
$$M = L' \times \frac{1}{P K U} = \frac{F - 0.5L}{F P K U}$$</p>
<p>All matches are sorted descending on their matching score and for all user input values, the top match will be returned.</p>
<h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2>

2
docs/reference/index.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

6
docs/reference/mo_matching_score.html
Unescape Escape View File

@ -82,7 +82,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>
@ -270,9 +270,9 @@
<li><p>The <a href='https://en.wikipedia.org/wiki/Levenshtein_distance'>Levenshtein distance</a> \(L\) is the distance between the user input and all taxonomic full names, with the text length of the user input being the maximum distance. A modified version of the Levenshtein distance \(L'\) based on the text length of the full name \(F\) is calculated as:</p></li>
</ol>
<p>$$L' = F - \frac{0.5 \times L}{F}$$</p>
<p>$$L' = F - \frac{0.5L}{F}$$</p>
<p>The final matching score \(M\) is calculated as:
$$M = L' \times \frac{1}{P \times K} * \frac{1}{U}$$</p>
$$M = L' \times \frac{1}{P K U} = \frac{F - 0.5L}{F P K U}$$</p>
<h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2>
<pre class="examples"><span class='fu'><a href='as.mo.html'>as.mo</a></span>(<span class='st'>"E. coli"</span>)

2
docs/survey.html
Unescape Escape View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9022</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9023</span>
</span>
</div>

4
man/as.mo.Rd
Unescape Escape View File

@ -136,10 +136,10 @@ With ambiguous user input, the returned results are chosen based on their matchi
\item The \href{https://en.wikipedia.org/wiki/Levenshtein_distance}{Levenshtein distance} \eqn{L} is the distance between the user input and all taxonomic full names, with the text length of the user input being the maximum distance. A modified version of the Levenshtein distance \eqn{L'} based on the text length of the full name \eqn{F} is calculated as:
}
\deqn{L' = F - \frac{0.5 \times L}{F}}{L' = F - (0.5 * L) / F}
\deqn{L' = F - \frac{0.5L}{F}}{L' = (F - 0.5L) / F}
The final matching score \eqn{M} is calculated as:
\deqn{M = L' \times \frac{1}{P \times K} * \frac{1}{U}}{M = L' * (1 / (P * K)) * (1 / U)}
\deqn{M = L' \times \frac{1}{P K U} = \frac{F - 0.5L}{F P K U}}{M = L' * (1 / (P * K * U)) = (F - 0.5L) / (F * P * K * U)}
All matches are sorted descending on their matching score and for all user input values, the top match will be returned.
}

4
man/mo_matching_score.Rd
Unescape Escape View File

@ -25,10 +25,10 @@ The matching score is based on four parameters:
\item The \href{https://en.wikipedia.org/wiki/Levenshtein_distance}{Levenshtein distance} \eqn{L} is the distance between the user input and all taxonomic full names, with the text length of the user input being the maximum distance. A modified version of the Levenshtein distance \eqn{L'} based on the text length of the full name \eqn{F} is calculated as:
}
\deqn{L' = F - \frac{0.5 \times L}{F}}{L' = F - (0.5 * L) / F}
\deqn{L' = F - \frac{0.5L}{F}}{L' = (F - 0.5L) / F}
The final matching score \eqn{M} is calculated as:
\deqn{M = L' \times \frac{1}{P \times K} * \frac{1}{U}}{M = L' * (1 / (P * K)) * (1 / U)}
\deqn{M = L' \times \frac{1}{P K U} = \frac{F - 0.5L}{F P K U}}{M = L' * (1 / (P * K * U)) = (F - 0.5L) / (F * P * K * U)}
}
\examples{
as.mo("E. coli")

1
tests/testthat.R
Unescape Escape View File

@ -23,4 +23,3 @@ library(testthat)
library(AMR)
test_check("AMR")
unlink("tests/testthat/Rplots.pdf")

16
tests/testthat/test-_all_examples.R
Unescape Escape View File

@ -19,19 +19,3 @@
# Visit our website for more info: https://msberends.github.io/AMR. #
# ==================================================================== #
# context("All examples")
#
# # run all examples (will take forever)
# exported_functions <- ls("package:AMR")
#
# for (i in seq_len(length(exported_functions))) {
# test_that(paste(exported_functions[i], "works"), {
# skip_on_cran()
# expect_output(suppressWarnings(example(exported_functions[i],
# package = "AMR",
# give.lines = TRUE,
# run.dontrun = TRUE,
# run.donttest = TRUE)),
# label = paste0("Examples of function ", exported_functions[i]))
# })
# }

8
tests/testthat/test-mic.R
Unescape Escape View File

@ -38,10 +38,10 @@ test_that("mic works", {
expect_warning(as.mic("INVALID VALUE"))
# print plots, should not raise errors
barplot(as.mic(c(1, 2, 4, 8)))
plot(as.mic(c(1, 2, 4, 8)))
print(as.mic(c(1, 2, 4, 8)))
# print plots
expect_success(x <- barplot(as.mic(c(1, 2, 4, 8))))
expect_success(x <- plot(as.mic(c(1, 2, 4, 8))))
expect_success(x <- print(as.mic(c(1, 2, 4, 8))))
expect_equal(summary(as.mic(c(2, 8))),
structure(c("Class" = "mic",

4
tests/testthat/test-resistance_predict.R
Unescape Escape View File

@ -35,8 +35,8 @@ test_that("prediction of rsi works", {
expect_true(AMX_R[3] < AMX_R[20])
x <- resistance_predict(example_isolates, col_ab = "AMX", year_min = 2010, model = "binomial")
plot(x)
ggplot_rsi_predict(x)
expect_success(y <- plot(x))
expect_success(y <- ggplot_rsi_predict(x))
expect_error(ggplot_rsi_predict(example_isolates))
library(dplyr)

10
tests/testthat/test-rsi.R
Unescape Escape View File

@ -27,14 +27,14 @@ test_that("rsi works", {
expect_true(as.rsi("S") < as.rsi("I"))
expect_true(as.rsi("I") < as.rsi("R"))
expect_true(is.rsi(as.rsi("S")))
# print plots, should not raise errors
barplot(as.rsi(c("S", "I", "R")))
plot(as.rsi(c("S", "I", "R")))
print(as.rsi(c("S", "I", "R")))
expect_success(x <- barplot(as.rsi(c("S", "I", "R"))))
expect_success(x <- plot(as.rsi(c("S", "I", "R"))))
expect_success(x <- print(as.rsi(c("S", "I", "R"))))
expect_equal(as.character(as.rsi(c(1:3))), c("S", "I", "R"))
expect_equal(suppressWarnings(as.logical(as.rsi("INVALID VALUE"))), NA)
expect_equal(summary(as.rsi(c("S", "R"))),

Write Preview
Loading…
Cancel
Save