bind_rows

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: AMR
-Version: 1.8.2.9114
+Version: 1.8.2.9116
 Date: 2023-02-10
 Title: Antimicrobial Resistance Data Analysis
 Description: Functions to simplify and standardise antimicrobial resistance (AMR)

NEWS.md

@@ -1,4 +1,4 @@
-# AMR 1.8.2.9114
+# AMR 1.8.2.9116
 
 *(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*
 

R/aa_globals.R

@@ -94,7 +94,9 @@ TAXONOMY_VERSION <- list(
 )
 
 globalVariables(c(
+  ".mo",
   ".rowid",
+  ".syndromic_group",
   "ab",
   "ab_txt",
   "affect_ab_name",
@@ -105,8 +107,9 @@ globalVariables(c(
   "atc_group1",
   "atc_group2",
   "base_ab",
-  "ci_min",
   "ci_max",
+  "ci_min",
+  "clinical_breakpoints",
   "code",
   "cols",
   "count",
@@ -130,14 +133,15 @@ globalVariables(c(
   "language",
   "lookup",
   "method",
-  "mic",
   "mic ",
+  "mic",
   "microorganism",
   "microorganisms",
   "microorganisms.codes",
   "mo",
   "name",
   "new",
+  "numerator",
   "observations",
   "old",
   "old_name",
@@ -149,13 +153,14 @@ globalVariables(c(
   "reference.rule_group",
   "reference.version",
   "rowid",
-  "sir",
-  "clinical_breakpoints",
   "rule_group",
   "rule_name",
   "se_max",
   "se_min",
+  "SI",
+  "sir",
   "species",
+  "syndromic_group",
   "total",
   "txt",
   "type",

R/aa_helper_functions.R

@@ -64,20 +64,26 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
 }
 
 # support where() like tidyverse:
-# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
 where <- function(fn) {
+  # adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
   if (!is.function(fn)) {
-    stop(pm_deparse_var(fn), " is not a valid predicate function.")
+    stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
+  }
+  df <- pm_select_env$.data
+  cols <- pm_select_env$get_colnames()
+  if (is.null(df)) {
+    df <- get_current_data("where", call = FALSE)
+    cols <- colnames(df)
   }
   preds <- unlist(lapply(
-    pm_select_env$.data,
+    df,
     function(x, fn) {
       do.call("fn", list(x))
     },
     fn
   ))
-  if (!is.logical(preds)) stop("`where()` must be used with functions that return `TRUE` or `FALSE`.")
-  data_cols <- pm_select_env$get_colnames()
+  if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
+  data_cols <- cols
   cols <- data_cols[preds]
   which(data_cols %in% cols)
 }
@@ -156,6 +162,20 @@ quick_case_when <- function(...) {
   out
 }
 
+bind_rows2 <- function(..., fill = NA) {
+  # this AMAZING code is from ChatGPT: when I asked for a base R dplyr::bind_rows alternative
+  dfs <- list(...)
+  all_cols <- unique(unlist(lapply(dfs, colnames)))
+  mat_list <- lapply(dfs, function(x) {
+    mat <- matrix(NA, nrow = nrow(x), ncol = length(all_cols))
+    colnames(mat) <- all_cols
+    mat[, colnames(x)] <- as.matrix(x)
+    mat
+  })
+  mat <- do.call(rbind, mat_list)
+  as.data.frame(mat, stringsAsFactors = FALSE)
+}
+
 # No export, no Rd
 addin_insert_in <- function() {
   import_fn("insertText", "rstudioapi")(" %in% ")

R/ab.R

@@ -495,7 +495,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
   # save to package env to save time for next time
   if (isTRUE(initial_search)) {
     AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$x %in% x), , drop = FALSE]
-    AMR_env$ab_previously_coerced <- unique(rbind(AMR_env$ab_previously_coerced,
+    AMR_env$ab_previously_coerced <- unique(bind_rows2(AMR_env$ab_previously_coerced,
       data.frame(
         x = x,
         ab = x_new,

R/antibiogram.R

@@ -404,8 +404,8 @@ antibiogram <- function(x,
       if (i == 1) {
         new_df <- long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits)
       } else {
-        new_df <- bind_rows(new_df,
-                            long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
+        new_df <- bind_rows2(new_df,
+                             long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
       }
     }
     # sort rows

R/av.R

@@ -461,7 +461,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
   # save to package env to save time for next time
   if (isTRUE(initial_search)) {
     AMR_env$av_previously_coerced <- AMR_env$av_previously_coerced[which(!AMR_env$av_previously_coerced$x %in% x), , drop = FALSE]
-    AMR_env$av_previously_coerced <- unique(rbind(AMR_env$av_previously_coerced,
+    AMR_env$av_previously_coerced <- unique(bind_rows2(AMR_env$av_previously_coerced,
       data.frame(
         x = x,
         av = x_new,

R/bug_drug_combinations.R

@@ -124,7 +124,7 @@ bug_drug_combinations <- function(x,
         m <- as.matrix(table(x))
         data.frame(S = m["S", ], I = m["I", ], R = m["R", ], stringsAsFactors = FALSE)
       })
-      merged <- do.call(rbind, pivot)
+      merged <- do.call(bind_rows2, pivot)
       out_group <- data.frame(
         mo = rep(unique_mo[i], NROW(merged)),
         ab = rownames(merged),
@@ -144,14 +144,14 @@ bug_drug_combinations <- function(x,
         }
         out_group <- cbind(group_values, out_group)
       }
-      out <- rbind(out, out_group, stringsAsFactors = FALSE)
+      out <- bind_rows2(out, out_group)
     }
     out
   }
   # based on pm_apply_grouped_function
   apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
     grouped <- pm_split_into_groups(.data, groups, drop)
-    res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
+    res <- do.call(bind_rows2, unname(lapply(grouped, fn, ...)))
     if (any(groups %in% colnames(res))) {
       class(res) <- c("grouped_data", class(res))
       res <- pm_set_groups(res, groups[groups %in% colnames(res)])
@@ -165,7 +165,7 @@ bug_drug_combinations <- function(x,
     out <- run_it(x)
   }
   rownames(out) <- NULL
-  out <- out %>% pm_arrange(mo, ab)
+  out <- out %pm>% pm_arrange(mo, ab)
   out <- as_original_data_class(out, class(x.bak)) # will remove tibble groups
   structure(out, class = c("bug_drug_combinations", ifelse(data_has_groups, "grouped", character(0)), class(out)))
 }

R/custom_antimicrobials.R

@@ -153,7 +153,7 @@ add_custom_antimicrobials <- function(x) {
     # assign new values
     new_df[, col] <- x[, col, drop = TRUE]
   }
-  AMR_env$AB_lookup <- unique(rbind(AMR_env$AB_lookup, new_df))
+  AMR_env$AB_lookup <- unique(bind_rows2(AMR_env$AB_lookup, new_df))
 
   AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% x$ab), , drop = FALSE]
   class(AMR_env$AB_lookup$ab) <- c("ab", "character")

R/custom_microorganisms.R

@@ -279,7 +279,7 @@ add_custom_microorganisms <- function(x) {
   # clear previous coercions
   suppressMessages(mo_reset_session())
 
-  AMR_env$MO_lookup <- unique(rbind(AMR_env$MO_lookup, new_df))
+  AMR_env$MO_lookup <- unique(bind_rows2(AMR_env$MO_lookup, new_df))
   class(AMR_env$MO_lookup$mo) <- c("mo", "character")
   if (nrow(x) <= 3) {
     message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal `microorganisms` data set.")

R/eucast_rules.R

@@ -475,7 +475,7 @@ eucast_rules <- function(x,
     amox$base_ab <- "AMX"
     amox$base_name <- ab_name("AMX", language = NULL)
     # merge and sort
-    ab_enzyme <- rbind(ab_enzyme, ampi, amox)
+    ab_enzyme <- bind_rows2(ab_enzyme, ampi, amox)
     ab_enzyme <- ab_enzyme[order(ab_enzyme$enzyme_name), , drop = FALSE]
 
     for (i in seq_len(nrow(ab_enzyme))) {
@@ -1161,10 +1161,8 @@ edit_sir <- function(x,
         )
         verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old) | is.na(new) & !is.na(old))
         # save changes to data set 'verbose_info'
-        track_changes$verbose_info <- rbind(track_changes$verbose_info,
-          verbose_new,
-          stringsAsFactors = FALSE
-        )
+        track_changes$verbose_info <- bind_rows2(track_changes$verbose_info,
+          verbose_new)
         # count adds and changes
         track_changes$added <- track_changes$added + verbose_new %pm>%
           pm_filter(is.na(old)) %pm>%
@@ -1215,7 +1213,7 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 12.0)
       )
     )
   }
-  out <- do.call("rbind", lapply(lst, as.data.frame, stringsAsFactors = FALSE))
+  out <- do.call("bind_rows2", lapply(lst, as.data.frame, stringsAsFactors = FALSE))
   rownames(out) <- NULL
   out$ab <- ab
   out$name <- ab_name(ab, language = NULL)

R/mo.R

@@ -325,7 +325,7 @@ as.mo <- function(x,
         result_mo <- NA_character_
       } else {
         result_mo <- AMR_env$MO_lookup$mo[match(top_hits[1], AMR_env$MO_lookup$fullname)]
-        AMR_env$mo_uncertainties <- rbind(AMR_env$mo_uncertainties,
+        AMR_env$mo_uncertainties <- bind_rows2(AMR_env$mo_uncertainties,
           data.frame(
             original_input = x_search,
             input = x_search_cleaned,
@@ -339,7 +339,7 @@ as.mo <- function(x,
           stringsAsFactors = FALSE
         )
         # save to package env to save time for next time
-        AMR_env$mo_previously_coerced <- unique(rbind(AMR_env$mo_previously_coerced,
+        AMR_env$mo_previously_coerced <- unique(bind_rows2(AMR_env$mo_previously_coerced,
           data.frame(
             x = paste(x_search, minimum_matching_score),
             mo = result_mo,
@@ -966,14 +966,14 @@ convert_colloquial_input <- function(x) {
   out[x %like_case% "(viridans.* (strepto|^s).*|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
 
   # Salmonella in different languages, like "Salmonella grupo B"
-  out[x %like_case% "salmonella.* [bcd]$"] <- gsub(".*salmonella.* ([bcd])$",
+  out[x %like_case% "salmonella.* [abcd]$"] <- gsub(".*salmonella.* ([abcd])$",
     "B_SLMNL_GRP\\U\\1",
-    x[x %like_case% "salmonella.* [bcd]$"],
+    x[x %like_case% "salmonella.* [abcd]$"],
     perl = TRUE
   )
-  out[x %like_case% "group [bcd] salmonella"] <- gsub(".*group ([bcd]) salmonella*",
+  out[x %like_case% "group [abcd] salmonella"] <- gsub(".*group ([abcd]) salmonella*",
     "B_SLMNL_GRP\\U\\1",
-    x[x %like_case% "group [bcd] salmonella"],
+    x[x %like_case% "group [abcd] salmonella"],
     perl = TRUE
   )
 

R/mo_property.R

@@ -69,9 +69,8 @@
 #' @return
 #' - An [integer] in case of [mo_year()]
 #' - An [ordered factor][factor] in case of [mo_pathogenicity()]
-#' - A [list] in case of [mo_taxonomy()], [mo_synonyms()] and [mo_info()]
+#' - A [list] in case of [mo_taxonomy()], [mo_synonyms()], [mo_snomed()] and [mo_info()]
 #' - A named [character] in case of [mo_url()]
-#' - A [numeric] in case of [mo_snomed()]
 #' - A [character] in all other cases
 #' @export
 #' @seealso Data set [microorganisms]

R/plot.R

@@ -585,17 +585,17 @@ plot.sir <- function(x,
   data$s <- round((data$n / sum(data$n)) * 100, 1)
 
   if (!"S" %in% data$x) {
-    data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
+    data <- bind_rows2(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
       stringsAsFactors = FALSE
     )
   }
   if (!"I" %in% data$x) {
-    data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
+    data <- bind_rows2(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
       stringsAsFactors = FALSE
     )
   }
   if (!"R" %in% data$x) {
-    data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
+    data <- bind_rows2(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
       stringsAsFactors = FALSE
     )
   }

R/sir.R

@@ -998,7 +998,7 @@ as_sir_method <- function(method_short,
       }
 
       # write to verbose output
-      AMR_env$sir_interpretation_history <- rbind(
+      AMR_env$sir_interpretation_history <- bind_rows2(
         AMR_env$sir_interpretation_history,
         # recycling 1 to 2 rows does not seem to work, which is why rep() was added
         data.frame(

R/sir_calc.R

@@ -322,7 +322,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
           }
           out_new <- cbind(group_values, out_new)
         }
-        out <- rbind(out, out_new, stringsAsFactors = FALSE)
+        out <- bind_rows2(out, out_new)
       }
     }
     out
@@ -331,7 +331,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
   # based on pm_apply_grouped_function
   apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
     grouped <- pm_split_into_groups(.data, groups, drop)
-    res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
+    res <- do.call(bind_rows2, unname(lapply(grouped, fn, ...)))
     if (any(groups %in% colnames(res))) {
       class(res) <- c("grouped_data", class(res))
       res <- pm_set_groups(res, groups[groups %in% colnames(res)])

inst/tinytest/test-mo_property.R

@@ -163,7 +163,7 @@ expect_identical(mo_current(c("Escherichia blattae", "Escherichia coli")),
 expect_identical(mo_ref("Chlamydia psittaci"), "Garcia-Lopez et al., 2019")
 expect_identical(mo_ref("Chlamydophila psittaci", keep_synonyms = TRUE), "Everett et al., 1999")
 
-expect_true(112283007 %in% mo_snomed("Escherichia coli"))
+expect_true(112283007 %in% mo_snomed("Escherichia coli")[[1]])
 # old codes must throw a warning in mo_* family
 expect_warning(mo_name(c("B_ESCHR_COL", "B_STPHY_AUR")))
 # outcome of mo_fullname must always return the fullname from the data set

man/mo_property.Rd

@@ -284,9 +284,8 @@ mo_property(
 \itemize{
 \item An \link{integer} in case of \code{\link[=mo_year]{mo_year()}}
 \item An \link[=factor]{ordered factor} in case of \code{\link[=mo_pathogenicity]{mo_pathogenicity()}}
-\item A \link{list} in case of \code{\link[=mo_taxonomy]{mo_taxonomy()}}, \code{\link[=mo_synonyms]{mo_synonyms()}} and \code{\link[=mo_info]{mo_info()}}
+\item A \link{list} in case of \code{\link[=mo_taxonomy]{mo_taxonomy()}}, \code{\link[=mo_synonyms]{mo_synonyms()}}, \code{\link[=mo_snomed]{mo_snomed()}} and \code{\link[=mo_info]{mo_info()}}
 \item A named \link{character} in case of \code{\link[=mo_url]{mo_url()}}
-\item A \link{numeric} in case of \code{\link[=mo_snomed]{mo_snomed()}}
 \item A \link{character} in all other cases
 }
 }