From 2007c3eef3356dc124edf1b2567d2e730b62a027 Mon Sep 17 00:00:00 2001 From: "Matthijs S. Berends" Date: Fri, 10 Feb 2023 17:09:48 +0100 Subject: [PATCH] bind_rows --- DESCRIPTION | 2 +- NEWS.md | 2 +- R/aa_globals.R | 1 - R/aa_helper_functions.R | 30 +++++++++++++++++++++++++----- R/ab.R | 2 +- R/antibiogram.R | 4 ++-- R/av.R | 2 +- R/bug_drug_combinations.R | 6 +++--- R/custom_antimicrobials.R | 2 +- R/custom_microorganisms.R | 2 +- R/eucast_rules.R | 10 ++++------ R/mo.R | 4 ++-- R/plot.R | 6 +++--- R/sir.R | 2 +- R/sir_calc.R | 4 ++-- 15 files changed, 48 insertions(+), 31 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7bef1135..b8c3316a 100644 --- a/DESCRIPTION +++ b/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) diff --git a/NEWS.md b/NEWS.md index c2bbe5af..1753e972 100755 --- a/NEWS.md +++ b/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!)* diff --git a/R/aa_globals.R b/R/aa_globals.R index 57bbb29c..0ec7c8ae 100755 --- a/R/aa_globals.R +++ b/R/aa_globals.R @@ -107,7 +107,6 @@ globalVariables(c( "atc_group1", "atc_group2", "base_ab", - "bind_rows", "ci_max", "ci_min", "clinical_breakpoints", diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R index 1b41b07b..34287280 100755 --- a/R/aa_helper_functions.R +++ b/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% ") diff --git a/R/ab.R b/R/ab.R index 6b4e9e06..cd7322ab 100755 --- a/R/ab.R +++ b/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, diff --git a/R/antibiogram.R b/R/antibiogram.R index 001f70de..fbb82fb4 100755 --- a/R/antibiogram.R +++ b/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 diff --git a/R/av.R b/R/av.R index c48b70f4..08791fdd 100755 --- a/R/av.R +++ b/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, diff --git a/R/bug_drug_combinations.R b/R/bug_drug_combinations.R index 0b86e529..4af032fc 100755 --- a/R/bug_drug_combinations.R +++ b/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)]) diff --git a/R/custom_antimicrobials.R b/R/custom_antimicrobials.R index eab62dd9..b86e910c 100755 --- a/R/custom_antimicrobials.R +++ b/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") diff --git a/R/custom_microorganisms.R b/R/custom_microorganisms.R index 9c4f5802..3e7f6789 100755 --- a/R/custom_microorganisms.R +++ b/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.") diff --git a/R/eucast_rules.R b/R/eucast_rules.R index d98a460b..7dbafeda 100755 --- a/R/eucast_rules.R +++ b/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) diff --git a/R/mo.R b/R/mo.R index 4a9b3704..c3633e4c 100755 --- a/R/mo.R +++ b/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, diff --git a/R/plot.R b/R/plot.R index fb2431a3..c927cb89 100755 --- a/R/plot.R +++ b/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 ) } diff --git a/R/sir.R b/R/sir.R index 7b8c18e3..bb8b37b8 100755 --- a/R/sir.R +++ b/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( diff --git a/R/sir_calc.R b/R/sir_calc.R index 3c11434d..3501f823 100755 --- a/R/sir_calc.R +++ b/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)])