1
0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 20:06:12 +01:00

(v1.3.0.9020) fix for uncertainty in as.mo()

This commit is contained in:
dr. M.S. (Matthijs) Berends 2020-09-14 19:41:48 +02:00
parent 354c606d6a
commit ab60f613aa
19 changed files with 100 additions and 84 deletions

View File

@ -1,5 +1,5 @@
Package: AMR Package: AMR
Version: 1.3.0.9019 Version: 1.3.0.9020
Date: 2020-09-14 Date: 2020-09-14
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(

View File

@ -1,4 +1,4 @@
# AMR 1.3.0.9019 # AMR 1.3.0.9020
## <small>Last updated: 14 September 2020</small> ## <small>Last updated: 14 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!

View File

@ -221,6 +221,7 @@ eucast_rules <- function(x,
col_mo <- search_type_in_df(x = x, type = "mo") col_mo <- search_type_in_df(x = x, type = "mo")
} }
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "`col_mo` must be set")
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
stop_ifnot(all(rules %in% c("breakpoints", "expert", "other", "all")), stop_ifnot(all(rules %in% c("breakpoints", "expert", "other", "all")),
'`rules` must be one or more of: "breakpoints", "expert", "other", "all".') '`rules` must be one or more of: "breakpoints", "expert", "other", "all".')

View File

@ -167,6 +167,7 @@ first_isolate <- function(x,
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo") col_mo <- search_type_in_df(x = x, type = "mo")
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "`col_mo` must be set")
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
} }
# -- date # -- date

View File

@ -150,6 +150,7 @@ mdro <- function(x,
col_mo <- "mo" col_mo <- "mo"
} }
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "`col_mo` must be set")
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
if (guideline$code == "cmi2012") { if (guideline$code == "cmi2012") {
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."

133
R/mo.R
View File

@ -288,6 +288,7 @@ exec_as.mo <- function(x,
actual_uncertainty = 1, actual_uncertainty = 1,
actual_input = NULL, actual_input = NULL,
language = get_locale()) { language = get_locale()) {
check_dataset_integrity() check_dataset_integrity()
lookup <- function(needle, lookup <- function(needle,
@ -298,7 +299,7 @@ exec_as.mo <- function(x,
initial = initial_search, initial = initial_search,
uncertainty = actual_uncertainty, uncertainty = actual_uncertainty,
input_actual = actual_input) { input_actual = actual_input) {
if (!is.null(input_actual)) { if (!is.null(input_actual)) {
input <- input_actual input <- input_actual
} else { } else {
@ -312,7 +313,7 @@ exec_as.mo <- function(x,
} }
if (length(column) == 1) { if (length(column) == 1) {
res_df <- haystack[which(eval(substitute(needle), envir = haystack, enclos = parent.frame())), , drop = FALSE] res_df <- haystack[which(eval(substitute(needle), envir = haystack, enclos = parent.frame())), , drop = FALSE]
if (NROW(res_df) > 1) { if (NROW(res_df) > 1 & uncertainty != -1) {
# sort the findings on matching score # sort the findings on matching score
res_df <- res_df[order(mo_matching_score(input, res_df[, "fullname", drop = TRUE]), decreasing = TRUE), , drop = FALSE] res_df <- res_df[order(mo_matching_score(input, res_df[, "fullname", drop = TRUE]), decreasing = TRUE), , drop = FALSE]
} }
@ -326,8 +327,8 @@ exec_as.mo <- function(x,
if (isTRUE(debug_mode)) { if (isTRUE(debug_mode)) {
cat(font_green(paste0(" **MATCH** (", NROW(res_df), " results)\n"))) cat(font_green(paste0(" **MATCH** (", NROW(res_df), " results)\n")))
} }
if (length(res) > n | uncertainty > 1) { if ((length(res) > n | uncertainty > 1) & uncertainty != -1) {
# save the other possible results as well # save the other possible results as well, but not for forced certain results (then uncertainty == -1)
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = uncertainty, format_uncertainty_as_df(uncertainty_level = uncertainty,
input = input, input = input,
@ -437,7 +438,7 @@ exec_as.mo <- function(x,
# we need special treatment for very prevalent full names, they are likely! # we need special treatment for very prevalent full names, they are likely!
# e.g. as.mo("Staphylococcus aureus") # e.g. as.mo("Staphylococcus aureus")
x <- MO_lookup[match(tolower(x), MO_lookup$fullname_lower), property, drop = TRUE] x <- MO_lookup[match(tolower(x), MO_lookup$fullname_lower), property, drop = TRUE]
} else if (all(x %in% reference_data_to_use$fullname)) { } else if (all(x %in% reference_data_to_use$fullname)) {
# we need special treatment for very prevalent full names, they are likely! # we need special treatment for very prevalent full names, they are likely!
# e.g. as.mo("Staphylococcus aureus") # e.g. as.mo("Staphylococcus aureus")
@ -702,18 +703,18 @@ exec_as.mo <- function(x,
# translate known trivial abbreviations to genus + species ---- # translate known trivial abbreviations to genus + species ----
if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA", "BORSA") if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA", "BORSA")
| x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") { | x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") {
x[i] <- lookup(fullname == "Staphylococcus aureus") x[i] <- lookup(fullname == "Staphylococcus aureus", uncertainty = -1)
next next
} }
if (toupper(x_backup_without_spp[i]) %in% c("MRSE", "MSSE") if (toupper(x_backup_without_spp[i]) %in% c("MRSE", "MSSE")
| x_backup_without_spp[i] %like_case% " (mrse|msse) ") { | x_backup_without_spp[i] %like_case% " (mrse|msse) ") {
x[i] <- lookup(fullname == "Staphylococcus epidermidis") x[i] <- lookup(fullname == "Staphylococcus epidermidis", uncertainty = -1)
next next
} }
if (toupper(x_backup_without_spp[i]) == "VRE" if (toupper(x_backup_without_spp[i]) == "VRE"
| x_backup_without_spp[i] %like_case% " vre " | x_backup_without_spp[i] %like_case% " vre "
| x_backup_without_spp[i] %like_case% "(enterococci|enterokok|enterococo)[a-z]*?$") { | x_backup_without_spp[i] %like_case% "(enterococci|enterokok|enterococo)[a-z]*?$") {
x[i] <- lookup(genus == "Enterococcus") x[i] <- lookup(genus == "Enterococcus", uncertainty = -1)
next next
} }
# support for: # support for:
@ -731,50 +732,50 @@ exec_as.mo <- function(x,
if (toupper(x_backup_without_spp[i]) %in% c("AIEC", "ATEC", "DAEC", "EAEC", "EHEC", "EIEC", "EPEC", "ETEC", "NMEC", "STEC", "UPEC") if (toupper(x_backup_without_spp[i]) %in% c("AIEC", "ATEC", "DAEC", "EAEC", "EHEC", "EIEC", "EPEC", "ETEC", "NMEC", "STEC", "UPEC")
# also support O-antigens of E. coli: O26, O103, O104, O111, O121, O145, O157 # also support O-antigens of E. coli: O26, O103, O104, O111, O121, O145, O157
| x_backup_without_spp[i] %like_case% "o?(26|103|104|111|121|145|157)") { | x_backup_without_spp[i] %like_case% "o?(26|103|104|111|121|145|157)") {
x[i] <- lookup(fullname == "Escherichia coli") x[i] <- lookup(fullname == "Escherichia coli", uncertainty = -1)
next next
} }
if (toupper(x_backup_without_spp[i]) == "MRPA" if (toupper(x_backup_without_spp[i]) == "MRPA"
| x_backup_without_spp[i] %like_case% " mrpa ") { | x_backup_without_spp[i] %like_case% " mrpa ") {
# multi resistant P. aeruginosa # multi resistant P. aeruginosa
x[i] <- lookup(fullname == "Pseudomonas aeruginosa") x[i] <- lookup(fullname == "Pseudomonas aeruginosa", uncertainty = -1)
next next
} }
if (toupper(x_backup_without_spp[i]) == "CRSM") { if (toupper(x_backup_without_spp[i]) == "CRSM") {
# co-trim resistant S. maltophilia # co-trim resistant S. maltophilia
x[i] <- lookup(fullname == "Stenotrophomonas maltophilia") x[i] <- lookup(fullname == "Stenotrophomonas maltophilia", uncertainty = -1)
next next
} }
if (toupper(x_backup_without_spp[i]) %in% c("PISP", "PRSP", "VISP", "VRSP") if (toupper(x_backup_without_spp[i]) %in% c("PISP", "PRSP", "VISP", "VRSP")
| x_backup_without_spp[i] %like_case% " (pisp|prsp|visp|vrsp) ") { | x_backup_without_spp[i] %like_case% " (pisp|prsp|visp|vrsp) ") {
# peni I, peni R, vanco I, vanco R: S. pneumoniae # peni I, peni R, vanco I, vanco R: S. pneumoniae
x[i] <- lookup(fullname == "Streptococcus pneumoniae") x[i] <- lookup(fullname == "Streptococcus pneumoniae", uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "^g[abcdfghk]s$") { if (x_backup_without_spp[i] %like_case% "^g[abcdfghk]s$") {
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB) # Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
x[i] <- lookup(mo == toupper(gsub("g([abcdfghk])s", x[i] <- lookup(mo == toupper(gsub("g([abcdfghk])s",
"B_STRPT_GRP\\1", "B_STRPT_GRP\\1",
x_backup_without_spp[i]))) x_backup_without_spp[i])), uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "(streptococ|streptokok).* [abcdfghk]$") { if (x_backup_without_spp[i] %like_case% "(streptococ|streptokok).* [abcdfghk]$") {
# Streptococci in different languages, like "estreptococos grupo B" # Streptococci in different languages, like "estreptococos grupo B"
x[i] <- lookup(mo == toupper(gsub(".*(streptococ|streptokok|estreptococ).* ([abcdfghk])$", x[i] <- lookup(mo == toupper(gsub(".*(streptococ|streptokok|estreptococ).* ([abcdfghk])$",
"B_STRPT_GRP\\2", "B_STRPT_GRP\\2",
x_backup_without_spp[i]))) x_backup_without_spp[i])), uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "group [abcdfghk] (streptococ|streptokok|estreptococ)") { if (x_backup_without_spp[i] %like_case% "group [abcdfghk] (streptococ|streptokok|estreptococ)") {
# Streptococci in different languages, like "Group A Streptococci" # Streptococci in different languages, like "Group A Streptococci"
x[i] <- lookup(mo == toupper(gsub(".*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*", x[i] <- lookup(mo == toupper(gsub(".*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*",
"B_STRPT_GRP\\1", "B_STRPT_GRP\\1",
x_backup_without_spp[i]))) x_backup_without_spp[i])), uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "haemoly.*strept") { if (x_backup_without_spp[i] %like_case% "haemoly.*strept") {
# Haemolytic streptococci in different languages # Haemolytic streptococci in different languages
x[i] <- lookup(mo == "B_STRPT_HAEM") x[i] <- lookup(mo == "B_STRPT_HAEM", uncertainty = -1)
next next
} }
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ---- # CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ----
@ -782,14 +783,14 @@ exec_as.mo <- function(x,
| x_trimmed[i] %like_case% "[ck]oagulas[ea] negatie?[vf]" | x_trimmed[i] %like_case% "[ck]oagulas[ea] negatie?[vf]"
| x_backup_without_spp[i] %like_case% "[ck]o?ns[^a-z]?$") { | x_backup_without_spp[i] %like_case% "[ck]o?ns[^a-z]?$") {
# coerce S. coagulase negative # coerce S. coagulase negative
x[i] <- lookup(mo == "B_STPHY_CONS") x[i] <- lookup(mo == "B_STPHY_CONS", uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "[ck]oagulas[ea] positie?[vf]" if (x_backup_without_spp[i] %like_case% "[ck]oagulas[ea] positie?[vf]"
| x_trimmed[i] %like_case% "[ck]oagulas[ea] positie?[vf]" | x_trimmed[i] %like_case% "[ck]oagulas[ea] positie?[vf]"
| x_backup_without_spp[i] %like_case% "[ck]o?ps[^a-z]?$") { | x_backup_without_spp[i] %like_case% "[ck]o?ps[^a-z]?$") {
# coerce S. coagulase positive # coerce S. coagulase positive
x[i] <- lookup(mo == "B_STPHY_COPS") x[i] <- lookup(mo == "B_STPHY_COPS", uncertainty = -1)
next next
} }
# streptococcal groups: milleri and viridans # streptococcal groups: milleri and viridans
@ -797,50 +798,50 @@ exec_as.mo <- function(x,
| x_backup_without_spp[i] %like_case% "strepto.* mil+er+i" | x_backup_without_spp[i] %like_case% "strepto.* mil+er+i"
| x_backup_without_spp[i] %like_case% "mgs[^a-z]?$") { | x_backup_without_spp[i] %like_case% "mgs[^a-z]?$") {
# Milleri Group Streptococcus (MGS) # Milleri Group Streptococcus (MGS)
x[i] <- lookup(mo == "B_STRPT_MILL") x[i] <- lookup(mo == "B_STRPT_MILL", uncertainty = -1)
next next
} }
if (x_trimmed[i] %like_case% "strepto.* viridans" if (x_trimmed[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% "strepto.* viridans" | x_backup_without_spp[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% "vgs[^a-z]?$") { | x_backup_without_spp[i] %like_case% "vgs[^a-z]?$") {
# Viridans Group Streptococcus (VGS) # Viridans Group Streptococcus (VGS)
x[i] <- lookup(mo == "B_STRPT_VIRI") x[i] <- lookup(mo == "B_STRPT_VIRI", uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "gram[ -]?neg.*" if (x_backup_without_spp[i] %like_case% "gram[ -]?neg.*"
| x_backup_without_spp[i] %like_case% "negatie?[vf]" | x_backup_without_spp[i] %like_case% "negatie?[vf]"
| x_trimmed[i] %like_case% "gram[ -]?neg.*") { | x_trimmed[i] %like_case% "gram[ -]?neg.*") {
# coerce Gram negatives # coerce Gram negatives
x[i] <- lookup(mo == "B_GRAMN") x[i] <- lookup(mo == "B_GRAMN", uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "gram[ -]?pos.*" if (x_backup_without_spp[i] %like_case% "gram[ -]?pos.*"
| x_backup_without_spp[i] %like_case% "positie?[vf]" | x_backup_without_spp[i] %like_case% "positie?[vf]"
| x_trimmed[i] %like_case% "gram[ -]?pos.*") { | x_trimmed[i] %like_case% "gram[ -]?pos.*") {
# coerce Gram positives # coerce Gram positives
x[i] <- lookup(mo == "B_GRAMP") x[i] <- lookup(mo == "B_GRAMP", uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "mycoba[ck]teri.[nm]?$") { if (x_backup_without_spp[i] %like_case% "mycoba[ck]teri.[nm]?$") {
# coerce mycobacteria in multiple languages # coerce mycobacteria in multiple languages
x[i] <- lookup(genus == "Mycobacterium") x[i] <- lookup(genus == "Mycobacterium", uncertainty = -1)
next next
} }
if (x_backup_without_spp[i] %like_case% "salmonella [a-z]+ ?.*") { if (x_backup_without_spp[i] %like_case% "salmonella [a-z]+ ?.*") {
if (x_backup_without_spp[i] %like_case% "salmonella group") { if (x_backup_without_spp[i] %like_case% "salmonella group") {
# Salmonella Group A to Z, just return S. species for now # Salmonella Group A to Z, just return S. species for now
x[i] <- lookup(genus == "Salmonella") x[i] <- lookup(genus == "Salmonella", uncertainty = -1)
next next
} else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup[i], ignore.case = FALSE) & } else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup[i], ignore.case = FALSE) &
!x_backup[i] %like% "t[iy](ph|f)[iy]") { !x_backup[i] %like% "t[iy](ph|f)[iy]") {
# Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica # Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica
# except for S. typhi, S. paratyphi, S. typhimurium # except for S. typhi, S. paratyphi, S. typhimurium
x[i] <- lookup(fullname == "Salmonella enterica") x[i] <- lookup(fullname == "Salmonella enterica", uncertainty = -1)
uncertainties <- rbind(uncertainties, uncertainties <- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = 1, format_uncertainty_as_df(uncertainty_level = 1,
input = x_backup[i], input = x_backup[i],
result_mo = lookup(fullname == "Salmonella enterica", "mo"))) result_mo = lookup(fullname == "Salmonella enterica", "mo", uncertainty = -1)))
next next
} }
} }
@ -848,17 +849,17 @@ exec_as.mo <- function(x,
# trivial names known to the field: # trivial names known to the field:
if ("meningococcus" %like_case% x_trimmed[i]) { if ("meningococcus" %like_case% x_trimmed[i]) {
# coerce Neisseria meningitidis # coerce Neisseria meningitidis
x[i] <- lookup(fullname == "Neisseria meningitidis") x[i] <- lookup(fullname == "Neisseria meningitidis", uncertainty = -1)
next next
} }
if ("gonococcus" %like_case% x_trimmed[i]) { if ("gonococcus" %like_case% x_trimmed[i]) {
# coerce Neisseria gonorrhoeae # coerce Neisseria gonorrhoeae
x[i] <- lookup(fullname == "Neisseria gonorrhoeae") x[i] <- lookup(fullname == "Neisseria gonorrhoeae", uncertainty = -1)
next next
} }
if ("pneumococcus" %like_case% x_trimmed[i]) { if ("pneumococcus" %like_case% x_trimmed[i]) {
# coerce Streptococcus penumoniae # coerce Streptococcus penumoniae
x[i] <- lookup(fullname == "Streptococcus pneumoniae") x[i] <- lookup(fullname == "Streptococcus pneumoniae", uncertainty = -1)
next next
} }
# } # }
@ -1246,13 +1247,11 @@ exec_as.mo <- function(x,
} }
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
found <- lookup(mo == found)
# uncertainty level 2 only if searched part contains a space (otherwise it will be found with lvl 3) # uncertainty level 2 only if searched part contains a space (otherwise it will be found with lvl 3)
if (x_strip_collapsed %like_case% " ") { if (x_strip_collapsed %like_case% " ") {
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, attr(found, which = "uncertainties", exact = TRUE))
input = a.x_backup, found <- lookup(mo == found)
result_mo = found_result))
return(found) return(found)
} }
} }
@ -1283,11 +1282,9 @@ exec_as.mo <- function(x,
} }
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, attr(found, which = "uncertainties", exact = TRUE))
input = a.x_backup, found <- lookup(mo == found)
result_mo = found_result))
return(found) return(found)
} }
} }
@ -1311,11 +1308,9 @@ exec_as.mo <- function(x,
} }
if (!empty_result(found)) { if (!empty_result(found)) {
found_result <- found found_result <- found
found <- lookup(mo == found)
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, attr(found, which = "uncertainties", exact = TRUE))
input = a.x_backup, found <- lookup(mo == found)
result_mo = found_result))
return(found) return(found)
} }
} }
@ -1332,9 +1327,8 @@ exec_as.mo <- function(x,
if (!is.na(found) & nchar(g.x_backup_without_spp) >= 6) { if (!is.na(found) & nchar(g.x_backup_without_spp) >= 6) {
found_result <- lookup(mo == found) found_result <- lookup(mo == found)
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level, attr(found, which = "uncertainties", exact = TRUE))
input = a.x_backup, found <- lookup(mo == found)
result_mo = found_result))
return(found) return(found)
} }
} }
@ -1388,7 +1382,7 @@ exec_as.mo <- function(x,
# no results found: make them UNKNOWN ---- # no results found: make them UNKNOWN ----
x[i] <- lookup(mo == "UNKNOWN") x[i] <- lookup(mo == "UNKNOWN", uncertainty = -1)
if (initial_search == TRUE) { if (initial_search == TRUE) {
failures <- c(failures, x_backup[i]) failures <- c(failures, x_backup[i])
} }
@ -1478,33 +1472,33 @@ exec_as.mo <- function(x,
immediate. = TRUE) immediate. = TRUE)
} }
x[x %in% CoNS] <- lookup(mo == "B_STPHY_CONS") x[x %in% CoNS] <- lookup(mo == "B_STPHY_CONS", uncertainty = -1)
x[x %in% CoPS] <- lookup(mo == "B_STPHY_COPS") x[x %in% CoPS] <- lookup(mo == "B_STPHY_COPS", uncertainty = -1)
if (Becker == "all") { if (Becker == "all") {
x[x %in% lookup(fullname %like_case% "^Staphylococcus aureus", n = Inf)] <- lookup(mo == "B_STPHY_COPS") x[x %in% lookup(fullname %like_case% "^Staphylococcus aureus", n = Inf)] <- lookup(mo == "B_STPHY_COPS", uncertainty = -1)
} }
} }
# Lancefield ---- # Lancefield ----
if (Lancefield == TRUE | Lancefield == "all") { if (Lancefield == TRUE | Lancefield == "all") {
# group A - S. pyogenes # group A - S. pyogenes
x[x %in% lookup(genus == "Streptococcus" & species == "pyogenes", n = Inf)] <- lookup(fullname == "Streptococcus group A") x[x %in% lookup(genus == "Streptococcus" & species == "pyogenes", n = Inf)] <- lookup(fullname == "Streptococcus group A", uncertainty = -1)
# group B - S. agalactiae # group B - S. agalactiae
x[x %in% lookup(genus == "Streptococcus" & species == "agalactiae", n = Inf)] <- lookup(fullname == "Streptococcus group B") x[x %in% lookup(genus == "Streptococcus" & species == "agalactiae", n = Inf)] <- lookup(fullname == "Streptococcus group B", uncertainty = -1)
# group C # group C
x[x %in% lookup(genus == "Streptococcus" & x[x %in% lookup(genus == "Streptococcus" &
species %in% c("equisimilis", "equi", "zooepidemicus", "dysgalactiae"), species %in% c("equisimilis", "equi", "zooepidemicus", "dysgalactiae"),
n = Inf)] <- lookup(fullname == "Streptococcus group C") n = Inf)] <- lookup(fullname == "Streptococcus group C", uncertainty = -1)
if (Lancefield == "all") { if (Lancefield == "all") {
# all Enterococci # all Enterococci
x[x %in% lookup(genus == "Enterococcus", n = Inf)] <- lookup(fullname == "Streptococcus group D") x[x %in% lookup(genus == "Enterococcus", n = Inf)] <- lookup(fullname == "Streptococcus group D", uncertainty = -1)
} }
# group F - S. anginosus # group F - S. anginosus
x[x %in% lookup(genus == "Streptococcus" & species == "anginosus", n = Inf)] <- lookup(fullname == "Streptococcus group F") x[x %in% lookup(genus == "Streptococcus" & species == "anginosus", n = Inf)] <- lookup(fullname == "Streptococcus group F", uncertainty = -1)
# group H - S. sanguinis # group H - S. sanguinis
x[x %in% lookup(genus == "Streptococcus" & species == "sanguinis", n = Inf)] <- lookup(fullname == "Streptococcus group H") x[x %in% lookup(genus == "Streptococcus" & species == "sanguinis", n = Inf)] <- lookup(fullname == "Streptococcus group H", uncertainty = -1)
# group K - S. salivarius # group K - S. salivarius
x[x %in% lookup(genus == "Streptococcus" & species == "salivarius", n = Inf)] <- lookup(fullname == "Streptococcus group K") x[x %in% lookup(genus == "Streptococcus" & species == "salivarius", n = Inf)] <- lookup(fullname == "Streptococcus group K", uncertainty = -1)
} }
# Wrap up ---------------------------------------------------------------- # Wrap up ----------------------------------------------------------------
@ -1533,10 +1527,20 @@ exec_as.mo <- function(x,
print(mo_renamed()) print(mo_renamed())
} }
if (NROW(uncertainties) > 0 & initial_search == FALSE) { if (initial_search == FALSE) {
# we got here from uncertain_fn().
if (NROW(uncertainties) == 0) {
# the stripped/transformed version of x_backup is apparently a full hit, like with: as.mo("Escherichia (hello there) coli")
uncertainties <- rbind(uncertainties,
format_uncertainty_as_df(uncertainty_level = actual_uncertainty,
input = actual_input,
result_mo = x,
candidates = ""))
}
# this will save the uncertain items as attribute, so they can be bound to `uncertainties` in the uncertain_fn() function # this will save the uncertain items as attribute, so they can be bound to `uncertainties` in the uncertain_fn() function
x <- structure(x, uncertainties = uncertainties) x <- structure(x, uncertainties = uncertainties)
} }
if (old_mo_warning == TRUE & property != "mo") { if (old_mo_warning == TRUE & property != "mo") {
warning("The input contained old microorganism IDs from previous versions of this package.\nPlease use `as.mo()` on these old IDs to transform them to the new format.\nSUPPORT FOR THIS WILL BE DROPPED IN A FUTURE VERSION.", call. = FALSE) warning("The input contained old microorganism IDs from previous versions of this package.\nPlease use `as.mo()` on these old IDs to transform them to the new format.\nSUPPORT FOR THIS WILL BE DROPPED IN A FUTURE VERSION.", call. = FALSE)
@ -1748,7 +1752,8 @@ print.mo_uncertainties <- function(x, ...) {
if (NROW(x) == 0) { if (NROW(x) == 0) {
return(NULL) return(NULL)
} }
cat(font_blue("Scores are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name.\n")) cat(font_blue(strwrap(c("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 likelihood of the match - the more transformations are needed for coercion, the more unlikely the result.")), collapse = "\n"))
cat("\n")
msg <- "" msg <- ""
for (i in seq_len(nrow(x))) { for (i in seq_len(nrow(x))) {
@ -1763,17 +1768,25 @@ print.mo_uncertainties <- function(x, ...) {
candidates <- paste(candidates, collapse = ", ") candidates <- paste(candidates, collapse = ", ")
# align with input after arrow # align with input after arrow
candidates <- paste0("\n", strrep(" ", nchar(x[i, ]$input) + 6), candidates <- paste0("\n", strrep(" ", nchar(x[i, ]$input) + 6),
"Other", ifelse(n_candidates == 25, " (max 25)", ""), ": ", candidates) "Less likely", ifelse(n_candidates == 25, " (max 25)", ""), ": ", candidates)
} else { } else {
candidates <- "" candidates <- ""
} }
if (x[i, ]$uncertainty == 1) {
uncertainty_interpretation <- font_green("* VERY LIKELY *")
} else if (x[i, ]$uncertainty == 1) {
uncertainty_interpretation <- font_orange("* LIKELY *")
} else {
uncertainty_interpretation <- font_red("* UNLIKELY *")
}
msg <- paste(msg, msg <- paste(msg,
paste0('"', x[i, ]$input, '" -> ', paste0('"', x[i, ]$input, '" -> ',
paste0(font_bold(font_italic(x[i, ]$fullname)), paste0(font_bold(font_italic(x[i, ]$fullname)),
ifelse(!is.na(x[i, ]$renamed_to), paste(", renamed to", font_italic(x[i, ]$renamed_to)), ""), ifelse(!is.na(x[i, ]$renamed_to), paste(", renamed to", font_italic(x[i, ]$renamed_to)), ""),
" (", x[i, ]$mo, " (", x[i, ]$mo,
", score: ", trimws(percentage(mo_matching_score(x[i, ]$input, x[i, ]$fullname) * (1 / x[i, ]$uncertainty), digits = 1)), ", score: ", trimws(percentage(mo_matching_score(x[i, ]$input, x[i, ]$fullname) * (1 / x[i, ]$uncertainty), digits = 1)),
")"), ") "),
uncertainty_interpretation,
candidates), candidates),
sep = "\n") sep = "\n")
} }
@ -1877,7 +1890,7 @@ mo_matching_score <- function(input, fullname) {
dist <- (nchar(fullname) - 0.5 * levenshtein) / nchar(fullname) dist <- (nchar(fullname) - 0.5 * levenshtein) / nchar(fullname)
index_in_MO_lookup <- tryCatch((nrow(MO_lookup) - match(fullname, MO_lookup$fullname)) / nrow(MO_lookup), index_in_MO_lookup <- tryCatch((nrow(MO_lookup) - match(fullname, MO_lookup$fullname)) / nrow(MO_lookup),
error = function(e) rep(1, length(fullname))) error = function(e) rep(1, length(fullname)))
dist * index_in_MO_lookup (0.25 * dist) + (0.75 * index_in_MO_lookup)
} }
trimws2 <- function(x) { trimws2 <- function(x) {

View File

@ -30,7 +30,7 @@
#' Please suggest your own translations [by creating a new issue on our repository](https://github.com/msberends/AMR/issues/new?title=Translations). #' Please suggest your own translations [by creating a new issue on our repository](https://github.com/msberends/AMR/issues/new?title=Translations).
#' #'
#' ## Changing the default language #' ## Changing the default language
#' The system language will be used at default (as returned by [Sys.getenv("LANG")] or, if `LANG` is not set, [Sys.getlocale()]), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order: #' The system language will be used at default (as returned by `Sys.getenv("LANG")` or, if `LANG` is not set, [Sys.getlocale()]), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order:
#' #'
#' 1. Setting the R option `AMR_locale`, e.g. by running `options(AMR_locale = "de")` #' 1. Setting the R option `AMR_locale`, e.g. by running `options(AMR_locale = "de")`
#' 2. Setting the system variable `LANGUAGE` or `LANG`, e.g. by adding `LANGUAGE="de_DE.utf8"` to your `.Renviron` file in your home directory #' 2. Setting the system variable `LANGUAGE` or `LANG`, e.g. by adding `LANGUAGE="de_DE.utf8"` to your `.Renviron` file in your home directory

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>
@ -236,9 +236,9 @@
<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-1309019" class="section level1"> <div id="amr-1309020" class="section level1">
<h1 class="page-header" data-toc-text="1.3.0.9019"> <h1 class="page-header" data-toc-text="1.3.0.9020">
<a href="#amr-1309019" class="anchor"></a>AMR 1.3.0.9019<small> Unreleased </small> <a href="#amr-1309020" class="anchor"></a>AMR 1.3.0.9020<small> Unreleased </small>
</h1> </h1>
<div id="last-updated-14-september-2020" class="section level2"> <div id="last-updated-14-september-2020" class="section level2">
<h2 class="hasAnchor"> <h2 class="hasAnchor">

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-14T11:57Z last_built: 2020-09-14T17:41Z
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

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

View File

@ -50,7 +50,7 @@
<meta property="og:title" content="Translate strings from AMR package — translate" /> <meta property="og:title" content="Translate strings from AMR package — translate" />
<meta property="og:description" content="For language-dependent output of AMR functions, like mo_name(), mo_gramstain(), mo_type() and ab_name()." /> <meta property="og:description" content="For language-dependent output of AMR functions, like mo_name(), mo_gramstain(), mo_type() and ab_name()." />
<meta property="og:image" content="https://msberends.github.io/AMR/logo.svg" /> <meta property="og:image" content="https://msberends.github.io/AMR/logo.png" />
@ -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.9018</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>
@ -252,7 +252,7 @@
<p>Please suggest your own translations <a href='https://github.com/msberends/AMR/issues/new?title=Translations'>by creating a new issue on our repository</a>.</p><h3>Changing the default language</h3> <p>Please suggest your own translations <a href='https://github.com/msberends/AMR/issues/new?title=Translations'>by creating a new issue on our repository</a>.</p><h3>Changing the default language</h3>
<p>The system language will be used at default (as returned by Sys.getenv("LANG") or, if <code>LANG</code> is not set, <code><a href='https://rdrr.io/r/base/locales.html'>Sys.getlocale()</a></code>), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order:</p><ol> <p>The system language will be used at default (as returned by <code><a href='https://rdrr.io/r/base/Sys.getenv.html'>Sys.getenv("LANG")</a></code> or, if <code>LANG</code> is not set, <code><a href='https://rdrr.io/r/base/locales.html'>Sys.getlocale()</a></code>), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order:</p><ol>
<li><p>Setting the R option <code>AMR_locale</code>, e.g. by running <code><a href='https://rdrr.io/r/base/options.html'>options(AMR_locale = "de")</a></code></p></li> <li><p>Setting the R option <code>AMR_locale</code>, e.g. by running <code><a href='https://rdrr.io/r/base/options.html'>options(AMR_locale = "de")</a></code></p></li>
<li><p>Setting the system variable <code>LANGUAGE</code> or <code>LANG</code>, e.g. by adding <code>LANGUAGE="de_DE.utf8"</code> to your <code>.Renviron</code> file in your home directory</p></li> <li><p>Setting the system variable <code>LANGUAGE</code> or <code>LANG</code>, e.g. by adding <code>LANGUAGE="de_DE.utf8"</code> to your <code>.Renviron</code> file in your home directory</p></li>
</ol> </ol>

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.9019</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.3.0.9020</span>
</span> </span>
</div> </div>

View File

@ -18,7 +18,7 @@ Currently supported languages are: Dutch, English, French, German, Italian, Port
Please suggest your own translations \href{https://github.com/msberends/AMR/issues/new?title=Translations}{by creating a new issue on our repository}. Please suggest your own translations \href{https://github.com/msberends/AMR/issues/new?title=Translations}{by creating a new issue on our repository}.
\subsection{Changing the default language}{ \subsection{Changing the default language}{
The system language will be used at default (as returned by \link{Sys.getenv("LANG")} or, if \code{LANG} is not set, \code{\link[=Sys.getlocale]{Sys.getlocale()}}), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order: The system language will be used at default (as returned by \code{Sys.getenv("LANG")} or, if \code{LANG} is not set, \code{\link[=Sys.getlocale]{Sys.getlocale()}}), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order:
\enumerate{ \enumerate{
\item Setting the R option \code{AMR_locale}, e.g. by running \code{options(AMR_locale = "de")} \item Setting the R option \code{AMR_locale}, e.g. by running \code{options(AMR_locale = "de")}
\item Setting the system variable \code{LANGUAGE} or \code{LANG}, e.g. by adding \code{LANGUAGE="de_DE.utf8"} to your \code{.Renviron} file in your home directory \item Setting the system variable \code{LANGUAGE} or \code{LANG}, e.g. by adding \code{LANGUAGE="de_DE.utf8"} to your \code{.Renviron} file in your home directory

View File

@ -205,8 +205,8 @@ test_that("as.mo works", {
expect_equal(suppressWarnings(as.character(as.mo("staaur extratest", allow_uncertain = FALSE))), "UNKNOWN") expect_equal(suppressWarnings(as.character(as.mo("staaur extratest", allow_uncertain = FALSE))), "UNKNOWN")
expect_message(as.mo("e coli extra_text", allow_uncertain = TRUE)) expect_message(as.mo("e coli extra_text", allow_uncertain = TRUE))
expect_equal(suppressMessages(as.character(as.mo("unexisting aureus", allow_uncertain = 3))), "B_STPHY_AURS") expect_equal(suppressMessages(as.character(as.mo("unexisting aureus", allow_uncertain = 3))), "B_STPHY_AURS")
expect_equal(suppressMessages(as.character(as.mo("unexisting staphy", allow_uncertain = 3))), "B_STPHY") expect_equal(suppressMessages(as.character(as.mo("unexisting staphy", allow_uncertain = 3))), "B_STPHY_COPS")
expect_equal(suppressMessages(as.character(as.mo("Staphylococcus aureus unexisting", allow_uncertain = 3))), "B_STPHY_AURS") expect_equal(suppressMessages(as.character(as.mo("Staphylococcus aureus unexisting", allow_uncertain = 3))), "B_STPHY_AURS_ANRB")
# predefined reference_df # predefined reference_df
expect_equal(as.character(as.mo("TestingOwnID", expect_equal(as.character(as.mo("TestingOwnID",
@ -228,15 +228,15 @@ test_that("as.mo works", {
c("B_PROTS_MRBL", "B_BCLLS_CERS", "B_ESCHR_COLI")) c("B_PROTS_MRBL", "B_BCLLS_CERS", "B_ESCHR_COLI"))
# hard to find # hard to find
expect_equal(as.character(suppressWarnings(as.mo( expect_equal(as.character(suppressMessages(as.mo(
c("Microbacterium paraoxidans", c("Microbacterium paraoxidans",
"Streptococcus suis (bovis gr)", "Streptococcus suis (bovis gr)",
"Raoultella (here some text) terrigena")))), "Raoultella (here some text) terrigena")))),
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_RLTLL_TRRG")) c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_RLTLL_TRRG"))
expect_output(print(mo_uncertainties())) expect_output(print(mo_uncertainties()))
# Salmonella (City) are all actually Salmonella enterica spp (City) # Salmonella (City) are all actually Salmonella enterica spp (City)
expect_equal(suppressWarnings(mo_name(c("Salmonella Goettingen", "Salmonella Typhimurium", "Salmonella Group A"))), expect_equal(suppressMessages(mo_name(c("Salmonella Goettingen", "Salmonella Typhimurium", "Salmonella Group A"))),
c("Salmonella enterica", "Salmonella enterica", "Salmonella")) c("Salmonella enterica", "Salmonella enterica", "Salmonella"))
# no virusses # no virusses