P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-10-31 10:48:15 +01:00
Code Releases Activity

(v0.7.1.9058) as.mo() improvement

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-08-20 11:40:54 +02:00
parent 04d49a62af
commit 7c069145ac
12 changed files with 126 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 0.7.1.9057 Version: 0.7.1.9058
Date: 2019-08-15 Date: 2019-08-20
Title: Antimicrobial Resistance Analysis Title: Antimicrobial Resistance Analysis
Authors@R: c( Authors@R: c(
person(role = c("aut", "cre"), person(role = c("aut", "cre"),

1
NAMESPACE
View File

@@ -233,6 +233,7 @@ importFrom(crayon,bold)
importFrom(crayon,green) importFrom(crayon,green)
importFrom(crayon,italic) importFrom(crayon,italic)
importFrom(crayon,magenta) importFrom(crayon,magenta)
importFrom(crayon,make_style)
importFrom(crayon,red) importFrom(crayon,red)
importFrom(crayon,silver) importFrom(crayon,silver)
importFrom(crayon,strip_style) importFrom(crayon,strip_style)

2
NEWS.md
View File

@@ -1,4 +1,4 @@
# AMR 0.7.1.9057 # AMR 0.7.1.9058
### Breaking ### Breaking
* Function `freq()` has moved to a new package, [`clean`](https://github.com/msberends/clean) ([CRAN link](https://cran.r-project.org/package=clean)). Creating frequency tables is actually not the scope of this package (never was) and this function has matured a lot over the last two years. Therefore, a new package was created for data cleaning and checking and it perfectly fits the `freq()` function. The [`clean`](https://github.com/msberends/clean) package is available on CRAN and will be installed automatically when updating the `AMR` package, that now imports it. In a later stage, the `skewness()` and `kurtosis()` functions will be moved to the `clean` package too. * Function `freq()` has moved to a new package, [`clean`](https://github.com/msberends/clean) ([CRAN link](https://cran.r-project.org/package=clean)). Creating frequency tables is actually not the scope of this package (never was) and this function has matured a lot over the last two years. Therefore, a new package was created for data cleaning and checking and it perfectly fits the `freq()` function. The [`clean`](https://github.com/msberends/clean) package is available on CRAN and will be installed automatically when updating the `AMR` package, that now imports it. In a later stage, the `skewness()` and `kurtosis()` functions will be moved to the `clean` package too.

25
R/eucast_rules.R
View File

@@ -119,7 +119,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
#' @rdname eucast_rules #' @rdname eucast_rules
#' @export #' @export
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n #' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style white red #' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style white red make_style
#' @importFrom utils menu #' @importFrom utils menu
#' @return The input of \code{x}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with all original and new values of the affected bug-drug combinations. #' @return The input of \code{x}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with all original and new values of the affected bug-drug combinations.
#' @source #' @source
@@ -197,7 +197,8 @@ eucast_rules <- function(x,
q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt) q_continue <- menu(choices = c("OK", "Cancel"), graphics = TRUE, title = txt)
} }
if (q_continue %in% c(FALSE, 2)) { if (q_continue %in% c(FALSE, 2)) {
return(invisible()) message("Cancelled, returning original data")
return(x)
} }
} }
@@ -228,6 +229,8 @@ eucast_rules <- function(x,
trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark)) trimws(format(x, big.mark = big.mark, decimal.mark = decimal.mark))
} }
grey <- make_style("grey")
warned <- FALSE warned <- FALSE
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") } txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") }
@@ -235,21 +238,21 @@ eucast_rules <- function(x,
txt_ok <- function(no_added, no_changed) { txt_ok <- function(no_added, no_changed) {
if (warned == FALSE) { if (warned == FALSE) {
if (no_added + no_changed == 0) { if (no_added + no_changed == 0) {
cat(green(" (no changes)\n")) cat(pillar::style_subtle(" (no changes)\n"))
} else { } else {
# opening # opening
cat(blue(" (")) cat(grey(" ("))
# additions # additions
if (no_added > 0) { if (no_added > 0) {
if (no_added == 1) { if (no_added == 1) {
cat(blue("1 value added")) cat(green("1 value added"))
} else { } else {
cat(blue(formatnr(no_added), "values added")) cat(green(formatnr(no_added), "values added"))
} }
} }
# separator # separator
if (no_added > 0 & no_changed > 0) { if (no_added > 0 & no_changed > 0) {
cat(blue(", ")) cat(grey(", "))
} }
# changes # changes
if (no_changed > 0) { if (no_changed > 0) {
@@ -260,7 +263,7 @@ eucast_rules <- function(x,
} }
} }
# closing # closing
cat(blue(")\n")) cat(grey(")\n"))
} }
warned <<- FALSE warned <<- FALSE
} }
@@ -770,7 +773,7 @@ eucast_rules <- function(x,
verbose_info <- verbose_info %>% verbose_info <- verbose_info %>%
arrange(row, rule_group, rule_name, col) arrange(row, rule_group, rule_name, col)
cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n")) cat(paste0("\n", grey(strrep("-", options()$width - 1)), "\n"))
cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'), cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'),
formatnr(n_distinct(verbose_info$row)), formatnr(n_distinct(verbose_info$row)),
'out of', formatnr(nrow(x_original)), 'out of', formatnr(nrow(x_original)),
@@ -783,7 +786,7 @@ eucast_rules <- function(x,
if (n_added == 0) { if (n_added == 0) {
colour <- cat # is function colour <- cat # is function
} else { } else {
colour <- blue # is function colour <- green # is function
} }
cat(colour(paste0("=> ", wouldve, "added ", cat(colour(paste0("=> ", wouldve, "added ",
bold(formatnr(verbose_info %>% bold(formatnr(verbose_info %>%
@@ -828,7 +831,7 @@ eucast_rules <- function(x,
cat() cat()
cat("\n") cat("\n")
} }
cat(paste0(silver(strrep("-", options()$width - 1)), "\n")) cat(paste0(grey(strrep("-", options()$width - 1)), "\n"))
if (verbose == FALSE & nrow(verbose_info) > 0) { if (verbose == FALSE & nrow(verbose_info) > 0) {
cat(paste("\nUse", bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n")) cat(paste("\nUse", bold("eucast_rules(..., verbose = TRUE)"), "(on your original data) to get a data.frame with all specified edits instead.\n\n"))

172
R/mo.R
View File

@@ -314,6 +314,7 @@ exec_as.mo <- function(x,
options(mo_uncertainties = NULL) options(mo_uncertainties = NULL)
options(mo_renamed = NULL) options(mo_renamed = NULL)
} }
options(mo_renamed_last_run = NULL)
if (NCOL(x) == 2) { if (NCOL(x) == 2) {
# support tidyverse selection like: df %>% select(colA, colB) # support tidyverse selection like: df %>% select(colA, colB)
@@ -336,9 +337,12 @@ exec_as.mo <- function(x,
} }
notes <- character(0) notes <- character(0)
uncertainties <- data.frame(input = character(0), uncertainties <- data.frame(uncertainty = integer(0),
input = character(0),
fullname = character(0), fullname = character(0),
mo = character(0)) renamed_to = character(0),
mo = character(0),
stringsAsFactors = FALSE)
failures <- character(0) failures <- character(0)
uncertainty_level <- translate_allow_uncertain(allow_uncertain) uncertainty_level <- translate_allow_uncertain(allow_uncertain)
@@ -488,11 +492,13 @@ exec_as.mo <- function(x,
# replace minus by a space # replace minus by a space
x <- gsub("-+", " ", x) x <- gsub("-+", " ", x)
# replace hemolytic by haemolytic # replace hemolytic by haemolytic
x <- gsub("ha?emoly", "haemoly", x) x <- gsub("ha?emoly", "haemoly", x, ignore.case = TRUE)
# place minus back in streptococci # place minus back in streptococci
x <- gsub("(alpha|beta|gamma).?ha?emoly", "\\1-haemoly", x) x <- gsub("(alpha|beta|gamma).?ha?emoly", "\\1-haemoly", x, ignore.case = TRUE)
# remove genus as first word # remove genus as first word
x <- gsub("^Genus ", "", x) x <- gsub("^genus ", "", x, ignore.case = TRUE)
# remove 'uncertain' like texts
x <- trimws(gsub("(uncertain|susp[ie]c[a-z]+|verdacht)", "", x, ignore.case = TRUE))
# allow characters that resemble others = dyslexia_mode ---- # allow characters that resemble others = dyslexia_mode ----
if (dyslexia_mode == TRUE) { if (dyslexia_mode == TRUE) {
x <- tolower(x) x <- tolower(x)
@@ -514,10 +520,11 @@ exec_as.mo <- function(x,
x <- gsub("(.)\\1+", "\\1+", x) x <- gsub("(.)\\1+", "\\1+", x)
# allow ending in -en or -us # allow ending in -en or -us
x <- gsub("e\\+n(?![a-z[])", "(e+n|u+(c|k|q|qu|s|z|x|ks)+)", x, ignore.case = TRUE, perl = TRUE) x <- gsub("e\\+n(?![a-z[])", "(e+n|u+(c|k|q|qu|s|z|x|ks)+)", x, ignore.case = TRUE, perl = TRUE)
# if the input is longer than 10 characters, add a [.] between all characters, as some might have forgotten a character # if the input is longer than 10 characters, allow any constant between all characters, as some might have forgotten a character
# this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis". # this will allow "Pasteurella damatis" to be correctly read as "Pasteurella dagmatis".
x[nchar(x_backup_without_spp) > 10] <- gsub("([a-z])([a-z])", "\\1.*\\2", x[nchar(x_backup_without_spp) > 10], ignore.case = TRUE) constants <- paste(letters[!letters %in% c("a", "e", "i", "o", "u")], collapse = "")
x[nchar(x_backup_without_spp) > 10] <- gsub("[+]", "+.*", x[nchar(x_backup_without_spp) > 10]) #x[nchar(x_backup_without_spp) > 10] <- gsub("([a-z])([a-z])", paste0("\\1[", constants, "]?\\2"), x[nchar(x_backup_without_spp) > 10], ignore.case = TRUE)
x[nchar(x_backup_without_spp) > 10] <- gsub("[+]", paste0("+[", constants, "]?"), x[nchar(x_backup_without_spp) > 10])
} }
x <- strip_whitespace(x) x <- strip_whitespace(x)
@@ -825,10 +832,9 @@ exec_as.mo <- function(x,
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history) set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history)
} }
uncertainties <- rbind(uncertainties, uncertainties <- rbind(uncertainties,
data.frame(uncertainty = 1, data.frame(uncertainty_level = 1,
input = x_backup_without_spp[i], input = x_backup_without_spp[i],
fullname = microorganismsDT[mo == "B_SLMNL_ENT", fullname][[1]], result_mo = "B_SLMNL_ENT"))
mo = "B_SLMNL_ENT"))
} }
next next
} }
@@ -1051,6 +1057,7 @@ exec_as.mo <- function(x,
} else { } else {
x[i] <- microorganismsDT[col_id == found[1, col_id_new], ..property][[1]] x[i] <- microorganismsDT[col_id == found[1, col_id_new], ..property][[1]]
} }
options(mo_renamed_last_run = found[1, fullname])
was_renamed(name_old = found[1, fullname], was_renamed(name_old = found[1, fullname],
name_new = microorganismsDT[col_id == found[1, col_id_new], fullname], name_new = microorganismsDT[col_id == found[1, col_id_new], fullname],
ref_old = found[1, ref], ref_old = found[1, ref],
@@ -1081,7 +1088,7 @@ exec_as.mo <- function(x,
# (1) look again for old taxonomic names, now for G. species ---- # (1) look again for old taxonomic names, now for G. species ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 1] (1) look again for old taxonomic names, now for G. species\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (1) look again for old taxonomic names, now for G. species\n")
} }
if (isTRUE(debug)) { if (isTRUE(debug)) {
message("Running '", c.x_withspaces_start_end, "' and '", d.x_withspaces_start_only, "'") message("Running '", c.x_withspaces_start_end, "' and '", d.x_withspaces_start_only, "'")
@@ -1102,11 +1109,11 @@ exec_as.mo <- function(x,
ref_old = found[1, ref], ref_old = found[1, ref],
ref_new = microorganismsDT[col_id == found[1, col_id_new], ref], ref_new = microorganismsDT[col_id == found[1, col_id_new], ref],
mo = microorganismsDT[col_id == found[1, col_id_new], mo]) mo = microorganismsDT[col_id == found[1, col_id_new], mo])
options(mo_renamed_last_run = found[1, fullname])
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = found[1, fullname], result_mo = microorganismsDT[col_id == found[1, col_id_new], mo]))
mo = paste("CoL", found[1, col_id])))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(x, property), 1, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(x, property), 1, force = force_mo_history)
} }
@@ -1116,7 +1123,7 @@ exec_as.mo <- function(x,
# (2) Try with misspelled input ---- # (2) Try with misspelled input ----
# just rerun with dyslexia_mode = TRUE will used the extensive regex part above # just rerun with dyslexia_mode = TRUE will used the extensive regex part above
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 1] (2) Try with misspelled input\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (2) Try with misspelled input\n")
} }
if (isTRUE(debug)) { if (isTRUE(debug)) {
message("Running '", a.x_backup, "'") message("Running '", a.x_backup, "'")
@@ -1131,10 +1138,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 1, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 1, force = force_mo_history)
} }
@@ -1148,7 +1154,7 @@ exec_as.mo <- function(x,
# (3) look for genus only, part of name ---- # (3) look for genus only, part of name ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (3) look for genus only, part of name\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (3) look for genus only, part of name\n")
} }
if (nchar(g.x_backup_without_spp) > 4 & !b.x_trimmed %like% " ") { if (nchar(g.x_backup_without_spp) > 4 & !b.x_trimmed %like% " ") {
if (!grepl("^[A-Z][a-z]+", b.x_trimmed, ignore.case = FALSE)) { if (!grepl("^[A-Z][a-z]+", b.x_trimmed, ignore.case = FALSE)) {
@@ -1160,10 +1166,9 @@ exec_as.mo <- function(x,
if (length(found) > 0) { if (length(found) > 0) {
x[i] <- found[1L] x[i] <- found[1L]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(x, property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(x, property), 2, force = force_mo_history)
} }
@@ -1174,7 +1179,7 @@ exec_as.mo <- function(x,
# (4) strip values between brackets ---- # (4) strip values between brackets ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (4) strip values between brackets\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (4) strip values between brackets\n")
} }
a.x_backup_stripped <- gsub("( *[(].*[)] *)", " ", a.x_backup) a.x_backup_stripped <- gsub("( *[(].*[)] *)", " ", a.x_backup)
a.x_backup_stripped <- trimws(gsub(" +", " ", a.x_backup_stripped)) a.x_backup_stripped <- trimws(gsub(" +", " ", a.x_backup_stripped))
@@ -1191,10 +1196,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1203,7 +1207,7 @@ exec_as.mo <- function(x,
# (5) inverse input ---- # (5) inverse input ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (5) inverse input\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (5) inverse input\n")
} }
a.x_backup_inversed <- paste(rev(unlist(strsplit(a.x_backup, split = " "))), collapse = " ") a.x_backup_inversed <- paste(rev(unlist(strsplit(a.x_backup, split = " "))), collapse = " ")
if (isTRUE(debug)) { if (isTRUE(debug)) {
@@ -1219,10 +1223,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1231,7 +1234,7 @@ exec_as.mo <- function(x,
# (6) try to strip off half an element from end and check the remains ---- # (6) try to strip off half an element from end and check the remains ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (6) try to strip off half an element from end and check the remains\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (6) try to strip off half an element from end and check the remains\n")
} }
x_strip <- a.x_backup %>% strsplit(" ") %>% unlist() x_strip <- a.x_backup %>% strsplit(" ") %>% unlist()
if (length(x_strip) > 1) { if (length(x_strip) > 1) {
@@ -1254,10 +1257,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1268,7 +1270,7 @@ exec_as.mo <- function(x,
} }
# (7) try to strip off one element from end and check the remains ---- # (7) try to strip off one element from end and check the remains ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (7) try to strip off one element from end and check the remains\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (7) try to strip off one element from end and check the remains\n")
} }
if (length(x_strip) > 1) { if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) { for (i in 1:(length(x_strip) - 1)) {
@@ -1287,10 +1289,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1301,17 +1302,16 @@ exec_as.mo <- function(x,
} }
# (8) check for unknown yeasts/fungi ---- # (8) check for unknown yeasts/fungi ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (8) check for unknown yeasts/fungi\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (8) check for unknown yeasts/fungi\n")
} }
if (b.x_trimmed %like% "yeast") { if (b.x_trimmed %like% "yeast") {
found <- "F_YEAST" found <- "F_YEAST"
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1322,10 +1322,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1333,7 +1332,7 @@ exec_as.mo <- function(x,
} }
# (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome) ---- # (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome) ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 2] (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome)\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (9) try to strip off one element from start and check the remains (only allow >= 2-part name outcome)\n")
} }
x_strip <- a.x_backup %>% strsplit(" ") %>% unlist() x_strip <- a.x_backup %>% strsplit(" ") %>% unlist()
if (length(x_strip) > 1 & nchar(g.x_backup_without_spp) >= 6) { if (length(x_strip) > 1 & nchar(g.x_backup_without_spp) >= 6) {
@@ -1354,10 +1353,9 @@ exec_as.mo <- function(x,
# 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% " ") { if (x_strip_collapsed %like% " ") {
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1374,7 +1372,7 @@ exec_as.mo <- function(x,
# (10) try to strip off one element from start and check the remains (any text size) ---- # (10) try to strip off one element from start and check the remains (any text size) ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 3] (10) try to strip off one element from start and check the remains (any text size)\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (10) try to strip off one element from start and check the remains (any text size)\n")
} }
x_strip <- a.x_backup %>% strsplit(" ") %>% unlist() x_strip <- a.x_backup %>% strsplit(" ") %>% unlist()
if (length(x_strip) > 1 & nchar(g.x_backup_without_spp) >= 6) { if (length(x_strip) > 1 & nchar(g.x_backup_without_spp) >= 6) {
@@ -1393,10 +1391,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 3, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 3, force = force_mo_history)
} }
@@ -1407,7 +1404,7 @@ exec_as.mo <- function(x,
# (11) try to strip off one element from end and check the remains (any text size) ---- # (11) try to strip off one element from end and check the remains (any text size) ----
# (this is in fact 7 but without nchar limit of >=6) # (this is in fact 7 but without nchar limit of >=6)
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 3] (11) try to strip off one element from end and check the remains (any text size)\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (11) try to strip off one element from end and check the remains (any text size)\n")
} }
if (length(x_strip) > 1) { if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) { for (i in 1:(length(x_strip) - 1)) {
@@ -1425,10 +1422,9 @@ exec_as.mo <- function(x,
found_result <- found found_result <- found
found <- microorganismsDT[mo == found, ..property][[1]] found <- microorganismsDT[mo == found, ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 2, force = force_mo_history)
} }
@@ -1439,7 +1435,7 @@ exec_as.mo <- function(x,
# (12) part of a name (very unlikely match) ---- # (12) part of a name (very unlikely match) ----
if (isTRUE(debug)) { if (isTRUE(debug)) {
cat("\n[UNCERTAINLY LEVEL 3] (12) part of a name (very unlikely match)\n") cat("\n[ UNCERTAINTY LEVEL", now_checks_for_uncertainty_level, "] (12) part of a name (very unlikely match)\n")
} }
if (isTRUE(debug)) { if (isTRUE(debug)) {
message("Running '", f.x_withspaces_end_only, "'") message("Running '", f.x_withspaces_end_only, "'")
@@ -1450,10 +1446,9 @@ exec_as.mo <- function(x,
if (!empty_result(found_result) & nchar(g.x_backup_without_spp) >= 6) { if (!empty_result(found_result) & nchar(g.x_backup_without_spp) >= 6) {
found <- microorganismsDT[mo == found_result[1L], ..property][[1]] found <- microorganismsDT[mo == found_result[1L], ..property][[1]]
uncertainties <<- rbind(uncertainties, uncertainties <<- rbind(uncertainties,
data.frame(uncertainty = now_checks_for_uncertainty_level, format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup, input = a.x_backup,
fullname = microorganismsDT[mo == found_result[1L], fullname][[1]], result_mo = found_result[1L]))
mo = found_result[1L]))
if (initial_search == TRUE) { if (initial_search == TRUE) {
set_mo_history(a.x_backup, get_mo_code(found[1L], property), 3, force = force_mo_history) set_mo_history(a.x_backup, get_mo_code(found[1L], property), 3, force = force_mo_history)
} }
@@ -1654,6 +1649,29 @@ was_renamed <- function(name_old, name_new, ref_old = "", ref_new = "", mo = "")
options(mo_renamed = total[order(names(total))]) options(mo_renamed = total[order(names(total))])
} }
format_uncertainty_as_df <- function(uncertainty_level,
input,
result_mo) {
if (!is.null(getOption("mo_renamed_last_run", default = NULL))) {
# was found as a renamed mo
df <- data.frame(uncertainty = uncertainty_level,
input = input,
fullname = getOption("mo_renamed_last_run"),
renamed_to = microorganismsDT[mo == result_mo, fullname][[1]],
mo = result_mo,
stringsAsFactors = FALSE)
options(mo_renamed_last_run = NULL)
} else {
df <- data.frame(uncertainty = uncertainty_level,
input = input,
fullname = microorganismsDT[mo == result_mo, fullname][[1]],
renamed_to = NA_character_,
mo = result_mo,
stringsAsFactors = FALSE)
}
df
}
#' @exportMethod print.mo #' @exportMethod print.mo
#' @export #' @export
#' @noRd #' @noRd
@@ -1805,7 +1823,9 @@ print.mo_uncertainties <- function(x, ...) {
} }
msg <- paste(msg, msg <- paste(msg,
paste0(colour2(paste0(" [", x[i, "uncertainty"], "] ")), ' "', x[i, "input"], '" -> ', paste0(colour2(paste0(" [", x[i, "uncertainty"], "] ")), ' "', x[i, "input"], '" -> ',
colour1(paste0(italic(x[i, "fullname"]), " (", x[i, "mo"], ")"))), colour1(paste0(italic(x[i, "fullname"]),
ifelse(!is.na(x[i, "renamed_to"]), paste(", renamed to", italic(x[i, "renamed_to"])), ""),
" (", x[i, "mo"], ")"))),
sep = "\n") sep = "\n")
} }
cat(msg) cat(msg)

10
R/rsi_calc.R
View File

@@ -21,6 +21,8 @@
#' @importFrom rlang enquos as_label #' @importFrom rlang enquos as_label
dots2vars <- function(...) { dots2vars <- function(...) {
# this function is to give more informative output about
# variable names in count_* and portion_* functions
paste( paste(
unlist( unlist(
lapply(enquos(...), lapply(enquos(...),
@@ -109,20 +111,14 @@ rsi_calc <- function(...,
x[, i] <- suppressWarnings(x %>% pull(i) %>% as.rsi()) # warning will be given later x[, i] <- suppressWarnings(x %>% pull(i) %>% as.rsi()) # warning will be given later
print_warning <- TRUE print_warning <- TRUE
} }
#x[, i] <- x %>% pull(i)
} }
if (length(rsi_integrity_check) > 0) { if (length(rsi_integrity_check) > 0) {
# this will give a warning for invalid results, of all input columns (so only 1 warning) # this will give a warning for invalid results, of all input columns (so only 1 warning)
rsi_integrity_check <- as.rsi(rsi_integrity_check) rsi_integrity_check <- as.rsi(rsi_integrity_check)
} }
# THE CHANCE THAT AT LEAST ONE RESULT IS ab_result
#numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow()
if (only_all_tested == TRUE) { if (only_all_tested == TRUE) {
# THE NUMBER OF ISOLATES WHERE *ALL* ABx ARE S/I/R # THE NUMBER OF ISOLATES WHERE *ALL* ABx ARE S/I/R
# x_filtered <- x %>% filter_all(all_vars(!is.na(.)))
# numerator <- x_filtered %>% filter_all(any_vars(. %in% ab_result)) %>% nrow()
# denominator <- x_filtered %>% nrow()
x <- apply(X = x %>% mutate_all(as.integer), x <- apply(X = x %>% mutate_all(as.integer),
MARGIN = 1, MARGIN = 1,
FUN = base::min) FUN = base::min)
@@ -159,7 +155,7 @@ rsi_calc <- function(...,
if (data_vars != "") { if (data_vars != "") {
data_vars <- paste(" for", data_vars) data_vars <- paste(" for", data_vars)
} }
warning("Introducing NA: only ", denominator, " results available", data_vars, " (minimum set to ", minimum, ").", call. = FALSE) warning("Introducing NA: only ", denominator, " results available", data_vars, " (`minimum` was set to ", minimum, ").", call. = FALSE)
fraction <- NA fraction <- NA
} else { } else {
fraction <- numerator / denominator fraction <- numerator / denominator

2
docs/LICENSE-text.html
View File

@@ -78,7 +78,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">0.7.1.9057</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9058</span>
</span> </span>
</div> </div>

2
docs/articles/index.html
View File

@@ -78,7 +78,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">0.7.1.9057</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9058</span>
</span> </span>
</div> </div>

2
docs/authors.html
View File

@@ -78,7 +78,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">0.7.1.9057</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9058</span>
</span> </span>
</div> </div>

2
docs/index.html
View File

@@ -42,7 +42,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">0.7.1.9057</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9058</span>
</span> </span>
</div> </div>

8
docs/news/index.html
View File

@@ -78,7 +78,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">0.7.1.9057</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9058</span>
</span> </span>
</div> </div>
@@ -225,9 +225,9 @@
</div> </div>
<div id="amr-0-7-1-9057" class="section level1"> <div id="amr-0-7-1-9058" class="section level1">
<h1 class="page-header"> <h1 class="page-header">
<a href="#amr-0-7-1-9057" class="anchor"></a>AMR 0.7.1.9057<small> Unreleased </small> <a href="#amr-0-7-1-9058" class="anchor"></a>AMR 0.7.1.9058<small> Unreleased </small>
</h1> </h1>
<div id="breaking" class="section level3"> <div id="breaking" class="section level3">
<h3 class="hasAnchor"> <h3 class="hasAnchor">
@@ -1238,7 +1238,7 @@ Using <code><a href="../reference/as.mo.html">as.mo(..., allow_uncertain = 3)</a
<div id="tocnav"> <div id="tocnav">
<h2>Contents</h2> <h2>Contents</h2>
<ul class="nav nav-pills nav-stacked"> <ul class="nav nav-pills nav-stacked">
<li><a href="#amr-0-7-1-9057">0.7.1.9057</a></li> <li><a href="#amr-0-7-1-9058">0.7.1.9058</a></li>
<li><a href="#amr-0-7-1">0.7.1</a></li> <li><a href="#amr-0-7-1">0.7.1</a></li>
<li><a href="#amr-0-7-0">0.7.0</a></li> <li><a href="#amr-0-7-0">0.7.0</a></li>
<li><a href="#amr-0-6-1">0.6.1</a></li> <li><a href="#amr-0-6-1">0.6.1</a></li>

2
docs/reference/index.html
View File

@@ -78,7 +78,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">0.7.1.9057</span> <span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">0.7.1.9058</span>
</span> </span>
</div> </div>