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

(v0.7.1.9102) lintr

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-10-11 17:21:02 +02:00
parent 59af355a89
commit 00cdb498a0
65 changed files with 620 additions and 812 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
R/ab.R
View File

@ -79,8 +79,6 @@ as.ab <- function(x, ...) {
x_bak_clean <- gsub("_[A-Z]{2}[0-9_]{0,3}$", "", x_bak_clean, ignore.case = TRUE)
# remove part between brackets if that's followed by another string
x_bak_clean <- gsub("(.*)+ [(].*[)]", "\\1", x_bak_clean)
# keep only a-Z, 0-9, space, slash and dash
# x_bak_clean <- gsub("[^A-Z0-9 /-]", "", x_bak_clean, ignore.case = TRUE)
# keep only max 1 space
x_bak_clean <- trimws(gsub(" +", " ", x_bak_clean, ignore.case = TRUE))
# non-character, space or number should be a slash
@ -93,7 +91,7 @@ as.ab <- function(x, ...) {
x_new <- rep(NA_character_, length(x))
x_unknown <- character(0)
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
if (is.na(x[i]) | is.null(x[i])) {
next
}
@ -108,28 +106,28 @@ as.ab <- function(x, ...) {
}
# exact AB code
found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$ab == toupper(x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact ATC code
found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$atc == toupper(x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact CID code
found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$cid == x[i]), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact name
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])),]$ab
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) == toupper(x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
@ -163,7 +161,7 @@ as.ab <- function(x, ...) {
# first >=4 characters of name
if (nchar(x[i]) >= 4) {
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])),]$ab
found <- AMR::antibiotics[which(toupper(AMR::antibiotics$name) %like% paste0("^", x[i])), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
@ -193,7 +191,7 @@ as.ab <- function(x, ...) {
x_spelling <- gsub("(.)\\1+", "\\1+", x_spelling)
# try if name starts with it
found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)),]$ab
found <- AMR::antibiotics[which(AMR::antibiotics$name %like% paste0("^", x_spelling)), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
@ -233,7 +231,7 @@ as.ab <- function(x, ...) {
# transform back from other languages and try again
x_translated <- paste(lapply(strsplit(x[i], "[^a-zA-Z0-9 ]"),
function(y) {
for (i in 1:length(y)) {
for (i in seq_len(length(y))) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(translations_file$replacement),
translations_file[which(tolower(translations_file$replacement) == tolower(y[i]) &
!isFALSE(translations_file$fixed)), "pattern"],
@ -252,7 +250,7 @@ as.ab <- function(x, ...) {
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply(strsplit(x_translated, "[^a-zA-Z0-9 ]"),
function(y) {
for (i in 1:length(y)) {
for (i in seq_len(length(y))) {
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE, initial_search2 = FALSE))
y[i] <- ifelse(!is.na(y_name),
y_name,
@ -278,14 +276,14 @@ as.ab <- function(x, ...) {
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0) {
warning("These ATC codes are not (yet) in the antibiotics data set: ",
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ', '),
paste('"', sort(unique(x_unknown_ATCs)), '"', sep = "", collapse = ", "),
".",
call. = FALSE)
}
if (length(x_unknown) > 0) {
warning("These values could not be coerced to a valid antimicrobial ID: ",
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ', '),
paste('"', sort(unique(x_unknown)), '"', sep = "", collapse = ", "),
".",
call. = FALSE)
}
@ -319,7 +317,7 @@ print.ab <- function(x, ...) {
#' @exportMethod as.data.frame.ab
#' @export
#' @noRd
as.data.frame.ab <- function (x, ...) {
as.data.frame.ab <- function(x, ...) {
# same as as.data.frame.character but with removed stringsAsFactors
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
collapse = " ")

2
R/ab_property.R
View File

@ -165,7 +165,7 @@ ab_info <- function(x, language = get_locale(), ...) {
#' @rdname ab_property
#' @export
ab_property <- function(x, property = 'name', language = get_locale(), ...) {
ab_property <- function(x, property = "name", language = get_locale(), ...) {
if (length(property) != 1L) {
stop("'property' must be of length 1.")
}

2
R/age.R
View File

@ -175,7 +175,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
# turn input values to 'split_at' indices
y <- x
labs <- split_at
for (i in 1:length(split_at)) {
for (i in seq_len(length(split_at))) {
y[x >= split_at[i]] <- i
# create labels
labs[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")

2
R/amr.R
View File

@ -65,6 +65,6 @@
#' \url{https://gitlab.com/msberends/AMR/issues}
#' @name AMR
#' @rdname AMR
# # prevent NOTE on R >= 3.6
#' @importFrom microbenchmark microbenchmark
#' @importFrom knitr kable
NULL

39
R/atc_online.R
View File

@ -73,8 +73,8 @@
#' }
atc_online_property <- function(atc_code,
property,
administration = 'O',
url = 'https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no') {
administration = "O",
url = "https://www.whocc.no/atc_ddd_index/?code=%s&showdescription=no") {
if (!all(c("curl", "rvest", "xml2") %in% rownames(utils::installed.packages()))) {
stop("Packages 'xml2', 'rvest' and 'curl' are required for this function")
@ -90,15 +90,15 @@ atc_online_property <- function(atc_code,
}
if (length(property) != 1L) {
stop('`property` must be of length 1', call. = FALSE)
stop("`property` must be of length 1", call. = FALSE)
}
if (length(administration) != 1L) {
stop('`administration` must be of length 1', call. = FALSE)
stop("`administration` must be of length 1", call. = FALSE)
}
# also allow unit as property
if (property %like% 'unit') {
property <- 'U'
if (property %like% "unit") {
property <- "U"
}
# validation of properties
@ -109,12 +109,12 @@ atc_online_property <- function(atc_code,
valid_properties <- tolower(valid_properties)
if (!property %in% valid_properties) {
stop('Invalid `property`, use one of ', paste(valid_properties.bak, collapse = ", "), '.')
stop("Invalid `property`, use one of ", paste(valid_properties.bak, collapse = ", "), ".")
}
if (property == 'ddd') {
if (property == "ddd") {
returnvalue <- rep(NA_real_, length(atc_code))
} else if (property == 'groups') {
} else if (property == "groups") {
returnvalue <- list()
} else {
returnvalue <- rep(NA_character_, length(atc_code))
@ -122,11 +122,11 @@ atc_online_property <- function(atc_code,
progress <- progress_estimated(n = length(atc_code))
for (i in 1:length(atc_code)) {
for (i in seq_len(length(atc_code))) {
progress$tick()$print()
atc_url <- sub('%s', atc_code[i], url, fixed = TRUE)
atc_url <- sub("%s", atc_code[i], url, fixed = TRUE)
if (property == "groups") {
tbl <- xml2::read_html(atc_url) %>%
@ -141,34 +141,34 @@ atc_online_property <- function(atc_code,
# select only text items where URL like "code="
texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)]
# last one is antibiotics, skip it
texts <- texts[1:length(texts) - 1]
texts <- texts[seq_len(length(texts)) - 1]
returnvalue <- c(list(texts), returnvalue)
} else {
tbl <- xml2::read_html(atc_url) %>%
rvest::html_nodes('table') %>%
rvest::html_nodes("table") %>%
rvest::html_table(header = TRUE) %>%
as.data.frame(stringsAsFactors = FALSE)
# case insensitive column names
colnames(tbl) <- tolower(colnames(tbl)) %>% gsub('^atc.*', 'atc', .)
colnames(tbl) <- tolower(colnames(tbl)) %>% gsub("^atc.*", "atc", .)
if (length(tbl) == 0) {
warning('ATC not found: ', atc_code[i], '. Please check ', atc_url, '.', call. = FALSE)
warning("ATC not found: ", atc_code[i], ". Please check ", atc_url, ".", call. = FALSE)
returnvalue[i] <- NA
next
}
if (property %in% c('atc', 'name')) {
if (property %in% c("atc", "name")) {
# ATC and name are only in first row
returnvalue[i] <- tbl[1, property]
} else {
if (!'adm.r' %in% colnames(tbl) | is.na(tbl[1, 'adm.r'])) {
if (!"adm.r" %in% colnames(tbl) | is.na(tbl[1, "adm.r"])) {
returnvalue[i] <- NA
next
} else {
for (j in 1:nrow(tbl)) {
if (tbl[j, 'adm.r'] == administration) {
for (j in seq_len(length(tbl))) {
if (tbl[j, "adm.r"] == administration) {
returnvalue[i] <- tbl[j, property]
}
}
@ -195,4 +195,3 @@ atc_online_groups <- function(atc_code, ...) {
atc_online_ddd <- function(atc_code, ...) {
atc_online_property(atc_code = atc_code, property = "ddd", ...)
}

6
R/availability.R
View File

@ -44,7 +44,9 @@
#' select_if(is.rsi) %>%
#' availability()
availability <- function(tbl, width = NULL) {
x <- base::sapply(tbl, function(x) { 1 - base::sum(base::is.na(x)) / base::length(x) })
x <- base::sapply(tbl, function(x) {
1 - base::sum(base::is.na(x)) / base::length(x)
})
n <- base::sapply(tbl, function(x) base::length(x[!base::is.na(x)]))
R <- base::sapply(tbl, function(x) base::ifelse(is.rsi(x), portion_R(x, minimum = 0), NA))
R_print <- character(length(R))
@ -83,7 +85,7 @@ availability <- function(tbl, width = NULL) {
resistant = R_print,
visual_resistance = vis_resistance)
if (length(R[is.na(R)]) == ncol(tbl)) {
df[,1:3]
df[, 1:3]
} else {
df
}

12
R/bug_drug_combinations.R
View File

@ -31,7 +31,7 @@
#' @param ... arguments passed on to \code{FUN}
#' @inheritParams rsi_df
#' @inheritParams base::formatC
#' @importFrom dplyr %>% rename group_by select mutate filter pull
#' @importFrom dplyr %>% rename group_by select mutate filter summarise ungroup
#' @importFrom tidyr spread
# @importFrom clean freq percentage
#' @details The function \code{format} calculates the resistance per bug-drug combination. Use \code{combine_IR = FALSE} (default) to test R vs. S+I and \code{combine_IR = TRUE} to test R+I vs. S.
@ -46,7 +46,7 @@
#' \donttest{
#' x <- bug_drug_combinations(example_isolates)
#' x
#' format(x)
#' format(x, translate_ab = "name (atc)")
#'
#' # Use FUN to change to transformation of microorganism codes
#' x <- bug_drug_combinations(example_isolates,
@ -76,7 +76,9 @@ bug_drug_combinations <- function(x,
x <- x %>%
as.data.frame(stringsAsFactors = FALSE) %>%
mutate(mo = x %>% pull(col_mo) %>% FUN(...)) %>%
mutate(mo = x %>%
pull(col_mo) %>%
FUN(...)) %>%
group_by(mo) %>%
select_if(is.rsi) %>%
gather("ab", "value", -mo) %>%
@ -112,7 +114,7 @@ format.bug_drug_combinations <- function(x,
if (remove_intrinsic_resistant == TRUE) {
x <- x %>% filter(R != total)
}
if (combine_IR == FALSE | combine_SI == TRUE) {
if (combine_SI == TRUE | combine_IR == FALSE) {
x$isolates <- x$R
} else {
x$isolates <- x$R + x$I
@ -121,7 +123,7 @@ format.bug_drug_combinations <- function(x,
give_ab_name <- function(ab, format, language) {
format <- tolower(format)
ab_txt <- rep(format, length(ab))
for (i in 1:length(ab_txt)) {
for (i in seq_len(length(ab_txt))) {
ab_txt[i] <- gsub("ab", ab[i], ab_txt[i])
ab_txt[i] <- gsub("cid", ab_cid(ab[i]), ab_txt[i])
ab_txt[i] <- gsub("group", ab_group(ab[i], language = language), ab_txt[i])

2
R/count.R
View File

@ -154,7 +154,7 @@ count_all <- function(..., only_all_tested = FALSE) {
#' @rdname count
#' @export
n_rsi<- count_all
n_rsi <- count_all
#' @rdname count
#' @export

4
R/data.R
View File

@ -203,10 +203,10 @@ dataset_UTF8_to_ASCII <- function(df) {
iconv(vect, from = "UTF-8", to = "ASCII//TRANSLIT")
}
df <- as.data.frame(df, stringsAsFactors = FALSE)
for (i in 1:NCOL(df)) {
for (i in seq_len(NCOL(df))) {
col <- df[, i]
if (is.list(col)) {
for (j in 1:length(col)) {
for (j in seq_len(length(col))) {
col[[j]] <- trans(col[[j]])
}
df[, i] <- list(col)

10
R/disk.R
View File

@ -64,14 +64,14 @@ as.disk <- function(x, na.rm = FALSE) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>%
unique() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid disk zones: ',
"%) that were invalid disk zones: ",
list_missing, call. = FALSE)
}
class(x) <- c('disk', 'integer')
class(x) <- c("disk", "integer")
x
}
}
@ -80,7 +80,7 @@ as.disk <- function(x, na.rm = FALSE) {
#' @export
#' @importFrom dplyr %>%
is.disk <- function(x) {
class(x) %>% identical(c('disk', 'integer'))
class(x) %>% identical(c("disk", "integer"))
}
#' @exportMethod print.disk

172
R/eucast_rules.R
View File

@ -233,8 +233,15 @@ eucast_rules <- function(x,
warned <- FALSE
txt_error <- function() { cat("", bgRed(white(" ERROR ")), "\n\n") }
txt_warning <- function() { if (warned == FALSE) { cat("", bgYellow(black(" WARNING "))) }; warned <<- TRUE }
txt_error <- function() {
cat("", bgRed(white(" ERROR ")), "\n\n")
}
txt_warning <- function() {
if (warned == FALSE) {
cat("", bgYellow(black(" WARNING ")))
}
warned <<- TRUE
}
txt_ok <- function(no_added, no_changed) {
if (warned == FALSE) {
if (no_added + no_changed == 0) {
@ -337,69 +344,69 @@ eucast_rules <- function(x,
verbose = verbose,
...)
AMC <- cols_ab['AMC']
AMK <- cols_ab['AMK']
AMP <- cols_ab['AMP']
AMX <- cols_ab['AMX']
ATM <- cols_ab['ATM']
AZL <- cols_ab['AZL']
AZM <- cols_ab['AZM']
CAZ <- cols_ab['CAZ']
CED <- cols_ab['CED']
CHL <- cols_ab['CHL']
CIP <- cols_ab['CIP']
CLI <- cols_ab['CLI']
CLR <- cols_ab['CLR']
COL <- cols_ab['COL']
CRO <- cols_ab['CRO']
CTX <- cols_ab['CTX']
CXM <- cols_ab['CXM']
CZO <- cols_ab['CZO']
DAP <- cols_ab['DAP']
DOX <- cols_ab['DOX']
ERY <- cols_ab['ERY']
ETP <- cols_ab['ETP']
FEP <- cols_ab['FEP']
FLC <- cols_ab['FLC']
FOS <- cols_ab['FOS']
FOX <- cols_ab['FOX']
FUS <- cols_ab['FUS']
GEN <- cols_ab['GEN']
IPM <- cols_ab['IPM']
KAN <- cols_ab['KAN']
LIN <- cols_ab['LIN']
LNZ <- cols_ab['LNZ']
LVX <- cols_ab['LVX']
MEM <- cols_ab['MEM']
MEZ <- cols_ab['MEZ']
MFX <- cols_ab['MFX']
MNO <- cols_ab['MNO']
NAL <- cols_ab['NAL']
NEO <- cols_ab['NEO']
NET <- cols_ab['NET']
NIT <- cols_ab['NIT']
NOR <- cols_ab['NOR']
NOV <- cols_ab['NOV']
OFX <- cols_ab['OFX']
OXA <- cols_ab['OXA']
PEN <- cols_ab['PEN']
PIP <- cols_ab['PIP']
PLB <- cols_ab['PLB']
PRI <- cols_ab['PRI']
QDA <- cols_ab['QDA']
RID <- cols_ab['RID']
RIF <- cols_ab['RIF']
RXT <- cols_ab['RXT']
SIS <- cols_ab['SIS']
SXT <- cols_ab['SXT']
TCY <- cols_ab['TCY']
TEC <- cols_ab['TEC']
TGC <- cols_ab['TGC']
TIC <- cols_ab['TIC']
TMP <- cols_ab['TMP']
TOB <- cols_ab['TOB']
TZP <- cols_ab['TZP']
VAN <- cols_ab['VAN']
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
AMP <- cols_ab["AMP"]
AMX <- cols_ab["AMX"]
ATM <- cols_ab["ATM"]
AZL <- cols_ab["AZL"]
AZM <- cols_ab["AZM"]
CAZ <- cols_ab["CAZ"]
CED <- cols_ab["CED"]
CHL <- cols_ab["CHL"]
CIP <- cols_ab["CIP"]
CLI <- cols_ab["CLI"]
CLR <- cols_ab["CLR"]
COL <- cols_ab["COL"]
CRO <- cols_ab["CRO"]
CTX <- cols_ab["CTX"]
CXM <- cols_ab["CXM"]
CZO <- cols_ab["CZO"]
DAP <- cols_ab["DAP"]
DOX <- cols_ab["DOX"]
ERY <- cols_ab["ERY"]
ETP <- cols_ab["ETP"]
FEP <- cols_ab["FEP"]
FLC <- cols_ab["FLC"]
FOS <- cols_ab["FOS"]
FOX <- cols_ab["FOX"]
FUS <- cols_ab["FUS"]
GEN <- cols_ab["GEN"]
IPM <- cols_ab["IPM"]
KAN <- cols_ab["KAN"]
LIN <- cols_ab["LIN"]
LNZ <- cols_ab["LNZ"]
LVX <- cols_ab["LVX"]
MEM <- cols_ab["MEM"]
MEZ <- cols_ab["MEZ"]
MFX <- cols_ab["MFX"]
MNO <- cols_ab["MNO"]
NAL <- cols_ab["NAL"]
NEO <- cols_ab["NEO"]
NET <- cols_ab["NET"]
NIT <- cols_ab["NIT"]
NOR <- cols_ab["NOR"]
NOV <- cols_ab["NOV"]
OFX <- cols_ab["OFX"]
OXA <- cols_ab["OXA"]
PEN <- cols_ab["PEN"]
PIP <- cols_ab["PIP"]
PLB <- cols_ab["PLB"]
PRI <- cols_ab["PRI"]
QDA <- cols_ab["QDA"]
RID <- cols_ab["RID"]
RIF <- cols_ab["RIF"]
RXT <- cols_ab["RXT"]
SIS <- cols_ab["SIS"]
SXT <- cols_ab["SXT"]
TCY <- cols_ab["TCY"]
TEC <- cols_ab["TEC"]
TGC <- cols_ab["TGC"]
TIC <- cols_ab["TIC"]
TMP <- cols_ab["TMP"]
TOB <- cols_ab["TOB"]
TZP <- cols_ab["TZP"]
VAN <- cols_ab["VAN"]
ab_missing <- function(ab) {
all(ab %in% c(NULL, NA))
@ -425,11 +432,11 @@ eucast_rules <- function(x,
# insert into original table
x_original[rows, cols] <<- to,
warning = function(w) {
if (w$message %like% 'invalid factor level') {
if (w$message %like% "invalid factor level") {
x_original <<- x_original %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x <<- x %>% mutate_at(vars(cols), ~factor(x = as.character(.), levels = c(to, levels(.))))
x_original[rows, cols] <<- to
warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = '`, `'), '` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.', call. = FALSE)
warning('Value "', to, '" added to the factor levels of column(s) `', paste(cols, collapse = "`, `"), "` because this value was not an existing factor level.\nA better way is to use as.rsi() on beforehand on antimicrobial columns to guarantee the right structure.", call. = FALSE)
txt_warning()
warned <<- FALSE
} else {
@ -442,8 +449,8 @@ eucast_rules <- function(x,
txt_error()
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
ifelse(length(rows) > 10, "...", ""),
' while writing value "', to,
'" to column(s) `', paste(cols, collapse = "`, `"),
" while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message),
call. = FALSE)
}
@ -453,17 +460,17 @@ eucast_rules <- function(x,
x[rows, cols] <<- x_original[rows, cols],
error = function(e) {
stop(paste0("In row(s) ", paste(rows[1:min(length(rows), 10)], collapse = ","),
'... while writing value "', to,
'" to column(s) `', paste(cols, collapse = "`, `"),
"... while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message), call. = FALSE)
}
)
# before_df might not be a data.frame, but a tibble or data.table instead
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows, ]
track_changes <- list(added = 0,
changed = 0)
for (i in 1:length(cols)) {
for (i in seq_len(length(cols))) {
verbose_new <- data.frame(row = rows,
col = cols[i],
mo_fullname = x[rows, "fullname"],
@ -530,6 +537,7 @@ eucast_rules <- function(x,
AMP <- AMX
}
# nolint start
# antibiotic classes
aminoglycosides <- c(TOB, GEN, KAN, NEO, NET, SIS)
tetracyclines <- c(DOX, MNO, TCY) # since EUCAST v3.1 tigecycline (TGC) is set apart
@ -544,12 +552,13 @@ eucast_rules <- function(x,
ureidopenicillins <- c(PIP, TZP, AZL, MEZ)
all_betalactams <- c(aminopenicillins, cephalosporins, carbapenems, ureidopenicillins, AMC, OXA, FLC, PEN)
fluoroquinolones <- c(OFX, CIP, NOR, LVX, MFX)
# nolint end
# Help function to get available antibiotic column names ------------------
get_antibiotic_columns <- function(x, df) {
x <- trimws(unlist(strsplit(x, ",", fixed = TRUE)))
y <- character(0)
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
if (is.function(get(x[i]))) {
stop("Column ", x[i], " is also a function. Please create an issue on github.com/msberends/AMR/issues.")
}
@ -562,7 +571,7 @@ eucast_rules <- function(x,
strsplit(",") %>%
unlist() %>%
trimws() %>%
sapply(function(x) if(x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %>%
sapply(function(x) if (x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE) else x) %>%
sort() %>%
paste(collapse = ", ")
}
@ -598,14 +607,13 @@ eucast_rules <- function(x,
eucast_rules_df <- eucast_rules_file # internal data file
no_added <- 0
no_changed <- 0
for (i in 1:nrow(eucast_rules_df)) {
for (i in seq_len(nrow(eucast_rules_df))) {
rule_previous <- eucast_rules_df[max(1, i - 1), "reference.rule"]
rule_current <- eucast_rules_df[i, "reference.rule"]
rule_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule"]
rule_group_previous <- eucast_rules_df[max(1, i - 1), "reference.rule_group"]
rule_group_current <- eucast_rules_df[i, "reference.rule_group"]
rule_group_next <- eucast_rules_df[min(nrow(eucast_rules_df), i + 1), "reference.rule_group"]
if (is.na(eucast_rules_df[i, 4])) {
rule_text <- paste0("always report as '", eucast_rules_df[i, 7], "': ", get_antibiotic_names(eucast_rules_df[i, 6]))
} else {
@ -620,7 +628,6 @@ eucast_rules <- function(x,
}
if (i == nrow(eucast_rules_df)) {
rule_next <- ""
rule_group_next <- ""
}
# don't apply rules if user doesn't want to apply them
@ -695,7 +702,7 @@ eucast_rules <- function(x,
if (like_is_one_of == "is") {
mo_value <- paste0("^", eucast_rules_df[i, 3], "$")
} else if (like_is_one_of == "one_of") {
# "Clostridium, Actinomyces, ..." -> "^(Clostridium|Actinomyces|...)$"
# so 'Clostridium, Actinomyces, ...' will turn into '^(Clostridium|Actinomyces|...)$'
mo_value <- paste0("^(",
paste(trimws(unlist(strsplit(eucast_rules_df[i, 3], ",", fixed = TRUE))),
collapse = "|"),
@ -774,10 +781,10 @@ eucast_rules <- function(x,
arrange(row, rule_group, rule_name, col)
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)),
'out of', formatnr(nrow(x_original)),
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n')))
"out of", formatnr(nrow(x_original)),
"rows, making a total of", formatnr(nrow(verbose_info)), "edits\n")))
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow()
@ -847,4 +854,3 @@ eucast_rules <- function(x,
x_original
}
}

208
R/first_isolate.R
View File

@ -124,39 +124,11 @@
#' # set key antibiotics to a new variable
#' x$keyab <- key_antibiotics(x)
#'
#' x$first_isolate <-
#' first_isolate(x)
#' x$first_isolate <- first_isolate(x)
#'
#' x$first_isolate_weighed <-
#' first_isolate(x,
#' col_keyantibiotics = 'keyab')
#' x$first_isolate_weighed <- first_isolate(x, col_keyantibiotics = 'keyab')
#'
#' x$first_blood_isolate <-
#' first_isolate(x,
#' specimen_group = 'Blood')
#'
#' x$first_blood_isolate_weighed <-
#' first_isolate(x,
#' specimen_group = 'Blood',
#' col_keyantibiotics = 'keyab')
#'
#' x$first_urine_isolate <-
#' first_isolate(x,
#' specimen_group = 'Urine')
#'
#' x$first_urine_isolate_weighed <-
#' first_isolate(x,
#' specimen_group = 'Urine',
#' col_keyantibiotics = 'keyab')
#'
#' x$first_resp_isolate <-
#' first_isolate(x,
#' specimen_group = 'Respiratory')
#'
#' x$first_resp_isolate_weighed <-
#' first_isolate(x,
#' specimen_group = 'Respiratory',
#' col_keyantibiotics = 'keyab')
#' x$first_blood_isolate <- first_isolate(x, specimen_group = "Blood")
#' }
first_isolate <- function(x,
col_date = NULL,
@ -176,23 +148,23 @@ first_isolate <- function(x,
info = TRUE,
include_unknown = FALSE,
...) {
if (!is.data.frame(x)) {
stop("`x` must be a data.frame.", call. = FALSE)
}
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old parameters
dots.names <- dots %>% names()
if ('filter_specimen' %in% dots.names) {
specimen_group <- dots[which(dots.names == 'filter_specimen')]
if ("filter_specimen" %in% dots.names) {
specimen_group <- dots[which(dots.names == "filter_specimen")]
}
if ('tbl' %in% dots.names) {
x <- dots[which(dots.names == 'tbl')]
if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == "tbl")]
}
}
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
@ -201,7 +173,7 @@ first_isolate <- function(x,
if (is.null(col_mo)) {
stop("`col_mo` must be set.", call. = FALSE)
}
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date")
@ -213,14 +185,14 @@ first_isolate <- function(x,
dates <- x %>% pull(col_date) %>% as.Date()
dates[is.na(dates)] <- as.Date("1970-01-01")
x[, col_date] <- dates
# -- patient id
if (is.null(col_patient_id)) {
if (all(c("First name", "Last name", "Sex", "Identification number") %in% colnames(x))) {
if (all(c("First name", "Last name", "Sex") %in% colnames(x))) {
# WHONET support
x <- x %>% mutate(patient_id = paste(`First name`, `Last name`, Sex))
col_patient_id <- "patient_id"
message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`.")))
message(blue(paste0("NOTE: Using combined columns `", bold("First name"), "`, `", bold("Last name"), "` and `", bold("Sex"), "` as input for `col_patient_id`")))
} else {
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
}
@ -228,7 +200,7 @@ first_isolate <- function(x,
if (is.null(col_patient_id)) {
stop("`col_patient_id` must be set.", call. = FALSE)
}
# -- key antibiotics
if (is.null(col_keyantibiotics)) {
col_keyantibiotics <- search_type_in_df(x = x, type = "keyantibiotics")
@ -236,7 +208,7 @@ first_isolate <- function(x,
if (isFALSE(col_keyantibiotics)) {
col_keyantibiotics <- NULL
}
# -- specimen
if (is.null(col_specimen) & !is.null(specimen_group)) {
col_specimen <- search_type_in_df(x = x, type = "specimen")
@ -244,30 +216,30 @@ first_isolate <- function(x,
if (isFALSE(col_specimen)) {
col_specimen <- NULL
}
# check if columns exist
check_columns_existance <- function(column, tblname = x) {
if (NROW(tblname) <= 1 | NCOL(tblname) <= 1) {
stop('Please check tbl for existance.')
stop("Please check tbl for existance.")
}
if (!is.null(column)) {
if (!(column %in% colnames(tblname))) {
stop('Column `', column, '` not found.')
stop("Column `", column, "` not found.")
}
}
}
check_columns_existance(col_date)
check_columns_existance(col_patient_id)
check_columns_existance(col_mo)
check_columns_existance(col_testcode)
check_columns_existance(col_icu)
check_columns_existance(col_keyantibiotics)
# create new dataframe with original row index
x <- x %>%
mutate(newvar_row_index = 1:nrow(x),
mutate(newvar_row_index = seq_len(nrow(x)),
newvar_mo = x %>% pull(col_mo) %>% as.mo(),
newvar_genus_species = paste(mo_genus(newvar_mo), mo_species(newvar_mo)),
newvar_date = x %>% pull(col_date),
@ -278,41 +250,41 @@ first_isolate <- function(x,
}
# remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE) {
cat('[Criterion] Excluded test codes:\n', toString(testcodes_exclude), '\n')
message(blue(paste0("[Criterion] Excluded test codes: ", toString(testcodes_exclude))))
}
if (is.null(col_icu)) {
icu_exclude <- FALSE
} else {
x <- x %>%
mutate(col_icu = x %>% pull(col_icu) %>% as.logical())
}
if (is.null(col_specimen)) {
specimen_group <- NULL
}
# filter on specimen group and keyantibiotics when they are filled in
if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x)
if (info == TRUE) {
cat('[Criterion] Excluded other than specimen group \'', specimen_group, '\'\n', sep = '')
message(blue(paste0("[Criterion] Excluded other than specimen group '", specimen_group, "'")))
}
}
if (!is.null(col_keyantibiotics)) {
x <- x %>% mutate(key_ab = x %>% pull(col_keyantibiotics))
}
if (is.null(testcodes_exclude)) {
testcodes_exclude <- ''
testcodes_exclude <- ""
}
# arrange data to the right sorting
if (is.null(specimen_group)) {
# not filtering on specimen
if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) {
cat('[Criterion] Included isolates from ICU.\n')
message(blue("[Criterion] Included isolates from ICU"))
}
x <- x %>%
arrange(newvar_patient_id,
@ -322,14 +294,14 @@ first_isolate <- function(x,
row.end <- nrow(x)
} else {
if (info == TRUE) {
cat('[Criterion] Excluded isolates from ICU.\n')
message(blue("[Criterion] Excluded isolates from ICU"))
}
x <- x %>%
arrange_at(c(col_icu,
"newvar_patient_id",
"newvar_genus_species",
"newvar_date"))
suppressWarnings(
row.start <- which(x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
)
@ -337,12 +309,12 @@ first_isolate <- function(x,
row.end <- which(x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
)
}
} else {
# filtering on specimen and only analyse these row to save time
if (icu_exclude == FALSE) {
if (info == TRUE & !is.null(col_icu)) {
cat('[Criterion] Included isolates from ICU.\n')
message(blue("[Criterion] Included isolates from ICU.\n"))
}
x <- x %>%
arrange_at(c(col_specimen,
@ -357,7 +329,7 @@ first_isolate <- function(x,
)
} else {
if (info == TRUE) {
cat('[Criterion] Excluded isolates from ICU.\n')
message(blue("[Criterion] Excluded isolates from ICU"))
}
x <- x %>%
arrange_at(c(col_icu,
@ -366,17 +338,19 @@ first_isolate <- function(x,
"newvar_genus_species",
"newvar_date"))
suppressWarnings(
row.start <- which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE) %>% min(na.rm = TRUE)
row.start <- min(which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
)
suppressWarnings(
row.end <- which(x %>% pull(col_specimen) == specimen_group
& x %>% pull(col_icu) == FALSE) %>% max(na.rm = TRUE)
row.end <- max(which(x %>% pull(col_specimen) == specimen_group &
x %>% pull(col_icu) == FALSE),
na.rm = TRUE)
)
}
}
# no isolates found
if (abs(row.start) == Inf | abs(row.end) == Inf) {
if (info == TRUE) {
@ -386,21 +360,11 @@ first_isolate <- function(x,
}
# did find some isolates - add new index numbers of rows
x <- x %>% mutate(newvar_row_index_sorted = 1:nrow(.))
# suppress warnings because dplyr wants us to use library(dplyr) when using filter(row_number())
#suppressWarnings(
scope.size <- row.end - row.start + 1
# x %>%
# filter(
# row_number() %>% between(row.start,
# row.end),
# newvar_genus != "",
# newvar_species != "") %>%
# nrow()
# )
identify_new_year = function(x, episode_days) {
x <- x %>% mutate(newvar_row_index_sorted = seq_len(nrow(.)))
scope.size <- row.end - row.start + 1
identify_new_year <- function(x, episode_days) {
# I asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
if (length(x) == 1) {
@ -421,7 +385,7 @@ first_isolate <- function(x,
result[indices] <- TRUE
return(result)
}
# Analysis of first isolate ----
all_first <- x %>%
mutate(other_pat_or_mo = if_else(newvar_patient_id == lag(newvar_patient_id)
@ -433,21 +397,19 @@ first_isolate <- function(x,
mutate(more_than_episode_ago = identify_new_year(x = newvar_date,
episode_days = episode_days)) %>%
ungroup()
weighted.notice <- ''
weighted.notice <- ""
if (!is.null(col_keyantibiotics)) {
weighted.notice <- 'weighted '
weighted.notice <- "weighted "
if (info == TRUE) {
if (type == 'keyantibiotics') {
cat('[Criterion] Inclusion based on key antibiotics, ')
if (ignore_I == FALSE) {
cat('not ')
}
cat('ignoring I.\n')
if (type == "keyantibiotics") {
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, ",
ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I")))
}
if (type == 'points') {
cat(paste0('[Criterion] Inclusion based on key antibiotics, using points threshold of '
, points_threshold, '.\n'))
if (type == "points") {
message(blue(paste0("[Criterion] Inclusion based on key antibiotics, using points threshold of "
, points_threshold)))
}
}
type_param <- type
@ -473,24 +435,24 @@ first_isolate <- function(x,
# no key antibiotics
all_first <- all_first %>%
mutate(
real_first_isolate =
if_else(
newvar_row_index_sorted %>% between(row.start, row.end)
& newvar_genus_species != ""
& (other_pat_or_mo | more_than_episode_ago),
TRUE,
FALSE))
real_first_isolate =
if_else(
newvar_row_index_sorted %>% between(row.start, row.end)
& newvar_genus_species != ""
& (other_pat_or_mo | more_than_episode_ago),
TRUE,
FALSE))
}
# first one as TRUE
all_first[row.start, 'real_first_isolate'] <- TRUE
all_first[row.start, "real_first_isolate"] <- TRUE
# no tests that should be included, or ICU
if (!is.null(col_testcode)) {
all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), 'real_first_isolate'] <- FALSE
all_first[which(all_first[, col_testcode] %in% tolower(testcodes_exclude)), "real_first_isolate"] <- FALSE
}
if (icu_exclude == TRUE) {
all_first[which(all_first[, col_icu] == TRUE), 'real_first_isolate'] <- FALSE
all_first[which(all_first[, col_icu] == TRUE), "real_first_isolate"] <- FALSE
}
decimal.mark <- getOption("OutDec")
@ -498,26 +460,20 @@ first_isolate <- function(x,
# handle empty microorganisms
if (any(all_first$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
if (include_unknown == TRUE) {
message(blue(paste0("NOTE: Included ", format(sum(all_first$newvar_mo == "UNKNOWN"),
decimal.mark = decimal.mark, big.mark = big.mark),
' isolates with a microbial ID "UNKNOWN" (column `', bold(col_mo), '`).')))
} else {
message(blue(paste0("NOTE: Excluded ", format(sum(all_first$newvar_mo == "UNKNOWN"),
decimal.mark = decimal.mark, big.mark = big.mark),
' isolates with a microbial ID "UNKNOWN" (column `', bold(col_mo), '`).')))
}
message(blue(paste0("NOTE: ", ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(all_first$newvar_mo == "UNKNOWN"),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'UNKNOWN' (column `", bold(col_mo), "`)")))
}
all_first[which(all_first$newvar_mo == "UNKNOWN"), 'real_first_isolate'] <- include_unknown
all_first[which(all_first$newvar_mo == "UNKNOWN"), "real_first_isolate"] <- include_unknown
# exclude all NAs
if (any(is.na(all_first$newvar_mo)) & info == TRUE) {
message(blue(paste0("NOTE: Excluded ", format(sum(is.na(all_first$newvar_mo)),
decimal.mark = decimal.mark, big.mark = big.mark),
' isolates with a microbial ID "NA" (column `', bold(col_mo), '`).')))
" isolates with a microbial ID 'NA' (column `", bold(col_mo), "`)")))
}
all_first[which(is.na(all_first$newvar_mo)), 'real_first_isolate'] <- FALSE
all_first[which(is.na(all_first$newvar_mo)), "real_first_isolate"] <- FALSE
# arrange back according to original sorting again
all_first <- all_first %>%
@ -541,9 +497,9 @@ first_isolate <- function(x,
}
base::message(msg_txt)
}
all_first
}
#' @rdname first_isolate
@ -580,5 +536,5 @@ filter_first_weighted_isolate <- function(x,
col_mo = col_mo,
col_keyantibiotics = "keyab",
...))
x[which(tbl_keyab$firsts == TRUE),]
x[which(tbl_keyab$firsts == TRUE), ]
}

75
R/g.test.R
View File

@ -107,10 +107,10 @@
#' # Meaning: there are significantly more left-billed birds.
#'
g.test <- function(x,
y = NULL,
# correct = TRUE,
p = rep(1/length(x), length(x)),
rescale.p = FALSE) {
y = NULL,
# correct = TRUE,
p = rep(1 / length(x), length(x)),
rescale.p = FALSE) {
DNAME <- deparse(substitute(x))
if (is.data.frame(x))
x <- as.matrix(x)
@ -144,11 +144,8 @@ g.test <- function(x,
stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0)
stop("at least one entry of 'x' must be positive")
# if (simulate.p.value) {
# setMETH <- function() METHOD <<- paste(METHOD, "with simulated p-value\n\t (based on",
# B, "replicates)")
# almost.1 <- 1 - 64 * .Machine$double.eps
# }
if (is.matrix(x)) {
METHOD <- "G-test of independence"
nr <- as.integer(nrow(x))
@ -157,34 +154,18 @@ g.test <- function(x,
stop("invalid nrow(x) or ncol(x)", domain = NA)
# add fisher.test suggestion
if (nr == 2 && nc == 2)
warning("`fisher.test()` is always more reliable for 2x2 tables and although must slower, often only takes seconds.")
warning("`fisher.test()` is always more reliable for 2x2 tables and although much slower, often only takes seconds.")
sr <- rowSums(x)
sc <- colSums(x)
E <- outer(sr, sc, "*")/n
v <- function(r, c, n) c * r * (n - r) * (n - c)/n^3
E <- outer(sr, sc, "*") / n
v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3
V <- outer(sr, sc, v, n)
dimnames(E) <- dimnames(x)
# if (simulate.p.value && all(sr > 0) && all(sc > 0)) {
# setMETH()
# tmp <- .Call(chisq_sim, sr, sc, B, E, PACKAGE = "stats")
# STATISTIC <- 2 * sum(x * log(x / E)) # sum(sort((x - E)^2/E, decreasing = TRUE)) for chisq.test
# PARAMETER <- NA
# PVAL <- (1 + sum(tmp >= almost.1 * STATISTIC))/(B +
# 1)
# }
# else {
# if (simulate.p.value)
# warning("cannot compute simulated p-value with zero marginals")
# if (correct && nrow(x) == 2L && ncol(x) == 2L) {
# YATES <- min(0.5, abs(x - E))
# if (YATES > 0)
# METHOD <- paste(METHOD, "with Yates' continuity correction")
# }
# else YATES <- 0
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
else {
if (length(dim(x)) > 2L)
@ -197,7 +178,7 @@ g.test <- function(x,
stop("probabilities must be non-negative.")
if (abs(sum(p) - 1) > sqrt(.Machine$double.eps)) {
if (rescale.p)
p <- p/sum(p)
p <- p / sum(p)
else stop("probabilities must sum to 1.")
}
METHOD <- "G-test of goodness-of-fit (likelihood ratio test)"
@ -205,30 +186,18 @@ g.test <- function(x,
V <- n * p * (1 - p)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test
names(E) <- names(x)
# if (simulate.p.value) {
# setMETH()
# nx <- length(x)
# sm <- matrix(sample.int(nx, B * n, TRUE, prob = p),
# nrow = n)
# ss <- apply(sm, 2L, function(x, E, k) {
# sum((table(factor(x, levels = 1L:k)) - E)^2/E)
# }, E = E, k = nx)
# PARAMETER <- NA
# PVAL <- (1 + sum(ss >= almost.1 * STATISTIC))/(B +
# 1)
# }
# else {
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
names(STATISTIC) <- "X-squared"
names(PARAMETER) <- "df"
if (any(E < 5) && is.finite(PARAMETER))
warning("G-statistic approximation may be incorrect due to E < 5")
structure(list(statistic = STATISTIC, parameter = PARAMETER,
p.value = PVAL, method = METHOD, data.name = DNAME,
observed = x, expected = E, residuals = (x - E)/sqrt(E),
stdres = (x - E)/sqrt(V)), class = "htest")
observed = x, expected = E, residuals = (x - E) / sqrt(E),
stdres = (x - E) / sqrt(V)), class = "htest")
}

12
R/ggplot_rsi.R
View File

@ -292,9 +292,9 @@ geom_rsi <- function(position = NULL,
x <- substr(x, 2, nchar(x) - 1)
}
if (tolower(x) %in% tolower(c('ab', 'abx', 'antibiotics'))) {
if (tolower(x) %in% tolower(c("ab", "abx", "antibiotics"))) {
x <- "antibiotic"
} else if (tolower(x) %in% tolower(c('SIR', 'RSI', 'interpretations', 'result'))) {
} else if (tolower(x) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
x <- "interpretation"
}
@ -327,9 +327,9 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
facet <- substr(facet, 2, nchar(facet) - 1)
}
if (tolower(facet) %in% tolower(c('SIR', 'RSI', 'interpretations', 'result'))) {
if (tolower(facet) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
facet <- "interpretation"
} else if (tolower(facet) %in% tolower(c('ab', 'abx', 'antibiotics'))) {
} else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
facet <- "antibiotic"
}
@ -358,8 +358,8 @@ scale_rsi_colours <- function(colours = c(S = "#61a8ff",
IR = "#ff6961",
R = "#ff6961")) {
stopifnot_installed_package("ggplot2")
#ggplot2::scale_fill_brewer(palette = "RdYlGn")
#ggplot2::scale_fill_manual(values = c("#b22222", "#ae9c20", "#7cfc00"))
# previous colour: palette = "RdYlGn"
# previous colours: values = c("#b22222", "#ae9c20", "#7cfc00")
if (!identical(colours, FALSE)) {
original_cols <- c(S = "#61a8ff",

15
R/guess_ab_col.R
View File

@ -83,9 +83,6 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE) {
} else if (any(tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations"))))) {
ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(unlist(ab_property(search_string.ab, "abbreviations")))][1L]
# } else if (any(tolower(colnames(x)) %in% tolower(ab_tradenames(search_string.ab)))) {
# ab_result <- colnames(x)[tolower(colnames(x)) %in% tolower(ab_tradenames(search_string.ab))][1L]
} else {
# sort colnames on length - longest first
cols <- colnames(x[, x %>% colnames() %>% nchar() %>% order() %>% rev()])
@ -128,7 +125,7 @@ get_column_abx <- function(x,
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
# or already have the rsi class (as.rsi)
# and that have no more than 50% invalid values
vectr_antibiotics <- unique(toupper(unlist(AMR::antibiotics[,c("ab", "atc", "name", "abbreviations", "synonyms")])))
vectr_antibiotics <- unique(toupper(unlist(AMR::antibiotics[, c("ab", "atc", "name", "abbreviations", "synonyms")])))
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- sapply(colnames(x), function(col, df = x_bak) {
if (toupper(col) %in% vectr_antibiotics |
@ -144,12 +141,12 @@ get_column_abx <- function(x,
df_trans <- data.frame(colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x))))
df_trans <- df_trans[!is.na(df_trans$abcode),]
df_trans <- df_trans[!is.na(df_trans$abcode), ]
x <- as.character(df_trans$colnames)
names(x) <- df_trans$abcode
# add from self-defined dots (...):
# get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
# such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
dots <- list(...)
if (length(dots) > 0) {
newnames <- suppressWarnings(as.ab(names(dots)))
@ -173,12 +170,12 @@ get_column_abx <- function(x,
x <- x[!names(x) %in% names(duplicates)]
if (verbose == TRUE) {
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
message(blue(paste0("NOTE: Using column `", bold(x[i]), "` as input for `", names(x)[i],
"` (", ab_name(names(x)[i], tolower = TRUE), ").")))
}
} else if (length(duplicates) > 0) {
for (i in 1:length(duplicates)) {
for (i in seq_len(length(duplicates))) {
warning(red(paste0("Using column `", bold(duplicates[i]), "` as input for `", names(x[which(x == duplicates[i])]),
"` (", ab_name(names(x[names(which(x == duplicates))[i]]), tolower = TRUE),
"), although it was matched for multiple antibiotics or columns.")), call. = FALSE)
@ -203,7 +200,7 @@ get_column_abx <- function(x,
mutate(txt = paste0(bold(missing), " (", missing_names, ")")) %>%
arrange(missing_names) %>%
pull(txt)
message(blue('NOTE: Reliability might be improved if these antimicrobial results would be available too:',
message(blue("NOTE: Reliability might be improved if these antimicrobial results would be available too:",
paste(missing_txt, collapse = ", ")))
}
}

8
R/join_microorganisms.R
View File

@ -56,7 +56,7 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::inner_join(x = x, y = AMR::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.')
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
join
}
@ -71,7 +71,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::left_join(x = x, y = AMR::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.')
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
join
}
@ -86,7 +86,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::right_join(x = x, y = AMR::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.')
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
join
}
@ -101,7 +101,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
dplyr::full_join(x = x, y = AMR::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.')
warning("The newly joined tbl contains ", nrow(join) - nrow(x), " rows more that its original.")
}
join
}

30
R/key_antibiotics.R
View File

@ -118,7 +118,7 @@ key_antibiotics <- function(x,
names(col.list) <- col.list
col.list.bak <- col.list
# are they available as upper case or lower case then?
for (i in 1:length(col.list)) {
for (i in seq_len(length(col.list))) {
if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) {
col.list[i] <- NA
} else if (toupper(col.list[i]) %in% colnames(x)) {
@ -131,9 +131,9 @@ key_antibiotics <- function(x,
}
if (!all(col.list %in% colnames(x))) {
if (info == TRUE) {
warning('Some columns do not exist and will be ignored: ',
warning("Some columns do not exist and will be ignored: ",
col.list.bak[!(col.list %in% colnames(x))] %>% toString(),
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
".\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.",
immediate. = TRUE,
call. = FALSE)
}
@ -164,7 +164,7 @@ key_antibiotics <- function(x,
universal <- c(universal_1, universal_2, universal_3,
universal_4, universal_5, universal_6)
gram_positive = c(universal,
gram_positive <- c(universal,
GramPos_1, GramPos_2, GramPos_3,
GramPos_4, GramPos_5, GramPos_6)
gram_positive <- gram_positive[!is.null(gram_positive)]
@ -173,7 +173,7 @@ key_antibiotics <- function(x,
warning("only using ", length(gram_positive), " different antibiotics as key antibiotics for Gram-positives. See ?key_antibiotics.", call. = FALSE)
}
gram_negative = c(universal,
gram_negative <- c(universal,
GramNeg_1, GramNeg_2, GramNeg_3,
GramNeg_4, GramNeg_5, GramNeg_6)
gram_negative <- gram_negative[!is.null(gram_negative)]
@ -211,8 +211,8 @@ key_antibiotics <- function(x,
# format
key_abs <- x %>%
pull(key_ab) %>%
gsub('(NA|NULL)', '.', .) %>%
gsub('[^SIR]', '.', ., ignore.case = TRUE) %>%
gsub("(NA|NULL)", ".", .) %>%
gsub("[^SIR]", ".", ., ignore.case = TRUE) %>%
toupper()
if (n_distinct(key_abs) == 1) {
@ -239,7 +239,7 @@ key_antibiotics_equal <- function(y,
type <- type[1]
if (length(x) != length(y)) {
stop('Length of `x` and `y` must be equal.')
stop("Length of `x` and `y` must be equal.")
}
# only show progress bar on points or when at least 5000 isolates
@ -251,17 +251,17 @@ key_antibiotics_equal <- function(y,
p <- dplyr::progress_estimated(length(x))
}
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
if (info_needed == TRUE) {
p$tick()$print()
}
if (is.na(x[i])) {
x[i] <- ''
x[i] <- ""
}
if (is.na(y[i])) {
y[i] <- ''
y[i] <- ""
}
if (x[i] == y[i]) {
@ -277,7 +277,7 @@ key_antibiotics_equal <- function(y,
x_split <- strsplit(x[i], "")[[1]]
y_split <- strsplit(y[i], "")[[1]]
if (type == 'keyantibiotics') {
if (type == "keyantibiotics") {
if (ignore_I == TRUE) {
x_split[x_split == "I"] <- "."
@ -289,7 +289,7 @@ key_antibiotics_equal <- function(y,
result[i] <- all(x_split == y_split)
} else if (type == 'points') {
} else if (type == "points") {
# count points for every single character:
# - no change is 0 points
# - I <-> S|R is 0.5 point
@ -303,12 +303,12 @@ key_antibiotics_equal <- function(y,
result[i] <- points >= points_threshold
} else {
stop('`', type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?key_antibiotics')
stop("`", type, '` is not a valid value for type, must be "points" or "keyantibiotics". See ?key_antibiotics')
}
}
}
if (info_needed == TRUE) {
cat('\n')
cat("\n")
}
result
}

6
R/kurtosis.R
View File

@ -37,7 +37,7 @@ kurtosis <- function(x, na.rm = FALSE) {
#' @exportMethod kurtosis.default
#' @rdname kurtosis
#' @export
kurtosis.default <- function (x, na.rm = FALSE) {
kurtosis.default <- function(x, na.rm = FALSE) {
x <- as.vector(x)
if (na.rm == TRUE) {
x <- x[!is.na(x)]
@ -50,13 +50,13 @@ kurtosis.default <- function (x, na.rm = FALSE) {
#' @exportMethod kurtosis.matrix
#' @rdname kurtosis
#' @export
kurtosis.matrix <- function (x, na.rm = FALSE) {
kurtosis.matrix <- function(x, na.rm = FALSE) {
base::apply(x, 2, kurtosis.default, na.rm = na.rm)
}
#' @exportMethod kurtosis.data.frame
#' @rdname kurtosis
#' @export
kurtosis.data.frame <- function (x, na.rm = FALSE) {
kurtosis.data.frame <- function(x, na.rm = FALSE) {
base::sapply(x, kurtosis.default, na.rm = na.rm)
}

2
R/like.R
View File

@ -69,7 +69,7 @@ like <- function(x, pattern, ignore.case = TRUE) {
} else {
# x and pattern are of same length, so items with each other
res <- vector(length = length(pattern))
for (i in 1:length(res)) {
for (i in seq_len(length(res))) {
if (is.factor(x[i])) {
res[i] <- as.integer(x[i]) %in% base::grep(pattern[i], levels(x[i]), ignore.case = ignore.case)
} else {

4
R/mdro.R
View File

@ -272,7 +272,7 @@ mdro <- function(x,
row_filter <- which(x[, cols] == "R")
} else if (any_all == "all") {
row_filter <- x %>%
mutate(index = 1:nrow(.)) %>%
mutate(index = seq_len(nrow(.))) %>%
filter_at(vars(cols), all_vars(. == "R")) %>%
pull((index))
}
@ -452,7 +452,7 @@ mdro <- function(x,
& !ab_missing(GEN) & !ab_missing(TOB)
& !ab_missing(CIP)
& !ab_missing(CAZ)
& !ab_missing(TZP) ) {
& !ab_missing(TZP)) {
x$psae <- 0
x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"] <- 1 + x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"]
x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"] <- 1 + x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"]

62
R/mic.R
View File

@ -65,29 +65,29 @@ as.mic <- function(x, na.rm = FALSE) {
x.bak <- x
# comma to period
x <- gsub(',', '.', x, fixed = TRUE)
x <- gsub(",", ".", x, fixed = TRUE)
# remove space between operator and number ("<= 0.002" -> "<=0.002")
x <- gsub('(<|=|>) +', '\\1', x)
x <- gsub("(<|=|>) +", "\\1", x)
# transform => to >= and =< to <=
x <- gsub('=>', '>=', x, fixed = TRUE)
x <- gsub('=<', '<=', x, fixed = TRUE)
x <- gsub("=>", ">=", x, fixed = TRUE)
x <- gsub("=<", "<=", x, fixed = TRUE)
# starting dots must start with 0
x <- gsub('^[.]+', '0.', x)
x <- gsub("^[.]+", "0.", x)
# <=0.2560.512 should be 0.512
x <- gsub('.*[.].*[.]', '0.', x)
x <- gsub(".*[.].*[.]", "0.", x)
# remove ending .0
x <- gsub('[.]+0$', '', x)
x <- gsub("[.]+0$", "", x)
# remove all after last digit
x <- gsub('[^0-9]+$', '', x)
x <- gsub("[^0-9]+$", "", x)
# keep only one zero before dot
x <- gsub("0+[.]", "0.", x)
# starting 00 is probably 0.0 if there's no dot yet
x[!x %like% "[.]"] <- gsub("^00", "0.0", x[!x %like% "[.]"])
# remove last zeroes
x <- gsub('([.].?)0+$', '\\1', x)
x <- gsub('(.*[.])0+$', '\\10', x)
x <- gsub("([.].?)0+$", "\\1", x)
x <- gsub("(.*[.])0+$", "\\10", x)
# remove ending .0 again
x[x %like% "[.]"] <- gsub('0+$', '', x[x %like% "[.]"])
x[x %like% "[.]"] <- gsub("0+$", "", x[x %like% "[.]"])
# force to be character
x <- as.character(x)
# trim it
@ -190,23 +190,23 @@ as.mic <- function(x, na.rm = FALSE) {
"<1024", "<=1024", "1024", ">=1024", ">1024",
"1025")
na_before <- x[is.na(x) | x == ''] %>% length()
na_before <- x[is.na(x) | x == ""] %>% length()
x[!x %in% lvls] <- NA
na_after <- x[is.na(x) | x == ''] %>% length()
na_after <- x[is.na(x) | x == ""] %>% length()
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid MICs: ',
"%) that were invalid MICs: ",
list_missing, call. = FALSE)
}
structure(.Data = factor(x, levels = lvls, ordered = TRUE),
class = c('mic', 'ordered', 'factor'))
class = c("mic", "ordered", "factor"))
}
}
@ -214,36 +214,36 @@ as.mic <- function(x, na.rm = FALSE) {
#' @export
#' @importFrom dplyr %>%
is.mic <- function(x) {
class(x) %>% identical(c('mic', 'ordered', 'factor'))
class(x) %>% identical(c("mic", "ordered", "factor"))
}
#' @exportMethod as.double.mic
#' @export
#' @noRd
as.double.mic <- function(x, ...) {
as.double(gsub('(<|=|>)+', '', as.character(x)))
as.double(gsub("(<|=|>)+", "", as.character(x)))
}
#' @exportMethod as.integer.mic
#' @export
#' @noRd
as.integer.mic <- function(x, ...) {
as.integer(gsub('(<|=|>)+', '', as.character(x)))
as.integer(gsub("(<|=|>)+", "", as.character(x)))
}
#' @exportMethod as.numeric.mic
#' @export
#' @noRd
as.numeric.mic <- function(x, ...) {
as.numeric(gsub('(<|=|>)+', '', as.character(x)))
as.numeric(gsub("(<|=|>)+", "", as.character(x)))
}
#' @exportMethod droplevels.mic
#' @export
#' @noRd
droplevels.mic <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...) {
droplevels.mic <- function(x, exclude = ifelse(anyNA(levels(x)), NULL, NA), ...) {
x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c('mic', 'ordered', 'factor')
class(x) <- c("mic", "ordered", "factor")
x
}
@ -266,7 +266,7 @@ summary.mic <- function(object, ...) {
x <- x[!is.na(x)]
n <- x %>% length()
c(
"Class" = 'mic',
"Class" = "mic",
"<NA>" = n_total - n,
"Min." = sort(x)[1] %>% as.character(),
"Max." = sort(x)[n] %>% as.character()
@ -278,9 +278,9 @@ summary.mic <- function(object, ...) {
#' @importFrom graphics barplot axis par
#' @noRd
plot.mic <- function(x,
main = paste('MIC values of', deparse(substitute(x))),
ylab = 'Frequency',
xlab = 'MIC value',
main = paste("MIC values of", deparse(substitute(x))),
ylab = "Frequency",
xlab = "MIC value",
axes = FALSE,
...) {
barplot(table(droplevels.factor(x)),
@ -297,9 +297,9 @@ plot.mic <- function(x,
#' @importFrom graphics barplot axis
#' @noRd
barplot.mic <- function(height,
main = paste('MIC values of', deparse(substitute(height))),
ylab = 'Frequency',
xlab = 'MIC value',
main = paste("MIC values of", deparse(substitute(height))),
ylab = "Frequency",
xlab = "MIC value",
axes = FALSE,
...) {
barplot(table(droplevels.factor(height)),

4
R/misc.R
View File

@ -67,7 +67,7 @@ search_type_in_df <- function(x, type) {
call. = FALSE)
}
} else {
for (i in 1:ncol(x)) {
for (i in seq_len(ncol(x))) {
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
found <- colnames(x)[i]
break
@ -141,7 +141,7 @@ getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (minimum > maximum) {
minimum <- maximum
}
max_places <- max(unlist(lapply(strsplit(sub('0+$', '',
max_places <- max(unlist(lapply(strsplit(sub("0+$", "",
as.character(x * 100)), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0))), na.rm = TRUE)
max(min(max_places,

194
R/mo.R
View File

@ -197,7 +197,7 @@ as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain = TRUE,
& isFALSE(Becker)
& isFALSE(Lancefield)
& !is.null(reference_df)
& all(x %in% reference_df[,1][[1]])) {
& all(x %in% reference_df[, 1][[1]])) {
# has valid own reference_df
# (data.table not faster here)
@ -308,13 +308,13 @@ exec_as.mo <- function(x,
# support tidyverse selection like: df %>% select(colA, colB)
# paste these columns together
x_vector <- vector("character", NROW(x))
for (i in 1:NROW(x)) {
x_vector[i] <- paste(pull(x[i,], 1), pull(x[i,], 2), sep = " ")
for (i in seq_len(NROW(x))) {
x_vector[i] <- paste(pull(x[i, ], 1), pull(x[i, ], 2), sep = " ")
}
x <- x_vector
} else {
if (NCOL(x) > 2) {
stop('`x` can be 2 columns at most', call. = FALSE)
stop("`x` can be 2 columns at most", call. = FALSE)
}
x[is.null(x)] <- NA
@ -544,7 +544,7 @@ exec_as.mo <- function(x,
# 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".
constants <- paste(letters[!letters %in% c("a", "e", "i", "o", "u")], collapse = "")
#x[nchar(x_backup_without_spp) > 10] <- gsub("([a-z])([a-z])", paste0("\\1[", constants, "]?\\2"), x[nchar(x_backup_without_spp) > 10])
x[nchar(x_backup_without_spp) > 10] <- gsub("[+]", paste0("+[", constants, "]?"), x[nchar(x_backup_without_spp) > 10])
}
x <- strip_whitespace(x, dyslexia_mode)
@ -558,11 +558,11 @@ exec_as.mo <- function(x,
x_withspaces <- gsub("[ .]+", ".* ", x)
x <- gsub("[ .]+", ".*", x)
# add start en stop regex
x <- paste0('^', x, '$')
x <- paste0("^", x, "$")
x_withspaces_start_only <- paste0('^', x_withspaces)
x_withspaces_end_only <- paste0(x_withspaces, '$')
x_withspaces_start_end <- paste0('^', x_withspaces, '$')
x_withspaces_start_only <- paste0("^", x_withspaces)
x_withspaces_end_only <- paste0(x_withspaces, "$")
x_withspaces_start_end <- paste0("^", x_withspaces, "$")
if (isTRUE(debug)) {
cat(paste0('x "', x, '"\n'))
@ -579,7 +579,7 @@ exec_as.mo <- function(x,
progress <- progress_estimated(n = length(x), min_time = 3)
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
progress$tick()$print()
@ -681,23 +681,6 @@ exec_as.mo <- function(x,
# check for very small input, but ignore the O antigens of E. coli
if (nchar(gsub("[^a-zA-Z]", "", x_trimmed[i])) < 3
& !x_backup_without_spp[i] %like_case% "[Oo]?(26|103|104|104|111|121|145|157)") {
# check if search term was like "A. species", then return first genus found with ^A
# if (x_backup[i] %like% "[a-z]+ species" | x_backup[i] %like% "[a-z] spp[.]?") {
# # get mo code of first hit
# found <- microorganismsDT[fullname %like% x_withspaces_start_only[i], mo]
# if (length(found) > 0) {
# mo_code <- found[1L] %>% strsplit("_") %>% unlist() %>% .[1:2] %>% paste(collapse = "_")
# found <- microorganismsDT[mo == mo_code, ..property][[1]]
# # return first genus that begins with x_trimmed, e.g. when "E. spp."
# if (length(found) > 0) {
# x[i] <- found[1L]
# if (initial_search == TRUE) {
# set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
# }
# next
# }
# }
# }
# fewer than 3 chars and not looked for species, add as failure
x[i] <- microorganismsDT[mo == "UNKNOWN", ..property][[1]]
if (initial_search == TRUE) {
@ -715,17 +698,17 @@ exec_as.mo <- function(x,
# translate known trivial abbreviations to genus + species ----
if (!is.na(x_trimmed[i])) {
if (toupper(x_backup_without_spp[i]) %in% c('MRSA', 'MSSA', 'VISA', 'VRSA')
if (toupper(x_backup_without_spp[i]) %in% c("MRSA", "MSSA", "VISA", "VRSA")
| x_backup_without_spp[i] %like_case% " (mrsa|mssa|visa|vrsa) ") {
x[i] <- microorganismsDT[mo == 'B_STPHY_AURS', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STPHY_AURS", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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[i] <- microorganismsDT[mo == 'B_STPHY_EPDR', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STPHY_EPDR", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -733,8 +716,8 @@ exec_as.mo <- function(x,
}
if (toupper(x_backup_without_spp[i]) == "VRE"
| x_backup_without_spp[i] %like_case% " vre "
| x_backup_without_spp[i] %like_case% '(enterococci|enterokok|enterococo)[a-z]*?$') {
x[i] <- microorganismsDT[mo == 'B_ENTRC', ..property][[1]][1L]
| x_backup_without_spp[i] %like_case% "(enterococci|enterokok|enterococo)[a-z]*?$") {
x[i] <- microorganismsDT[mo == "B_ENTRC", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -755,39 +738,39 @@ 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")
# 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[i] <- microorganismsDT[mo == 'B_ESCHR_COLI', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_ESCHR_COLI", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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 ") {
# multi resistant P. aeruginosa
x[i] <- microorganismsDT[mo == 'B_PSDMN_ARGN', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_PSDMN_ARGN", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (toupper(x_backup_without_spp[i]) == 'CRSM') {
if (toupper(x_backup_without_spp[i]) == "CRSM") {
# co-trim resistant S. maltophilia
x[i] <- microorganismsDT[mo == 'B_STNTR_MLTP', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STNTR_MLTP", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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) ") {
# peni I, peni R, vanco I, vanco R: S. pneumoniae
x[i] <- microorganismsDT[mo == 'B_STRPT_PNMN', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STRPT_PNMN", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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)
x[i] <- microorganismsDT[mo == toupper(gsub("g([abcdfghk])s", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L]
if (initial_search == TRUE) {
@ -795,7 +778,7 @@ exec_as.mo <- function(x,
}
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"
x[i] <- microorganismsDT[mo == toupper(gsub(".*(streptococ|streptokok|estreptococ).* ([abcdfghk])$", "B_STRPT_GRP\\2", x_backup_without_spp[i])), ..property][[1]][1L]
if (initial_search == TRUE) {
@ -803,7 +786,7 @@ exec_as.mo <- function(x,
}
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"
x[i] <- microorganismsDT[mo == toupper(gsub(".*group ([abcdfghk]) (streptococ|streptokok|estreptococ).*", "B_STRPT_GRP\\1", x_backup_without_spp[i])), ..property][[1]][1L]
if (initial_search == TRUE) {
@ -811,79 +794,79 @@ exec_as.mo <- function(x,
}
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
x[i] <- microorganismsDT[mo == 'B_STRPT_HAEM', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STRPT_HAEM", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese) ----
if (x_backup_without_spp[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]?$') {
if (x_backup_without_spp[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]?$") {
# coerce S. coagulase negative
x[i] <- microorganismsDT[mo == 'B_STPHY_CONS', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_backup_without_spp[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]?$') {
if (x_backup_without_spp[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]?$") {
# coerce S. coagulase positive
x[i] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
# streptococcal groups: milleri and viridans
if (x_trimmed[i] %like_case% 'strepto.* milleri'
| x_backup_without_spp[i] %like_case% 'strepto.* milleri'
| x_backup_without_spp[i] %like_case% 'mgs[^a-z]?$') {
if (x_trimmed[i] %like_case% "strepto.* milleri"
| x_backup_without_spp[i] %like_case% "strepto.* milleri"
| x_backup_without_spp[i] %like_case% "mgs[^a-z]?$") {
# Milleri Group Streptococcus (MGS)
x[i] <- microorganismsDT[mo == 'B_STRPT_MILL', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STRPT_MILL", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_trimmed[i] %like_case% 'strepto.* viridans'
| x_backup_without_spp[i] %like_case% 'strepto.* viridans'
| x_backup_without_spp[i] %like_case% 'vgs[^a-z]?$') {
if (x_trimmed[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% "strepto.* viridans"
| x_backup_without_spp[i] %like_case% "vgs[^a-z]?$") {
# Viridans Group Streptococcus (VGS)
x[i] <- microorganismsDT[mo == 'B_STRPT_VIRI', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STRPT_VIRI", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_backup_without_spp[i] %like_case% 'gram[ -]?neg.*'
| x_backup_without_spp[i] %like_case% 'negatie?[vf]'
| x_trimmed[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_trimmed[i] %like_case% "gram[ -]?neg.*") {
# coerce Gram negatives
x[i] <- microorganismsDT[mo == 'B_GRAMN', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_GRAMN", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
}
if (x_backup_without_spp[i] %like_case% 'gram[ -]?pos.*'
| x_backup_without_spp[i] %like_case% 'positie?[vf]'
| x_trimmed[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_trimmed[i] %like_case% "gram[ -]?pos.*") {
# coerce Gram positives
x[i] <- microorganismsDT[mo == 'B_GRAMP', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_GRAMP", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
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 Gram positives
x[i] <- microorganismsDT[mo == 'B_MYCBC', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_MYCBC", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -893,14 +876,14 @@ exec_as.mo <- function(x,
if (x_backup_without_spp[i] %like_case% "salmonella [a-z]+ ?.*") {
if (x_backup_without_spp[i] %like_case% "salmonella group") {
# Salmonella Group A to Z, just return S. species for now
x[i] <- microorganismsDT[mo == 'B_SLMNL', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_SLMNL", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
next
} else if (grepl("[sS]almonella [A-Z][a-z]+ ?.*", x_backup[i], ignore.case = FALSE)) {
# Salmonella with capital letter species like "Salmonella Goettingen" - they're all S. enterica
x[i] <- microorganismsDT[mo == 'B_SLMNL_ENTR', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_SLMNL_ENTR", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -915,7 +898,7 @@ exec_as.mo <- function(x,
# trivial names known to the field:
if ("meningococcus" %like_case% x_trimmed[i]) {
# coerce Neisseria meningitidis
x[i] <- microorganismsDT[mo == 'B_NESSR_MNNG', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_NESSR_MNNG", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -923,7 +906,7 @@ exec_as.mo <- function(x,
}
if ("gonococcus" %like_case% x_trimmed[i]) {
# coerce Neisseria gonorrhoeae
x[i] <- microorganismsDT[mo == 'B_NESSR_GNRR', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_NESSR_GNRR", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -931,7 +914,7 @@ exec_as.mo <- function(x,
}
if ("pneumococcus" %like_case% x_trimmed[i]) {
# coerce Streptococcus penumoniae
x[i] <- microorganismsDT[mo == 'B_STRPT_PNMN', ..property][[1]][1L]
x[i] <- microorganismsDT[mo == "B_STRPT_PNMN", ..property][[1]][1L]
if (initial_search == TRUE) {
set_mo_history(x_backup[i], get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
}
@ -1030,7 +1013,7 @@ exec_as.mo <- function(x,
x_length <- nchar(g.x_backup_without_spp)
x_split <- paste0("^",
g.x_backup_without_spp %>% substr(1, x_length / 2),
'.* ',
".* ",
g.x_backup_without_spp %>% substr((x_length / 2) + 1, x_length))
found <- data_to_check[fullname_lower %like_case% x_split, ..property][[1]]
if (length(found) > 0) {
@ -1050,12 +1033,12 @@ exec_as.mo <- function(x,
# look for old taxonomic names ----
# wait until prevalence == 2 to run the old taxonomic results on both prevalence == 1 and prevalence == 2
found <- data.old_to_check[fullname_lower == tolower(a.x_backup)
| fullname_lower %like_case% d.x_withspaces_start_end,]
| fullname_lower %like_case% d.x_withspaces_start_end, ]
if (NROW(found) > 0) {
col_id_new <- found[1, col_id_new]
# when property is "ref" (which is the case in mo_ref, mo_authors and mo_year), return the old value, so:
# mo_ref("Chlamydia psittaci") = "Page, 1968" (with warning)
# mo_ref("Chlamydophila psittaci") = "Everett et al., 1999"
# mo_ref() of "Chlamydia psittaci" will be "Page, 1968" (with warning)
# mo_ref() of "Chlamydophila psittaci" will be "Everett et al., 1999"
if (property == "ref") {
x[i] <- found[1, ref]
} else {
@ -1067,9 +1050,7 @@ exec_as.mo <- function(x,
ref_old = found[1, ref],
ref_new = microorganismsDT[col_id == found[1, col_id_new], ref],
mo = microorganismsDT[col_id == found[1, col_id_new], mo])
# if (initial_search == TRUE) {
# set_mo_history(a.x_backup, get_mo_code(x[i], property), 0, force = force_mo_history, disable = disable_mo_history)
# }
# no set history on renames
return(x[i])
}
@ -1119,9 +1100,7 @@ exec_as.mo <- function(x,
format_uncertainty_as_df(uncertainty_level = now_checks_for_uncertainty_level,
input = a.x_backup,
result_mo = microorganismsDT[col_id == found[1, col_id_new], mo]))
# if (initial_search == TRUE) {
# set_mo_history(a.x_backup, get_mo_code(x, property), 1, force = force_mo_history, disable = disable_mo_history)
# }
# no set history on renames
return(x)
}
@ -1243,11 +1222,11 @@ exec_as.mo <- function(x,
}
x_strip <- a.x_backup %>% strsplit(" ") %>% unlist()
if (length(x_strip) > 1) {
for (i in 1:(length(x_strip) - 1)) {
for (i in seq_len(length(x_strip) - 1)) {
lastword <- x_strip[length(x_strip) - i + 1]
lastword_half <- substr(lastword, 1, as.integer(nchar(lastword) / 2))
# remove last half of the second term
x_strip_collapsed <- paste(c(x_strip[1:(length(x_strip) - i)], lastword_half), collapse = " ")
x_strip_collapsed <- paste(c(x_strip[seq_len(length(x_strip) - i)], lastword_half), collapse = " ")
if (nchar(x_strip_collapsed) >= 4 & nchar(lastword_half) > 2) {
if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'")
@ -1278,8 +1257,8 @@ exec_as.mo <- function(x,
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) {
for (i in 1:(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ")
for (i in seq_len(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ")
if (nchar(x_strip_collapsed) >= 6) {
if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'")
@ -1412,8 +1391,8 @@ exec_as.mo <- function(x,
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) {
for (i in 1:(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[1:(length(x_strip) - i)], collapse = " ")
for (i in seq_len(length(x_strip) - 1)) {
x_strip_collapsed <- paste(x_strip[seq_len(length(x_strip) - i)], collapse = " ")
if (isTRUE(debug)) {
message("Running '", x_strip_collapsed, "'")
}
@ -1579,7 +1558,7 @@ exec_as.mo <- function(x,
" (covering ", percentage(total_failures / total_n),
") could not be coerced and ", plural[3], " considered 'unknown'")
if (n_distinct(failures) <= 10) {
msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ', '))
msg <- paste0(msg, ": ", paste('"', unique(failures), '"', sep = "", collapse = ", "))
}
msg <- paste0(msg, ". Use mo_failures() to review ", plural[2], ". Edit the `allow_uncertain` parameter if needed (see ?as.mo).")
warning(red(msg),
@ -1639,35 +1618,35 @@ exec_as.mo <- function(x,
immediate. = TRUE)
}
x[x %in% CoNS] <- microorganismsDT[mo == 'B_STPHY_CONS', ..property][[1]][1L]
x[x %in% CoPS] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L]
x[x %in% CoNS] <- microorganismsDT[mo == "B_STPHY_CONS", ..property][[1]][1L]
x[x %in% CoPS] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
if (Becker == "all") {
x[x %in% microorganismsDT[mo %like_case% '^B_STPHY_AURS', ..property][[1]]] <- microorganismsDT[mo == 'B_STPHY_COPS', ..property][[1]][1L]
x[x %in% microorganismsDT[mo %like_case% "^B_STPHY_AURS", ..property][[1]]] <- microorganismsDT[mo == "B_STPHY_COPS", ..property][[1]][1L]
}
}
# Lancefield ----
if (Lancefield == TRUE | Lancefield == "all") {
# group A - S. pyogenes
x[x == microorganismsDT[mo == 'B_STRPT_PYGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPA', ..property][[1]][1L]
x[x == microorganismsDT[mo == "B_STRPT_PYGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPA", ..property][[1]][1L]
# group B - S. agalactiae
x[x == microorganismsDT[mo == 'B_STRPT_AGLC', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPB', ..property][[1]][1L]
x[x == microorganismsDT[mo == "B_STRPT_AGLC", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPB", ..property][[1]][1L]
# group C
S_groupC <- microorganismsDT %>% filter(genus == "Streptococcus",
species %in% c("equisimilis", "equi",
"zooepidemicus", "dysgalactiae")) %>%
pull(property)
x[x %in% S_groupC] <- microorganismsDT[mo == 'B_STRPT_GRPC', ..property][[1]][1L]
x[x %in% S_groupC] <- microorganismsDT[mo == "B_STRPT_GRPC", ..property][[1]][1L]
if (Lancefield == "all") {
# all Enterococci
x[x %like% "^(Enterococcus|B_ENTRC)"] <- microorganismsDT[mo == 'B_STRPT_GRPD', ..property][[1]][1L]
x[x %like% "^(Enterococcus|B_ENTRC)"] <- microorganismsDT[mo == "B_STRPT_GRPD", ..property][[1]][1L]
}
# group F - S. anginosus
x[x == microorganismsDT[mo == 'B_STRPT_ANGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPF', ..property][[1]][1L]
x[x == microorganismsDT[mo == "B_STRPT_ANGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPF", ..property][[1]][1L]
# group H - S. sanguinis
x[x == microorganismsDT[mo == 'B_STRPT_SNGN', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPH', ..property][[1]][1L]
x[x == microorganismsDT[mo == "B_STRPT_SNGN", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPH", ..property][[1]][1L]
# group K - S. salivarius
x[x == microorganismsDT[mo == 'B_STRPT_SLVR', ..property][[1]][1L]] <- microorganismsDT[mo == 'B_STRPT_GRPK', ..property][[1]][1L]
x[x == microorganismsDT[mo == "B_STRPT_SLVR", ..property][[1]][1L]] <- microorganismsDT[mo == "B_STRPT_GRPK", ..property][[1]][1L]
}
# Wrap up ----------------------------------------------------------------
@ -1886,7 +1865,7 @@ print.mo_uncertainties <- function(x, ...) {
", 3 = ", red("very uncertain"), ")\n"))
msg <- ""
for (i in 1:nrow(x)) {
for (i in seq_len(nrow(x))) {
if (x[i, "uncertainty"] == 1) {
colour1 <- green
colour2 <- function(...) bgGreen(white(...))
@ -1929,7 +1908,7 @@ print.mo_renamed <- function(x, ...) {
if (NROW(x) == 0) {
return(invisible())
}
for (i in 1:nrow(x)) {
for (i in seq_len(nrow(x))) {
message(blue(paste0("NOTE: ",
italic(x$old_name[i]), ifelse(x$old_ref[i] %in% c("", NA), "",
paste0(" (", gsub("et al.", italic("et al."), x$old_ref[i]), ")")),
@ -1955,15 +1934,10 @@ unregex <- function(x) {
}
get_mo_code <- function(x, property) {
# don't use right now
# return(NULL)
if (property == "mo") {
unique(x)
} else {
microorganismsDT[get(property) == x, "mo"][[1]]
# which is ~2.5 times faster than:
# AMR::microorganisms[base::which(AMR::microorganisms[, property] %in% x),]$mo
}
}

16
R/mo_history.R
View File

@ -43,11 +43,11 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA
}
x <- toupper(df$x)
mo <- df$mo
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
# save package version too, as both the as.mo() algorithm and the reference data set may change
if (NROW(mo_hist[base::which(mo_hist$x == x[i] &
mo_hist$uncertainty_level >= uncertainty_level &
mo_hist$package_version == utils::packageVersion("AMR")),]) == 0) {
mo_hist$package_version == utils::packageVersion("AMR")), ]) == 0) {
# # Not using the file system:
# tryCatch(options(mo_remembered_results = rbind(mo_hist,
# data.frame(
@ -73,7 +73,9 @@ set_mo_history <- function(x, mo, uncertainty_level, force = FALSE, disable = FA
stringsAsFactors = FALSE)),
row.names = FALSE,
file = mo_history_file()),
error = function(e) { warning_new_write <- FALSE; base::invisible()})
error = function(e) {
warning_new_write <- FALSE; base::invisible()
})
}
}
}
@ -87,7 +89,7 @@ get_mo_history <- function(x, uncertainty_level, force = FALSE, disable = FALSE)
if (isTRUE(disable)) {
return(to_class_mo(NA))
}
history <- read_mo_history(uncertainty_level = uncertainty_level, force = force)
if (base::is.null(history)) {
result <- NA
@ -105,7 +107,7 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F
if (isTRUE(disable)) {
return(NULL)
}
if ((!base::interactive() & force == FALSE)) {
return(NULL)
}
@ -123,7 +125,7 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F
# Below: filter on current package version.
# Even current fullnames may be replaced by new taxonomic names, so new versions of
# the Catalogue of Life must not lead to data corruption.
if (unfiltered == FALSE) {
history <- history %>%
filter(package_version == as.character(utils::packageVersion("AMR")),
@ -133,7 +135,7 @@ read_mo_history <- function(uncertainty_level = 2, force = FALSE, unfiltered = F
arrange(desc(uncertainty_level)) %>%
distinct(x, mo, .keep_all = TRUE)
}
if (nrow(history) == 0) {
NULL
} else {

6
R/mo_property.R
View File

@ -158,8 +158,8 @@ mo_shortname <- function(x, language = get_locale(), ...) {
shortnames <- paste0(substr(mo_genus(x.mo, language = NULL), 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
# exceptions for Staphylococci
shortnames[shortnames == "S. coagulase-negative" ] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive" ] <- "CoPS"
shortnames[shortnames == "S. coagulase-negative"] <- "CoNS"
shortnames[shortnames == "S. coagulase-positive"] <- "CoPS"
# exceptions for Streptococci: Streptococcus Group A -> GAS
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"]), "S")
@ -384,7 +384,7 @@ mo_url <- function(x, open = FALSE, ...) {
#' @rdname mo_property
#' @importFrom data.table data.table as.data.table setkey
#' @export
mo_property <- function(x, property = 'fullname', language = get_locale(), ...) {
mo_property <- function(x, property = "fullname", language = get_locale(), ...) {
if (length(property) != 1L) {
stop("'property' must be of length 1.")
}

10
R/mo_source.R
View File

@ -99,7 +99,7 @@
#' @inheritSection AMR Read more on our website!
set_mo_source <- function(path) {
file_location <- path.expand('~/mo_source.rds')
file_location <- path.expand("~/mo_source.rds")
if (!is.character(path) | length(path) > 1) {
stop("`path` must be a character of length 1.")
@ -119,17 +119,17 @@ set_mo_source <- function(path) {
stop("File not found: ", path)
}
if (path %like% '[.]rds$') {
if (path %like% "[.]rds$") {
df <- readRDS(path)
} else if (path %like% '[.]xlsx?$') {
} else if (path %like% "[.]xlsx?$") {
# is Excel file (old or new)
if (!"readxl" %in% utils::installed.packages()) {
stop("Install the 'readxl' package first.")
}
df <- readxl::read_excel(path)
} else if (path %like% '[.]tsv$') {
} else if (path %like% "[.]tsv$") {
df <- utils::read.table(header = TRUE, sep = "\t", stringsAsFactors = FALSE)
} else {
@ -196,7 +196,7 @@ get_mo_source <- function() {
# set updated source
set_mo_source(getOption("mo_source"))
}
file_location <- path.expand('~/mo_source.rds')
file_location <- path.expand("~/mo_source.rds")
readRDS(file_location)
}
}

5
R/read.4d.R
View File

@ -154,7 +154,7 @@ read.4D <- function(file,
if (info == TRUE) {
message("OK\nSetting original column names as label... ", appendLF = FALSE)
}
for (i in 1:ncol(data_4D)) {
for (i in seq_len(ncol(data_4D))) {
if (!is.na(colnames.bak[i])) {
attr(data_4D[, i], "label") <- colnames.bak[i]
}
@ -163,7 +163,7 @@ read.4D <- function(file,
if (info == TRUE) {
message("OK\nSetting query as label to data.frame... ", appendLF = FALSE)
}
qry <- readLines(con <- file(file, open="r"))[1]
qry <- readLines(con <- file(file, open = "r"))[1]
close(con)
attr(data_4D, "label") <- qry
@ -173,4 +173,3 @@ read.4D <- function(file,
data_4D
}

46
R/resistance_predict.R
View File

@ -120,7 +120,7 @@ resistance_predict <- function(x,
...) {
if (nrow(x) == 0) {
stop('This table does not contain any observations.')
stop("This table does not contain any observations.")
}
if (is.null(model)) {
@ -128,17 +128,17 @@ resistance_predict <- function(x,
}
if (!col_ab %in% colnames(x)) {
stop('Column ', col_ab, ' not found.')
stop("Column ", col_ab, " not found.")
}
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old parameters
dots.names <- dots %>% names()
if ('tbl' %in% dots.names) {
x <- dots[which(dots.names == 'tbl')]
if ("tbl" %in% dots.names) {
x <- dots[which(dots.names == "tbl")]
}
if ('I_as_R' %in% dots.names) {
if ("I_as_R" %in% dots.names) {
warning("`I_as_R is deprecated - use I_as_S instead.", call. = FALSE)
}
}
@ -152,7 +152,7 @@ resistance_predict <- function(x,
}
if (!col_date %in% colnames(x)) {
stop('Column ', col_date, ' not found.')
stop("Column ", col_date, " not found.")
}
if (n_groups(x) > 1) {
@ -161,10 +161,10 @@ resistance_predict <- function(x,
}
year <- function(x) {
if (all(grepl('^[0-9]{4}$', x))) {
if (all(grepl("^[0-9]{4}$", x))) {
x
} else {
as.integer(format(as.Date(x), '%Y'))
as.integer(format(as.Date(x), "%Y"))
}
}
@ -181,8 +181,8 @@ resistance_predict <- function(x,
}
df <- df %>%
filter_at(col_ab, all_vars(!is.na(.))) %>%
mutate(year = pull(., col_date) %>% year()) %>%
group_by_at(c('year', col_ab)) %>%
mutate(year = year(pull(., col_date))) %>%
group_by_at(c("year", col_ab)) %>%
summarise(n())
if (df %>% pull(col_ab) %>% n_distinct(na.rm = TRUE) < 2) {
@ -191,7 +191,7 @@ resistance_predict <- function(x,
call. = FALSE)
}
colnames(df) <- c('year', 'antibiotic', 'observations')
colnames(df) <- c("year", "antibiotic", "observations")
df <- df %>%
filter(!is.na(antibiotic)) %>%
tidyr::spread(antibiotic, observations, fill = 0) %>%
@ -202,7 +202,7 @@ resistance_predict <- function(x,
as.matrix()
if (NROW(df) == 0) {
stop('There are no observations.')
stop("There are no observations.")
}
year_lowest <- min(df$year)
@ -217,12 +217,12 @@ resistance_predict <- function(x,
years <- list(year = seq(from = year_min, to = year_max, by = year_every))
if (model %in% c('binomial', 'binom', 'logit')) {
if (model %in% c("binomial", "binom", "logit")) {
model <- "binomial"
model_lm <- with(df, glm(df_matrix ~ year, family = binomial))
if (info == TRUE) {
cat('\nLogistic regression model (logit) with binomial distribution')
cat('\n------------------------------------------------------------\n')
cat("\nLogistic regression model (logit) with binomial distribution")
cat("\n------------------------------------------------------------\n")
print(summary(model_lm))
}
@ -230,12 +230,12 @@ resistance_predict <- function(x,
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c('loglin', 'poisson')) {
} else if (model %in% c("loglin", "poisson")) {
model <- "poisson"
model_lm <- with(df, glm(R ~ year, family = poisson))
if (info == TRUE) {
cat('\nLog-linear regression model (loglin) with poisson distribution')
cat('\n--------------------------------------------------------------\n')
cat("\nLog-linear regression model (loglin) with poisson distribution")
cat("\n--------------------------------------------------------------\n")
print(summary(model_lm))
}
@ -243,12 +243,12 @@ resistance_predict <- function(x,
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c('lin', 'linear')) {
} else if (model %in% c("lin", "linear")) {
model <- "linear"
model_lm <- with(df, lm((R / (R + S)) ~ year))
if (info == TRUE) {
cat('\nLinear regression model')
cat('\n-----------------------\n')
cat("\nLinear regression model")
cat("\n-----------------------\n")
print(summary(model_lm))
}
@ -257,7 +257,7 @@ resistance_predict <- function(x,
se <- predictmodel$se.fit
} else {
stop('No valid model selected. See ?resistance_predict.')
stop("No valid model selected. See ?resistance_predict.")
}
# prepare the output dataframe
@ -268,7 +268,7 @@ resistance_predict <- function(x,
mutate(se_min = value - se,
se_max = value + se)
if (model == 'poisson') {
if (model == "poisson") {
df_prediction <- df_prediction %>%
mutate(value = value %>%
format(scientific = FALSE) %>%

71
R/rsi.R
View File

@ -100,20 +100,17 @@ as.rsi.default <- function(x, ...) {
if (is.rsi(x)) {
x
} else if (identical(levels(x), c("S", "I", "R"))) {
structure(x, class = c('rsi', 'ordered', 'factor'))
structure(x, class = c("rsi", "ordered", "factor"))
} else {
# if (input_resembles_mic(x) > 0.5) {
# warning("`as.rsi` is intended to clean antimicrobial interpretations - not to interpret MIC values.", call. = FALSE)
# }
x <- x %>% unlist()
x.bak <- x
na_before <- x[is.na(x) | x == ''] %>% length()
na_before <- x[is.na(x) | x == ""] %>% length()
# remove all spaces
x <- gsub(' +', '', x)
x <- gsub(" +", "", x)
# remove all MIC-like values: numbers, operators and periods
x <- gsub('[0-9.,;:<=>]+', '', x)
x <- gsub("[0-9.,;:<=>]+", "", x)
# remove everything between brackets, and 'high' and 'low'
x <- gsub("([(].*[)])", "", x)
x <- gsub("(high|low)", "", x, ignore.case = TRUE)
@ -122,29 +119,29 @@ as.rsi.default <- function(x, ...) {
# set to capitals
x <- toupper(x)
# remove all invalid characters
x <- gsub('[^RSI]+', '', x)
x <- gsub("[^RSI]+", "", x)
# in cases of "S;S" keep S, but in case of "S;I" make it NA
x <- gsub('^S+$', 'S', x)
x <- gsub('^I+$', 'I', x)
x <- gsub('^R+$', 'R', x)
x[!x %in% c('S', 'I', 'R')] <- NA
na_after <- x[is.na(x) | x == ''] %>% length()
x <- gsub("^S+$", "S", x)
x <- gsub("^I+$", "I", x)
x <- gsub("^R+$", "R", x)
x[!x %in% c("S", "I", "R")] <- NA
na_after <- x[is.na(x) | x == ""] %>% length()
if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>%
sort()
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
warning(na_after - na_before, ' results truncated (',
list_missing <- paste0('"', list_missing, '"', collapse = ", ")
warning(na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
'%) that were invalid antimicrobial interpretations: ',
"%) that were invalid antimicrobial interpretations: ",
list_missing, call. = FALSE)
}
}
structure(.Data = factor(x, levels = c("S", "I", "R"), ordered = TRUE),
class = c('rsi', 'ordered', 'factor'))
class = c("rsi", "ordered", "factor"))
}
}
@ -226,7 +223,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
lookup_becker <- paste(mo_becker, ab)
lookup_lancefield <- paste(mo_lancefield, ab)
for (i in 1:length(x)) {
for (i in seq_len(length(x))) {
get_record <- trans %>%
filter(lookup %in% c(lookup_mo[i],
lookup_genus[i],
@ -236,7 +233,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
lookup_lancefield[i])) %>%
# be as specific as possible (i.e. prefer species over genus):
arrange(desc(nchar(mo))) %>%
.[1L,]
.[1L, ]
if (NROW(get_record) > 0) {
if (method == "mic") {
@ -254,7 +251,7 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
}
}
structure(.Data = factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE),
class = c('rsi', 'ordered', 'factor'))
class = c("rsi", "ordered", "factor"))
}
#' @rdname as.rsi
@ -280,7 +277,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# transform all MICs
ab_cols <- colnames(x)[sapply(x, is.mic)]
if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) {
for (i in seq_len(length(ab_cols))) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
next
@ -297,7 +294,7 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
# transform all disks
ab_cols <- colnames(x)[sapply(x, is.disk)]
if (length(ab_cols) > 0) {
for (i in 1:length(ab_cols)) {
for (i in seq_len(length(ab_cols))) {
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
message(red(paste0("Unknown drug: `", bold(ab_cols[i]), "`. Rename this column to a drug name or code, and check the output with as.ab().")))
next
@ -319,14 +316,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
#' @export
is.rsi <- function(x) {
identical(class(x),
c('rsi', 'ordered', 'factor'))
c("rsi", "ordered", "factor"))
}
#' @rdname as.rsi
#' @export
is.rsi.eligible <- function(x, threshold = 0.05) {
if (NCOL(x) > 1) {
stop('`x` must be a one-dimensional vector.')
stop("`x` must be a one-dimensional vector.")
}
if (any(c("logical",
"numeric",
@ -363,9 +360,9 @@ print.rsi <- function(x, ...) {
#' @exportMethod droplevels.rsi
#' @export
#' @noRd
droplevels.rsi <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...) {
droplevels.rsi <- function(x, exclude = if (anyNA(levels(x))) NULL else NA, ...) {
x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c('rsi', 'ordered', 'factor')
class(x) <- c("rsi", "ordered", "factor")
x
}
@ -375,7 +372,7 @@ droplevels.rsi <- function(x, exclude = if(anyNA(levels(x))) NULL else NA, ...)
summary.rsi <- function(object, ...) {
x <- object
c(
"Class" = 'rsi',
"Class" = "rsi",
"<NA>" = sum(is.na(x)),
"Sum S" = sum(x == "S", na.rm = TRUE),
"Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE),
@ -392,9 +389,9 @@ summary.rsi <- function(object, ...) {
plot.rsi <- function(x,
lwd = 2,
ylim = NULL,
ylab = 'Percentage',
xlab = 'Antimicrobial Interpretation',
main = paste('Susceptibility Analysis of', deparse(substitute(x))),
ylab = "Percentage",
xlab = "Antimicrobial Interpretation",
main = paste("Susceptibility Analysis of", deparse(substitute(x))),
axes = FALSE,
...) {
suppressWarnings(
@ -416,7 +413,7 @@ plot.rsi <- function(x,
data <- rbind(data, data.frame(x = "R", n = 0, s = 0))
}
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE)
data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE)
ymax <- if_else(max(data$s) > 95, 105, 100)
@ -436,7 +433,7 @@ plot.rsi <- function(x,
text(x = data$x,
y = data$s + 4,
labels = paste0(data$s, '% (n = ', data$n, ')'))
labels = paste0(data$s, "% (n = ", data$n, ")"))
}
@ -446,10 +443,10 @@ plot.rsi <- function(x,
#' @importFrom graphics barplot axis par
#' @noRd
barplot.rsi <- function(height,
col = c('green3', 'orange2', 'red3'),
xlab = ifelse(beside, 'Antimicrobial Interpretation', ''),
main = paste('Susceptibility Analysis of', deparse(substitute(height))),
ylab = 'Frequency',
col = c("green3", "orange2", "red3"),
xlab = ifelse(beside, "Antimicrobial Interpretation", ""),
main = paste("Susceptibility Analysis of", deparse(substitute(height))),
ylab = "Frequency",
beside = TRUE,
axes = beside,
...) {

24
R/rsi_calc.R
View File

@ -50,13 +50,13 @@ rsi_calc <- function(...,
data_vars <- dots2vars(...)
if (!is.numeric(minimum)) {
stop('`minimum` must be numeric', call. = FALSE)
stop("`minimum` must be numeric", call. = FALSE)
}
if (!is.logical(as_percent)) {
stop('`as_percent` must be logical', call. = FALSE)
stop("`as_percent` must be logical", call. = FALSE)
}
if (!is.logical(only_all_tested)) {
stop('`only_all_tested` must be logical', call. = FALSE)
stop("`only_all_tested` must be logical", call. = FALSE)
}
dots_df <- ...elt(1) # it needs this evaluation
@ -67,8 +67,7 @@ rsi_calc <- function(...,
ndots <- length(dots)
if ("data.frame" %in% class(dots_df)) {
# data.frame passed with other columns, like:
# example_isolates %>% portion_S(amcl, gent)
# data.frame passed with other columns, like: example_isolates %>% portion_S(amcl, gent)
dots <- as.character(dots)
dots <- dots[dots != "."]
if (length(dots) == 0 | all(dots == "df")) {
@ -79,13 +78,10 @@ rsi_calc <- function(...,
x <- dots_df[, dots]
}
} else if (ndots == 1) {
# only 1 variable passed (can also be data.frame), like:
# portion_S(example_isolates$amcl)
# example_isolates$amcl %>% portion_S()
# only 1 variable passed (can also be data.frame), like: portion_S(example_isolates$amcl) and example_isolates$amcl %>% portion_S()
x <- dots_df
} else {
# multiple variables passed without pipe, like:
# portion_S(example_isolates$amcl, example_isolates$gent)
# multiple variables passed without pipe, like: portion_S(example_isolates$amcl, example_isolates$gent)
x <- NULL
try(x <- as.data.frame(dots), silent = TRUE)
if (is.null(x)) {
@ -105,7 +101,7 @@ rsi_calc <- function(...,
if (is.data.frame(x)) {
rsi_integrity_check <- character(0)
for (i in 1:ncol(x)) {
for (i in seq_len(ncol(x))) {
# check integrity of columns: force rsi class
if (!is.rsi(x %>% pull(i))) {
rsi_integrity_check <- c(rsi_integrity_check, x %>% pull(i) %>% as.character())
@ -125,11 +121,13 @@ rsi_calc <- function(...,
FUN = base::min)
numerator <- sum(as.integer(x) %in% as.integer(ab_result), na.rm = TRUE)
denominator <- length(x) - sum(is.na(x))
} else {
# THE NUMBER OF ISOLATES WHERE *ANY* ABx IS S/I/R
other_values <- base::setdiff(c(NA, levels(ab_result)), ab_result)
other_values_filter <- base::apply(x, 1, function(y) { base::all(y %in% other_values) & base::any(is.na(y)) })
other_values_filter <- base::apply(x, 1, function(y) {
base::all(y %in% other_values) & base::any(is.na(y))
})
numerator <- x %>% filter_all(any_vars(. %in% ab_result)) %>% nrow()
denominator <- x %>% filter(!other_values_filter) %>% nrow()
}

8
R/skewness.R
View File

@ -38,25 +38,25 @@ skewness <- function(x, na.rm = FALSE) {
#' @exportMethod skewness.default
#' @rdname skewness
#' @export
skewness.default <- function (x, na.rm = FALSE) {
skewness.default <- function(x, na.rm = FALSE) {
x <- as.vector(x)
if (na.rm == TRUE) {
x <- x[!is.na(x)]
}
n <- length(x)
(base::sum((x - base::mean(x))^3) / n) / (base::sum((x - base::mean(x))^2) / n)^(3/2)
(base::sum((x - base::mean(x))^3) / n) / (base::sum((x - base::mean(x)) ^ 2) / n) ^ (3 / 2)
}
#' @exportMethod skewness.matrix
#' @rdname skewness
#' @export
skewness.matrix <- function (x, na.rm = FALSE) {
skewness.matrix <- function(x, na.rm = FALSE) {
base::apply(x, 2, skewness.default, na.rm = na.rm)
}
#' @exportMethod skewness.data.frame
#' @rdname skewness
#' @export
skewness.data.frame <- function (x, na.rm = FALSE) {
skewness.data.frame <- function(x, na.rm = FALSE) {
base::sapply(x, skewness.default, na.rm = na.rm)
}

2
R/translate.R
View File

@ -134,7 +134,7 @@ translate_AMR <- function(from, language = get_locale(), only_unknown = FALSE) {
return(from)
}
for (i in 1:nrow(df_trans)) {
for (i in seq_len(nrow(df_trans))) {
from <- gsub(x = from,
pattern = df_trans$pattern[i],
replacement = df_trans$replacement[i],

35
R/zzz.R
View File

@ -42,42 +42,9 @@
value = make_trans_tbl(),
envir = asNamespace("AMR"))
# assign(x = "mo_history",
# value = data.frame(x = character(0),
# mo = character(0),
# uncertainty_level = integer(0),
# package_v = character(0),
# stringsAsFactors = FALSE),
# envir = asNamespace("AMR"))
}
.onAttach <- function(...) {
# if (interactive() & !isFALSE(getOption("AMR_survey"))) {
# options(AMR_survey = FALSE)
# console_width <- options()$width - 1
# url <- "https://www.surveymonkey.com/r/AMR_for_R"
# txt <- paste0("Thanks for using the AMR package! ",
# "As researchers, we are interested in how and why you use this package and if there are things you're missing from it. ",
# "Please fill in our 2-minute survey at: ", url, ". ",
# "This message can be turned off with: options(AMR_survey = FALSE)")
#
# # make it honour new lines bases on console width:
# txt <- unlist(strsplit(txt, " "))
# txt_new <- ""
# total_chars <- 0
# for (i in 1:length(txt)) {
# total_chars <- total_chars + nchar(txt[i]) + 1
# if (total_chars > console_width) {
# txt_new <- paste0(txt_new, "\n")
# total_chars <- 0
# }
# txt_new <- paste0(txt_new, txt[i], " ")
# }
# # packageStartupMessage(txt_new)
# }
}
# maybe add survey later: "https://www.surveymonkey.com/r/AMR_for_R"
#' @importFrom data.table as.data.table setkey
make_DT <- function() {