bind_rows

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: AMR
-Version: 1.8.2.9115
+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.9115
+# 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

@@ -107,7 +107,6 @@ globalVariables(c(
   "atc_group1",
   "atc_group2",
   "base_ab",
-  "bind_rows",
   "ci_max",
   "ci_min",
   "clinical_breakpoints",

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`.")
+  if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
-  data_cols <- pm_select_env$get_colnames()
+  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,7 +404,7 @@ 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,
+        new_df <- bind_rows2(new_df,
                              long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
       }
     }

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)])

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,
+        track_changes$verbose_info <- bind_rows2(track_changes$verbose_info,
-          verbose_new,
+          verbose_new)
-          stringsAsFactors = FALSE
-        )
         # 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,

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)])