P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 22:22:03 +02:00
Code Releases Activity

(v1.3.0.9030) matching score update

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2020-09-26 16:26:01 +02:00
parent 9667c2994f
commit 050a9a04fb
33 changed files with 249 additions and 175 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
R/aa_helper_functions.R
View File

@ -48,18 +48,6 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
rownames(merged) <- NULL
merged
}
# 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))
# 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
# }
quick_case_when <- function(...) {
vectors <- list(...)

88
R/join_microorganisms.R
View File

@ -27,12 +27,12 @@
#' @name join
#' @aliases join inner_join
#' @param x existing table to join, or character vector
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (like `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("my_genus_species" = "fullname")`)
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (like `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("bacteria_id" = "fullname")`)
#' @param suffix if there are non-joined duplicate variables in `x` and `y`, these suffixes will be added to the output to disambiguate them. Should be a character vector of length 2.
#' @param ... ignored
#' @details **Note:** As opposed to the `join()` functions of `dplyr`, [character] vectors are supported and at default existing columns will get a suffix `"2"` and the newly joined columns will not get a suffix.
#'
#' These functions rely on [merge()], a base R function to do joins.
#' If the `dplyr` package is installed, their join functions will be used. Otherwise, the much slower [merge()] function from base R will be used.
#' @inheritSection AMR Read more on our website!
#' @export
#' @examples
@ -60,9 +60,17 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x_class <- get_prejoined_class(x)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
pm_inner_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
# use dplyr if available - it's much faster
dplyr_inner <- import_fn("inner_join", "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_inner)) {
join <- suppressWarnings(
dplyr_inner(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
} else {
join <- suppressWarnings(
pm_inner_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
@ -79,9 +87,17 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x_class <- get_prejoined_class(x)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
pm_left_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
# use dplyr if available - it's much faster
dplyr_left <- import_fn("left_join", "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_left)) {
join <- suppressWarnings(
dplyr_left(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
} else {
join <- suppressWarnings(
pm_left_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
@ -98,9 +114,17 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x_class <- get_prejoined_class(x)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
pm_right_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
# use dplyr if available - it's much faster
dplyr_right <- import_fn("right_join", "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_right)) {
join <- suppressWarnings(
dplyr_right(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
} else {
join <- suppressWarnings(
pm_right_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
@ -117,9 +141,17 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
x_class <- get_prejoined_class(x)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
pm_full_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
# use dplyr if available - it's much faster
dplyr_full <- import_fn("full_join", "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_full)) {
join <- suppressWarnings(
dplyr_full(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
} else {
join <- suppressWarnings(
pm_full_join(x = x, y = microorganisms, by = by, suffix = suffix, ...)
)
}
if (NROW(join) > NROW(x)) {
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
@ -136,9 +168,17 @@ semi_join_microorganisms <- function(x, by = NULL, ...) {
checked <- joins_check_df(x, by)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
pm_semi_join(x = x, y = microorganisms, by = by, ...)
)
# use dplyr if available - it's much faster
dplyr_semi <- import_fn("semi_join", "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_semi)) {
join <- suppressWarnings(
dplyr_semi(x = x, y = microorganisms, by = by,...)
)
} else {
join <- suppressWarnings(
pm_semi_join(x = x, y = microorganisms, by = by,...)
)
}
class(join) <- x_class
join
}
@ -152,9 +192,17 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
x_class <- get_prejoined_class(x)
x <- checked$x
by <- checked$by
join <- suppressWarnings(
pm_anti_join(x = x, y = microorganisms, by = by, ...)
)
# use dplyr if available - it's much faster
dplyr_anti <- import_fn("anti_join", "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_anti)) {
join <- suppressWarnings(
dplyr_anti(x = x, y = microorganisms, by = by,...)
)
} else {
join <- suppressWarnings(
pm_anti_join(x = x, y = microorganisms, by = by,...)
)
}
class(join) <- x_class
join
}

32
R/mo.R
View File

@ -101,20 +101,7 @@
#'
#' Group 3 (least prevalent microorganisms) consists of all other microorganisms. This group contains microorganisms most probably not found in humans.
#'
#' ## Background on matching scores
#' With ambiguous user input, the returned results are chosen based on their matching score using [mo_matching_score()]. This matching score is based on four parameters:
#'
#' 1. The prevalence \eqn{P} is categorised into group 1, 2 and 3 as stated above;
#' 2. A kingdom index \eqn{K} is set as follows: Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, and all others = 5;
#' 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' = 1 - \frac{0.5L}{F}}{L' = 1 - ((0.5 * L) / F)}
#'
#' The final matching score \eqn{M} is calculated as:
#' \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 mo_matching_score Matching score for microorganisms
#' @inheritSection catalogue_of_life Catalogue of Life
# (source as a section here, so it can be inherited by other man pages:)
#' @section Source:
@ -331,8 +318,7 @@ exec_as.mo <- function(x,
if (NROW(res_df) > 1 & uncertainty != -1) {
# sort the findings on matching score
scores <- mo_matching_score(x = input,
fullname = res_df[, "fullname", drop = TRUE],
uncertainty = uncertainty)
fullname = res_df[, "fullname", drop = TRUE])
res_df <- res_df[order(scores, decreasing = TRUE), , drop = FALSE]
}
res <- as.character(res_df[, column, drop = TRUE])
@ -1779,7 +1765,7 @@ print.mo_uncertainties <- function(x, ...) {
if (NROW(x) == 0) {
return(NULL)
}
cat(font_blue(strwrap(c("Matching scores are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name. Furthermore, an indication is given about the probability of the match - the more transformations are needed for coercion, the more improbable the result.")), collapse = "\n"))
cat(font_blue(strwrap(c("Matching scores are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name. Furthermore, an indication is given about the certainty of the match - the more transformations are needed for coercion, the less certain the result.")), collapse = "\n"))
cat("\n")
msg <- ""
@ -1787,8 +1773,7 @@ print.mo_uncertainties <- function(x, ...) {
if (x[i, ]$candidates != "") {
candidates <- unlist(strsplit(x[i, ]$candidates, ", ", fixed = TRUE))
scores <- mo_matching_score(x = x[i, ]$input,
fullname = candidates,
uncertainty = x[i, ]$uncertainty)
fullname = candidates)
# sort on descending scores
candidates <- candidates[order(1 - scores)]
n_candidates <- length(candidates)
@ -1802,11 +1787,11 @@ print.mo_uncertainties <- function(x, ...) {
candidates <- ""
}
if (x[i, ]$uncertainty == 1) {
uncertainty_interpretation <- font_green("* MOST PROBABLE *")
uncertainty_interpretation <- font_green("* very certain *")
} else if (x[i, ]$uncertainty == 1) {
uncertainty_interpretation <- font_yellow("* PROBABLE *")
uncertainty_interpretation <- font_yellow("* certain *")
} else {
uncertainty_interpretation <- font_red("* IMPROBABLE *")
uncertainty_interpretation <- font_red("* not certain *")
}
msg <- paste(msg,
paste0('"', x[i, ]$input, '" -> ',
@ -1814,8 +1799,7 @@ print.mo_uncertainties <- function(x, ...) {
ifelse(!is.na(x[i, ]$renamed_to), paste(", renamed to", font_italic(x[i, ]$renamed_to)), ""),
" (", x[i, ]$mo,
", matching score = ", trimws(percentage(mo_matching_score(x = x[i, ]$input,
fullname = x[i, ]$fullname,
uncertainty = x[i, ]$uncertainty),
fullname = x[i, ]$fullname),
digits = 1)),
") "),
uncertainty_interpretation,

53
R/mo_matching_score.R
View File

@ -23,50 +23,53 @@
#'
#' This helper function is used by [as.mo()] to determine the most probable match of taxonomic records, based on user input.
#' @param x Any user input value(s)
#' @param fullname A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
#' @param n A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
#' @param uncertainty The level of uncertainty set in [as.mo()], see `allow_uncertain` in that function (here, it defaults to 1, but is automatically determined in [as.mo()] based on the number of transformations needed to get to a result)
#' @details The matching score is based on four parameters:
#' @section Matching score for microorganisms:
#' With ambiguous user input in [as.mo()] and all the [`mo_*`][mo_property()] functions, the returned results are chosen based on their matching score using [mo_matching_score()]. This matching score \eqn{m} is calculated as:
#'
#' 1. A human pathogenic prevalence \eqn{P}, that is categorised into group 1, 2 and 3 (see [as.mo()]);
#' 2. A kingdom index \eqn{K} is set as follows: Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, and all others = 5;
#' 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' = 1 - \frac{0.5L}{F}}{L' = 1 - ((0.5 * L) / F)}
#'
#' The final matching score \eqn{M} is calculated as:
#' \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)}
#' \deqn{m_{(x, n)} = \frac{l_{n} - 0.5 \times \min \begin{cases}l_{n} \\ \operatorname{lev}(x, n)\end{cases}}{l_{n} p k}}{m(x, n) = ( l_n * min(l_n, lev(x, n) ) ) / ( l_n * p * k )}
#'
#' where:
#'
#' * \eqn{x} is the user input;
#' * \eqn{n} is a taxonomic name (genus, species and subspecies);
#' * \eqn{l_{n}}{l_n} is the length of the taxonomic name;
#' * \eqn{\operatorname{lev}}{lev} is the [Levenshtein distance](https://en.wikipedia.org/wiki/Levenshtein_distance) function;
#' * \eqn{p} is the human pathogenic prevalence, categorised into group \eqn{1}, \eqn{2} and \eqn{3} (see *Details* in `?as.mo`), meaning that \eqn{p = \{1, 2 , 3\}}{p = {1, 2, 3}};
#' * \eqn{k} is the kingdom index, set as follows: Bacteria = \eqn{1}, Fungi = \eqn{2}, Protozoa = \eqn{3}, Archaea = \eqn{4}, and all others = \eqn{5}, meaning that \eqn{k = \{1, 2 , 3, 4, 5\}}{k = {1, 2, 3, 4, 5}}.
#'
#' All matches are sorted descending on their matching score and for all user input values, the top match will be returned.
#' @export
#' @examples
#' as.mo("E. coli")
#' mo_uncertainties()
mo_matching_score <- function(x, fullname, uncertainty = 1) {
# fullname is always a taxonomically valid full name
#'
#' mo_matching_score("E. coli", "Escherichia coli")
mo_matching_score <- function(x, n) {
# n is always a taxonomically valid full name
levenshtein <- double(length = length(x))
if (length(fullname) == 1) {
fullname <- rep(fullname, length(x))
if (length(n) == 1) {
n <- rep(n, length(x))
}
if (length(x) == 1) {
x <- rep(x, length(fullname))
x <- rep(x, length(n))
}
for (i in seq_len(length(x))) {
# determine Levenshtein distance, but maximise to nchar of fullname
levenshtein[i] <- min(as.double(utils::adist(x[i], fullname[i], ignore.case = FALSE)),
nchar(fullname[i]))
# determine Levenshtein distance, but maximise to nchar of n
levenshtein[i] <- min(as.double(utils::adist(x[i], n[i], ignore.case = FALSE)),
nchar(n[i]))
}
# F = length of fullname
var_F <- nchar(fullname)
var_F <- nchar(n)
# L = modified Levenshtein distance
var_L <- levenshtein
# P = Prevalence (1 to 3)
var_P <- MO_lookup[match(fullname, MO_lookup$fullname), "prevalence", drop = TRUE]
var_P <- MO_lookup[match(n, 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
var_K <- MO_lookup[match(n, MO_lookup$fullname), "kingdom_index", drop = TRUE]
# matching score:
(var_F - 0.5 * var_L) / (var_F * var_P * var_K * var_U)
(var_F - 0.5 * var_L) / (var_F * var_P * var_K)
}

1
R/mo_property.R
View File

@ -42,6 +42,7 @@
#' All output will be [translate]d where possible.
#'
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species.
#' @inheritSection mo_matching_score Matching score for microorganisms
#' @inheritSection catalogue_of_life Catalogue of Life
#' @inheritSection as.mo Source
#' @rdname mo_property