P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 18:06:12 +01:00
Code Releases Activity

(v1.5.0.9038) quick test

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2021-03-08 01:24:37 +01:00
parent a12975bc6e
commit 461793dc34
3 changed files with 25 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

@ -1,5 +1,5 @@
Package: AMR
Version: 1.5.0.9037
Version: 1.5.0.9038
Date: 2021-03-07
Title: Antimicrobial Resistance Data Analysis
Authors@R: c(

34
R/ab.R
View File

@ -109,23 +109,23 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = TRUE, ...) {
x <- toupper(x)
x_nonNA <- x[!is.na(x)]
if (all(x_nonNA %in% antibiotics$ab, na.rm = TRUE)) {
# all valid AB codes, but not yet right class
return(set_clean_class(x,
new_class = c("ab", "character")))
}
if (all(x_nonNA %in% toupper(antibiotics$name), na.rm = TRUE)) {
# all valid AB names
out <- antibiotics$ab[match(x, toupper(antibiotics$name))]
out[is.na(x)] <- NA_character_
return(out)
}
if (all(x_nonNA %in% antibiotics$atc, na.rm = TRUE)) {
# all valid ATC codes
out <- antibiotics$ab[match(x, antibiotics$atc)]
out[is.na(x)] <- NA_character_
return(out)
}
# if (all(x_nonNA %in% antibiotics$ab, na.rm = TRUE)) {
# # all valid AB codes, but not yet right class
# return(set_clean_class(x,
# new_class = c("ab", "character")))
# }
# if (all(x_nonNA %in% toupper(antibiotics$name), na.rm = TRUE)) {
# # all valid AB names
# out <- antibiotics$ab[match(x, toupper(antibiotics$name))]
# out[is.na(x)] <- NA_character_
# return(out)
# }
# if (all(x_nonNA %in% antibiotics$atc, na.rm = TRUE)) {
# # all valid ATC codes
# out <- antibiotics$ab[match(x, antibiotics$atc)]
# out[is.na(x)] <- NA_character_
# return(out)
# }
# remove diacritics
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")

23
R/rsi.R
View File

@ -337,6 +337,8 @@ as.rsi.mic <- function(x,
meet_criteria(reference_data, allow_class = "data.frame")
check_reference_data(reference_data)
pkg_env$strange <- list(before = ab)
# for dplyr's across()
cur_column_dplyr <- import_fn("cur_column", "dplyr", error_on_fail = FALSE)
if (!is.null(cur_column_dplyr)) {
@ -345,6 +347,8 @@ as.rsi.mic <- function(x,
error = function(e) ab)
}
pkg_env$strange$afteracross <- ab
# for auto-determining mo
mo_var_found <- ""
if (is.null(mo)) {
@ -369,6 +373,7 @@ as.rsi.mic <- function(x,
}
ab_coerced <- suppressWarnings(as.ab(ab))
pkg_env$strange$coerced <- ab_coerced
mo_coerced <- suppressWarnings(as.mo(mo))
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab_coerced)) {
@ -704,6 +709,8 @@ exec_as.rsi <- function(method,
conserve_capped_values,
add_intrinsic_resistance,
reference_data) {
pkg_env$strange$exec <- ab
pkg_env$strange$names <- names(pkg_env$strange)
metadata_mo <- get_mo_failures_uncertainties_renamed()
@ -812,22 +819,6 @@ exec_as.rsi <- function(method,
get_record <- get_record[1L, , drop = FALSE]
if (NROW(get_record) > 0) {
pkg_env$strange <- list(x_dbl = as.double(x[i]),
x_chr = as.character(x[i]),
get_record = get_record,
guideline_coerced = guideline_coerced,
lookup = c(lookup_mo[i],
lookup_genus[i],
lookup_family[i],
lookup_order[i],
lookup_becker[i],
lookup_lancefield[i],
lookup_other[i]),
is_intrinsic_r = is_intrinsic_r,
c1 = x[i] <= get_record$breakpoint_S,
c2 = guideline_coerced %like% "EUCAST" & x[i] > get_record$breakpoint_R,
c2 = guideline_coerced %like% "CLSI" & x[i] >= get_record$breakpoint_R)
if (is.na(x[i]) | (is.na(get_record$breakpoint_S) & is.na(get_record$breakpoint_R))) {
new_rsi[i] <- NA_character_
} else if (method == "mic") {