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

(v1.3.0.9023) optimalisation

This commit is contained in:
dr. M.S. (Matthijs) Berends 2020-09-19 11:54:01 +02:00
parent 4e40e42011
commit d049cce69b
30 changed files with 104 additions and 578 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -62,5 +62,5 @@ jobs:
shell: Rscript {0} shell: Rscript {0}
- name: Lint - 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} shell: Rscript {0}

4
DESCRIPTION
View File

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

4
NEWS.md
View File

@ -1,5 +1,5 @@
# AMR 1.3.0.9022 # AMR 1.3.0.9023
## <small>Last updated: 18 September 2020</small> ## <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! 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
View File

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

530
R/aa_helper_pm_functions.R
View File

@ -36,7 +36,7 @@
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software # 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. # 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: # https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/LICENSE:
# YEAR: 2020 # YEAR: 2020
# COPYRIGHT HOLDER: Nathan Eastwood # COPYRIGHT HOLDER: Nathan Eastwood
@ -67,28 +67,6 @@ pm_between <- function(x, left, right) {
if (!is.double(x)) x <- as.numeric(x) if (!is.double(x)) x <- as.numeric(x)
x >= as.numeric(left) & x <= as.numeric(right) 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() pm_context <- new.env()
# Data # Data
@ -288,23 +266,6 @@ pm_filter.grouped_data <- function(.data, ...) {
res <- pm_apply_grouped_function("pm_filter", .data, drop = TRUE, ...) res <- pm_apply_grouped_function("pm_filter", .data, drop = TRUE, ...)
res[rows[rows %in% rownames(res)], ] 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_group_by <- function(.data, ..., .add = FALSE) {
pm_check_is_dataframe(.data) pm_check_is_dataframe(.data)
pre_groups <- pm_get_groups(.data) pre_groups <- pm_get_groups(.data)
@ -481,6 +442,27 @@ pm_if_else <- function(condition, true, false, missing = NULL) {
res 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_inner_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
pm_join_worker(x = x, y = y, by = by, suffix = suffix, sort = FALSE) 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 = "") 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) { 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 (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") 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] .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) { pm_set_names <- function(object = nm, nm) {
names(object) <- nm names(object) <- nm
object 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]) if (grouped) .data <- pm_set_groups(.data, colnames(.data)[grp_pos])
.data .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) { pm_replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) return(x) if (is.null(val)) return(x)
pm_check_length(val, x, arg_name) pm_check_length(val, x, arg_name)
@ -937,20 +712,6 @@ pm_rownames_to_column <- function(.data, var = "rowname") {
rownames(.data) <- NULL rownames(.data) <- NULL
.data[, c(var, setdiff(col_names, var))] .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()) { pm_starts_with <- function(match, ignore.case = TRUE, vars = pm_peek_vars()) {
grep(pattern = paste0("^", paste0(match, collapse = "|^")), x = vars, ignore.case = ignore.case) 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_nrow <- function() nrow(pm_select_env$.data)
pm_select_env$get_ncol <- function() ncol(pm_select_env$.data) pm_select_env$get_ncol <- function() ncol(pm_select_env$.data)
pm_slice <- function(.data, ...) { pm_select <- function(.data, ...) {
pm_check_is_dataframe(.data) col_pos <- pm_select_positions(.data, ..., .group_pos = TRUE)
if ("grouped_data" %in% class(.data)) { map_names <- names(col_pos)
pm_slice.grouped_data(.data, ...) map_names_length <- nchar(map_names)
} else { if (any(map_names_length == 0L)) {
pm_slice.default(.data, ...) 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
pm_slice.data.frame <- function(.data, ...) { if (pm_has_groups(.data)) res <- pm_set_groups(res, pm_get_groups(.data))
if (nrow(.data) == 0L) return(.data) res
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_smaller_ranks <- function(x, y) {
sum(pm_min_rank(x) <= y, na.rm = TRUE)
} }
pm_summarise <- function(.data, ...) { pm_summarise <- function(.data, ...) {
pm_check_is_dataframe(.data) pm_check_is_dataframe(.data)

12
R/ab.R
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_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_new <- rep(NA_character_, length(x))
x_unknown <- character(0) x_unknown <- character(0)
@ -174,7 +174,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
# exact LOINC code # exact LOINC code
loinc_found <- unlist(lapply(AB_lookup$generalised_loinc, 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] found <- antibiotics$ab[loinc_found == TRUE]
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) 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 # exact synonym
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms, 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] found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) 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 # exact abbreviation
abbr_found <- unlist(lapply(AB_lookup$generalised_abbreviations, 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] found <- antibiotics$ab[abbr_found == TRUE]
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) 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 # and try if any synonym starts with it
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms, 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] found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) { if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text) 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 # remove part between brackets if that's followed by another string
x <- gsub("(.*)+ [(].*[)]", "\\1", x) x <- gsub("(.*)+ [(].*[)]", "\\1", x)
# keep only max 1 space # keep only max 1 space
x <- trimws(gsub(" +", " ", x)) x <- trimws2(gsub(" +", " ", x))
# non-character, space or number should be a slash # non-character, space or number should be a slash
x <- gsub("[^A-Z0-9 -]", "/", x) x <- gsub("[^A-Z0-9 -]", "/", x)
# spaces around non-characters must be removed: amox + clav -> amox/clav # spaces around non-characters must be removed: amox + clav -> amox/clav

2
R/bug_drug_combinations.R
View File

@ -199,7 +199,7 @@ format.bug_drug_combinations <- function(x,
select_ab_vars() %pm>% select_ab_vars() %pm>%
pm_arrange(ab_group, ab_txt) pm_arrange(ab_group, ab_txt)
y <- y %pm>% 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) { if (add_ab_group == FALSE) {
y <- y %pm>% y <- y %pm>%

4
R/mo.R
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); #' 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: #' 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: #' 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. #' 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 #' @inheritSection catalogue_of_life Catalogue of Life

23
R/mo_matching_score.R
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()]); #' 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: #' 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: #' 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 #' @export
#' @examples #' @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)), levenshtein[i] <- min(as.double(utils::adist(x[i], fullname[i], ignore.case = FALSE)),
nchar(fullname[i])) 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) # F = length of fullname
prevalence_kingdom_index <- tryCatch(MO_lookup[match(fullname, MO_lookup$fullname), "prevalence_kingdom_index", drop = TRUE], var_F <- nchar(fullname)
error = function(e) rep(1, length(fullname))) # L = modified Levenshtein distance
dist * (1 / prevalence_kingdom_index) * (1 / uncertainty) 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
View File

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

2
R/zzz.R
View File

@ -84,8 +84,6 @@ create_MO_lookup <- function() {
# all the rest # all the rest
MO_lookup[which(is.na(MO_lookup$kingdom_index)), "kingdom_index"] <- 5 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. # 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$fullname_lower <- tolower(trimws(paste(MO_lookup$genus,
MO_lookup$species, MO_lookup$species,

8
data-raw/reproduction_of_poorman.R
View File

@ -7,9 +7,11 @@ files <- xml2::read_html(paste0("https://github.com/nathaneastwood/poorman/tree/
rvest::html_attr("href") rvest::html_attr("href")
# get full URLs of all raw R files # 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 # 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 # add our prepend file, containing info about the source of the data
intro <- readLines("data-raw/poorman_prepend.R") intro <- readLines("data-raw/poorman_prepend.R")
@ -68,8 +70,6 @@ contents <- gsub("context", "pm_context", contents, fixed = TRUE)
contents <- gsub("(pm_)+", "pm_", contents) contents <- gsub("(pm_)+", "pm_", contents)
# special case for pm_distinct(), we need '.keep_all' to work # 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) 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? # who needs US spelling?
contents <- contents[!grepl("summarize", contents)] contents <- contents[!grepl("summarize", contents)]

2
docs/404.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR/index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/LICENSE-text.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/articles/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/authors.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

2
docs/index.html
View File

@ -43,7 +43,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

12
docs/news/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </div>
@ -236,13 +236,13 @@
<small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small> <small>Source: <a href='https://github.com/msberends/AMR/blob/master/NEWS.md'><code>NEWS.md</code></a></small>
</div> </div>
<div id="amr-1309022" class="section level1"> <div id="amr-1309023" class="section level1">
<h1 class="page-header" data-toc-text="1.3.0.9022"> <h1 class="page-header" data-toc-text="1.3.0.9023">
<a href="#amr-1309022" class="anchor"></a>AMR 1.3.0.9022<small> Unreleased </small> <a href="#amr-1309023" class="anchor"></a>AMR 1.3.0.9023<small> Unreleased </small>
</h1> </h1>
<div id="last-updated-18-september-2020" class="section level2"> <div id="last-updated-19-september-2020" class="section level2">
<h2 class="hasAnchor"> <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> </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> <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"> <div id="new" class="section level3">

2
docs/pkgdown.yml
View File

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

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

@ -82,7 +82,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </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> <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> </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: <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> <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> <h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2>

2
docs/reference/index.html
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </div>

6
docs/reference/mo_matching_score.html
View File

@ -82,7 +82,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a> <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> </span>
</div> </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> <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> </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: <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> <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>) <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
View File

@ -81,7 +81,7 @@
</button> </button>
<span class="navbar-brand"> <span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a> <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> </span>
</div> </div>

4
man/as.mo.Rd
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: \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: 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. 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
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: \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: 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{ \examples{
as.mo("E. coli") as.mo("E. coli")

1
tests/testthat.R
View File

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

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

@ -19,19 +19,3 @@
# Visit our website for more info: https://msberends.github.io/AMR. # # 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
View File

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

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

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

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

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