pm_bind_rows

R/aa_helper_functions.R

@@ -88,7 +88,8 @@ where <- function(fn) {
   which(data_cols %in% cols)
 }
 
-# copied and slightly rewritten from poorman under same license (2021-10-15)
+# copied and slightly rewritten from {poorman} under permissive license (2021-10-15)
+# https://github.com/nathaneastwood/poorman, MIT licensed, Nathan Eastwood, 2020
 quick_case_when <- function(...) {
   fs <- list(...)
   lapply(fs, function(x) {
@@ -162,20 +163,26 @@ 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
+# copied and slightly rewritten from {poorman} under permissive license (2023-02-11)
+# https://github.com/nathaneastwood/poorman, MIT licensed, Nathan Eastwood, 2020
+pm_bind_rows <- function (..., stringsAsFactors = FALSE) {
+  lsts <- Filter(Negate(is.null), list(...))
+  nms <- unique(unlist(lapply(lsts, names)))
+  lsts <- lapply(lsts, function(x) {
+    if (!is.data.frame(x)) {
+      x <- data.frame(as.list(x), stringsAsFactors = stringsAsFactors)
+    }
+    for (i in nms[!nms %in% names(x)]) {
+      # create the new column, could also be length 0
+      x[[i]] <- rep(NA, NROW(x))
+    }
+    x
   })
-  mat <- do.call(rbind, mat_list)
-  as.data.frame(mat, stringsAsFactors = FALSE)
+  names(lsts) <- NULL
+  do.call(rbind, lsts)
 }
 
+
 # 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(bind_rows2(AMR_env$ab_previously_coerced,
+    AMR_env$ab_previously_coerced <- unique(pm_bind_rows(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_rows2(new_df,
-                             long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
+        new_df <- pm_bind_rows(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(bind_rows2(AMR_env$av_previously_coerced,
+    AMR_env$av_previously_coerced <- unique(pm_bind_rows(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(bind_rows2, pivot)
+      merged <- do.call(pm_bind_rows, 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 <- bind_rows2(out, out_group)
+      out <- pm_bind_rows(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(bind_rows2, unname(lapply(grouped, fn, ...)))
+    res <- do.call(pm_bind_rows, 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(bind_rows2(AMR_env$AB_lookup, new_df))
+  AMR_env$AB_lookup <- unique(pm_bind_rows(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(bind_rows2(AMR_env$MO_lookup, new_df))
+  AMR_env$MO_lookup <- unique(pm_bind_rows(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 <- bind_rows2(ab_enzyme, ampi, amox)
+    ab_enzyme <- pm_bind_rows(ab_enzyme, ampi, amox)
     ab_enzyme <- ab_enzyme[order(ab_enzyme$enzyme_name), , drop = FALSE]
 
     for (i in seq_len(nrow(ab_enzyme))) {
@@ -1161,7 +1161,7 @@ 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 <- bind_rows2(track_changes$verbose_info,
+        track_changes$verbose_info <- pm_bind_rows(track_changes$verbose_info,
           verbose_new)
         # count adds and changes
         track_changes$added <- track_changes$added + verbose_new %pm>%
@@ -1213,7 +1213,7 @@ eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 12.0)
       )
     )
   }
-  out <- do.call("bind_rows2", lapply(lst, as.data.frame, stringsAsFactors = FALSE))
+  out <- do.call("pm_bind_rows", 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 <- bind_rows2(AMR_env$mo_uncertainties,
+        AMR_env$mo_uncertainties <- pm_bind_rows(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(bind_rows2(AMR_env$mo_previously_coerced,
+        AMR_env$mo_previously_coerced <- unique(pm_bind_rows(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 <- bind_rows2(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
+    data <- pm_bind_rows(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
       stringsAsFactors = FALSE
     )
   }
   if (!"I" %in% data$x) {
-    data <- bind_rows2(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
+    data <- pm_bind_rows(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
       stringsAsFactors = FALSE
     )
   }
   if (!"R" %in% data$x) {
-    data <- bind_rows2(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
+    data <- pm_bind_rows(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 <- bind_rows2(
+      AMR_env$sir_interpretation_history <- pm_bind_rows(
         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 <- bind_rows2(out, out_new)
+        out <- pm_bind_rows(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(bind_rows2, unname(lapply(grouped, fn, ...)))
+    res <- do.call(pm_bind_rows, 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)])