From 94f8c85376396db4588b5844fba956851916cb8c Mon Sep 17 00:00:00 2001 From: timcadman Date: Thu, 4 Apr 2024 15:03:56 +0000 Subject: [PATCH 01/20] fix: removed erroneous weight_obj argument, moved functions back into try catch which seemed to fix it and stopped using dplyr to build a tibble which also fixed it. This is a big hack really but lets see what happens --- R/multGlm.R | 42 +++++++++++++++++++----------------------- 1 file changed, 19 insertions(+), 23 deletions(-) diff --git a/R/multGlm.R b/R/multGlm.R index 98fa502..618bdb8 100644 --- a/R/multGlm.R +++ b/R/multGlm.R @@ -42,29 +42,38 @@ dh.multGLM <- function(df = NULL, ref = NULL, checks = TRUE, conns = NULL, ## ---- Run the models ------------------------------------------------------- suppressWarnings( glm_out <- ref %>% - pmap(function(formula, cohort, weight_obj, ...) { + pmap(function(formula, cohort, ...) { tryCatch( - {multGlmWraper(formula, df, family, weights, cohort, conns)}, - error = multHandleError(error_message) + { + ds.glmSLMA( + formula = unlist(formula), + dataName = df, + family = family, + weights = weights, + combine.with.metafor = TRUE, + datasources = conns[cohort]) + }, + error = function(error_message) { + out <- list("failed", error_message) + return(out) + } ) }) ) -formula = ref$formula +# formula = ref$formula ## ---- Identify models which failed completely ------------------------------ fail_tmp <- glm_out %>% map(~ .[[1]][[1]][[1]]) %>% str_detect("POTENTIALLY DISCLOSIVE|failed", negate = TRUE) - out <- ref %>% - mutate( - fit = glm_out, - converged = fail_tmp - ) - + out <- ref + out$fit <- glm_out + out$converged <- fail_tmp + problems <- out %>% dplyr::filter(converged == FALSE) @@ -97,16 +106,3 @@ multHandleError <- function(error_message){ out <- list("failed", error_message) return(out) } - -multGlmWraper <- function(formula, df, family, weights, cohort, conns){ - - ds.glmSLMA( - formula = unlist(formula), - dataName = df, - family = family, - combine.with.metafor = TRUE, - weights = weights, - datasources = conns[cohort] - ) - -} \ No newline at end of file From 6d94b73c5c2a11f937bfd4dfddbf51a60883816a Mon Sep 17 00:00:00 2001 From: timcadman Date: Thu, 4 Apr 2024 15:08:58 +0000 Subject: [PATCH 02/20] chore: bumped version number --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6146bee..439f988 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: dsHelper Type: Package Title: Helper Functions for Use with 'DataSHIELD' -Version: 1.3.0 +Version: 1.4 Description: Often we need to automate things with 'DataSHIELD'. These functions help to do that. Authors@R: c(person(given= "Tim", From b5cad12b321a1212f67e6a0d98768f07744c00a4 Mon Sep 17 00:00:00 2001 From: timcadman Date: Thu, 4 Apr 2024 15:17:48 +0000 Subject: [PATCH 03/20] fix: error caused by trying to filter on which is not a column from where type = 'glm_ipd' --- R/pool.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/R/pool.R b/R/pool.R index 7a58057..9b58955 100644 --- a/R/pool.R +++ b/R/pool.R @@ -84,6 +84,7 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @importFrom purrr map #' @noRd getCoefs <- function(imputed_glm, type, coh_names, family){ + cohort <- NULL coefs <- imputed_glm %>% map( @@ -93,9 +94,14 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ family = family, coh_names = coh_names, direction = "wide", - ci_format = "separate") %>% - dplyr::filter(cohort != "combined")) - + ci_format = "separate") + ) + + if(type == "glm_slma"){ + coefs <- coefs %>% + dplyr::filter(cohort != "combined") + } + } #' Tidy coefficients data frames. From 9c92f260dfde788f24f1dd358157b1791f5f93b9 Mon Sep 17 00:00:00 2001 From: timcadman Date: Tue, 9 Apr 2024 11:35:00 +0000 Subject: [PATCH 04/20] fix: now should work for both input types. Also provide warning if >1 cohort name used where type == glm_ipd --- R/pool.R | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/R/pool.R b/R/pool.R index 9b58955..931f7a3 100644 --- a/R/pool.R +++ b/R/pool.R @@ -22,14 +22,13 @@ #' @export dh.pool <- function(imputed_glm = NULL, type = NULL, coh_names = NULL, family = NULL, exponentiate = FALSE){ - poolCheckArgs(imputed_glm, type, coh_names, family, exponentiate) m <- length(imputed_glm) coefs <- getCoefs(imputed_glm, type, coh_names, family) tidied_coefs <- tidyCoefs(coefs, m) - split_coefs <- splitCoefs(tidied_coefs) + split_coefs <- splitCoefs(tidied_coefs, type, coh_names) out <- split_coefs %>% map(~makeRubinTable(coefs = .x, m = m, exponentiate = exponentiate)) %>% @@ -62,6 +61,12 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ checkmate::assert_list(imputed_glm, add = error_messages) checkmate::assert_true(length(imputed_glm) > 1, add = error_messages) + if(type == "glm_ipd" & length(coh_names) >1){ + warning("Your input type is `glm_ipd` but you have provided >1 cohort name. Did you intend this? + It is recommended that the regression model is performed separately on each cohort, then estimates + pooled and (if applicable) meta-analysed") +} + if (exponentiate == TRUE & family == "gaussian") { warning("It is not recommended to exponentiate coefficients from linear regression: argument is ignored") @@ -96,11 +101,13 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ direction = "wide", ci_format = "separate") ) - - if(type == "glm_slma"){ - coefs <- coefs %>% - dplyr::filter(cohort != "combined") - } + + if(type == "glm_slma"){ + coefs <- list(coefs) %>% + map(~dplyr::filter(., cohort != "combined")) + } + + return(coefs) } @@ -134,14 +141,20 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' equals the number of imputed datasets. #' #' @noRd - splitCoefs <- function(tidied_coefs){ + splitCoefs <- function(tidied_coefs, type, coh_names){ cohort <- variable <- NULL + if(type == "glm_slma"){ split_coefs <- tidied_coefs %>% group_by(cohort, variable) %>% group_split() + } else if (type == "glm_ipd"){ + split_coefs <- list(tidied_coefs) %>% + map(~mutate(., cohort = coh_names)) + } + return(split_coefs) } From e244243e1413f11ae2b0fc0c903bc58c57f38816 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 12 Apr 2024 11:50:11 +0200 Subject: [PATCH 05/20] fix: had incorrectly split variables for glm_ipd --- R/pool.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/pool.R b/R/pool.R index 931f7a3..5636d53 100644 --- a/R/pool.R +++ b/R/pool.R @@ -99,7 +99,8 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ family = family, coh_names = coh_names, direction = "wide", - ci_format = "separate") + ci_format = "separate", + digits = 20) ) if(type == "glm_slma"){ @@ -144,17 +145,16 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ splitCoefs <- function(tidied_coefs, type, coh_names){ cohort <- variable <- NULL + + if (type == "glm_ipd"){ + tidied_coefs <- tidied_coefs %>% + mutate(., cohort = coh_names) + } - if(type == "glm_slma"){ split_coefs <- tidied_coefs %>% group_by(cohort, variable) %>% group_split() - - } else if (type == "glm_ipd"){ - split_coefs <- list(tidied_coefs) %>% - map(~mutate(., cohort = coh_names)) - } - + return(split_coefs) } From 4d08827cbcc888820b6c769f6640b28de4a768fc Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 25 Apr 2024 10:19:02 +0200 Subject: [PATCH 06/20] feat: extended to work with lmer models --- R/pool.R | 233 ++++++++++++++++++++++++++----------------------------- 1 file changed, 109 insertions(+), 124 deletions(-) diff --git a/R/pool.R b/R/pool.R index 5636d53..b0fa911 100644 --- a/R/pool.R +++ b/R/pool.R @@ -13,29 +13,27 @@ #' `type` is "gaussian". #' @return A tibble containing Rubin's pooled estimates and confidence intervals. #' -#' @details This function performs Rubin's pooling on a list of imputed generalized linear models. -#' It extracts coefficients using specified parameters, tidies the coefficients, and then performs +#' @details This function performs Rubin's pooling on a list of imputed generalized linear models. +#' It extracts coefficients using specified parameters, tidies the coefficients, and then performs #' pooling. #' #' @importFrom dplyr bind_rows #' @importFrom purrr map #' @export -dh.pool <- function(imputed_glm = NULL, type = NULL, coh_names = NULL, family = NULL, - exponentiate = FALSE){ +dh.pool <- function(imputed_glm = NULL, type = NULL, coh_names = NULL, family = NULL, + exponentiate = FALSE) { poolCheckArgs(imputed_glm, type, coh_names, family, exponentiate) - + m <- length(imputed_glm) - coefs <- getCoefs(imputed_glm, type, coh_names, family) - tidied_coefs <- tidyCoefs(coefs, m) + tidied_coefs <- tidyCoefs(coefs, m, type) split_coefs <- splitCoefs(tidied_coefs, type, coh_names) - - out <- split_coefs %>% - map(~makeRubinTable(coefs = .x, m = m, exponentiate = exponentiate)) %>% + + out <- split_coefs %>% + map(~ makeRubinTable(coefs = .x, m = m, exponentiate = exponentiate)) %>% bind_rows() - + return(out) - } #' Check arguments for dh.pool function. @@ -54,26 +52,24 @@ dh.pool <- function(imputed_glm = NULL, type = NULL, coh_names = NULL, family = #' #' @importFrom checkmate assert_list assert_true #' @noRd -poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ - +poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate) { error_messages <- makeAssertCollection() - + checkmate::assert_list(imputed_glm, add = error_messages) checkmate::assert_true(length(imputed_glm) > 1, add = error_messages) - - if(type == "glm_ipd" & length(coh_names) >1){ + + if (type == "glm_ipd" & length(coh_names) > 1) { warning("Your input type is `glm_ipd` but you have provided >1 cohort name. Did you intend this? It is recommended that the regression model is performed separately on each cohort, then estimates pooled and (if applicable) meta-analysed") -} - + } + if (exponentiate == TRUE & family == "gaussian") { warning("It is not recommended to exponentiate coefficients from linear regression: argument is ignored") } - + return(reportAssertions(error_messages)) - } #' Extract coefficients from imputed generalized linear models. @@ -85,32 +81,38 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @return A list of data frames containing coefficients. #' #' @details This function extracts coefficients from each imputed generalized linear model -#' +#' #' @importFrom purrr map #' @noRd - getCoefs <- function(imputed_glm, type, coh_names, family){ - cohort <- NULL - - coefs <- imputed_glm %>% - map( - ~dh.lmTab( - model = .x, - type = type, - family = family, - coh_names = coh_names, - direction = "wide", - ci_format = "separate", - digits = 20) - ) - - if(type == "glm_slma"){ - coefs <- list(coefs) %>% - map(~dplyr::filter(., cohort != "combined")) - } - - return(coefs) - - } +getCoefs <- function(imputed_glm, type, coh_names, family) { + cohort <- NULL + + coefs <- imputed_glm %>% + map( + ~ dh.lmTab( + model = .x, + type = type, + family = family, + coh_names = coh_names, + direction = "wide", + ci_format = "separate", + digits = 20 + ) + ) + + if (type == "glm_slma") { + coefs <- list(coefs) %>% + map(~ dplyr::filter(., cohort != "combined")) + } + + if (type == "lmer_slma") { + coefs <- coefs %>% + map(~ .$fixed) %>% + map(~ dplyr::filter(., cohort != "combined")) + } + + return(coefs) +} #' Tidy coefficients data frames. #' @@ -122,57 +124,52 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' #' @importFrom dplyr bind_rows select #' @noRd - tidyCoefs <- function(coefs, m){ - - imputation <- cohort <- variable <- est <- se <- n_obs <- NULL - - tidied <- coefs %>% - set_names(paste0("imputation_",1:m)) %>% - bind_rows(.id = "imputation") %>% - dplyr::select(imputation, cohort, variable, est, se, n_obs) - } +tidyCoefs <- function(coefs, m, type) { + imputation <- cohort <- variable <- est <- se <- n_obs <- NULL + + tidied <- coefs %>% + set_names(paste0("imputation_", 1:m)) %>% + bind_rows(.id = "imputation") %>% + dplyr::select(imputation, cohort, variable, est, se, n_obs) +} #' Split tidied coefficients data frame. #' #' @param tidied_coefs A tidied data frame of coefficients. #' @return A list of tibbles, split by cohort and variable. #' -#' @details This function splits the tidied coefficients tibble into a list of tibbles based on +#' @details This function splits the tidied coefficients tibble into a list of tibbles based on #' cohort and variable, ie it creates one tibble per cohort and variable, where the number of rows #' equals the number of imputed datasets. #' #' @noRd - splitCoefs <- function(tidied_coefs, type, coh_names){ - - cohort <- variable <- NULL +splitCoefs <- function(tidied_coefs, type, coh_names) { + cohort <- variable <- NULL + + if (type == "glm_ipd") { + tidied_coefs <- tidied_coefs %>% + mutate(., cohort = coh_names) + } - if (type == "glm_ipd"){ - tidied_coefs <- tidied_coefs %>% - mutate(., cohort = coh_names) - } - - split_coefs <- tidied_coefs %>% - group_by(cohort, variable) %>% - group_split() + split_coefs <- tidied_coefs %>% + group_by(cohort, variable) %>% + group_split() - return(split_coefs) - - } + return(split_coefs) +} #' Calculate the Rubin's pooled mean. #' #' @param coefs A tibble containing coefficients. #' @return The pooled mean of coefficients. #' -#' @details This function calculates the pooled mean using Rubin's rules from a tibble of +#' @details This function calculates the pooled mean using Rubin's rules from a tibble of #' coefficients. #' #' @noRd - rubinMean <- function(coefs){ - - return(mean(coefs$est)) - - } +rubinMean <- function(coefs) { + return(mean(coefs$est)) +} #' Calculate the Rubin's within-imputation variance. #' @@ -182,11 +179,9 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @details This function calculates the within-imputation variance using Rubin's rules. #' #' @noRd - rubinWithinVar <- function(coefs){ - - return(mean(coefs$se^2)) - - } +rubinWithinVar <- function(coefs) { + return(mean(coefs$se^2)) +} #' Calculate the Rubin's between-imputation variance. #' @@ -198,11 +193,9 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @details This function calculates the between-imputation variance using Rubin's rules. #' #' @noRd - rubinBetweenVar <- function(coefs, means, m){ - - return(sum((coefs$est - means)^2) / (m - 1)) - - } +rubinBetweenVar <- function(coefs, means, m) { + return(sum((coefs$est - means)^2) / (m - 1)) +} #' Calculate the Rubin's pooled standard error. #' @@ -214,11 +207,9 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @details This function calculates the pooled standard error using Rubin's rules. #' #' @noRd - rubinPooledSe <- function(within_var, between_var, m){ - - return(within_var + between_var + (between_var/m)) - - } +rubinPooledSe <- function(within_var, between_var, m) { + return(within_var + between_var + (between_var / m)) +} #' Calculate the Rubin's Z statistic. #' @@ -233,11 +224,9 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' rubinZ(1.2, 0.3) #' #' @noRd - rubinZ <- function(pooled_mean, pooled_se){ - - return(pooled_mean / pooled_se) - - } +rubinZ <- function(pooled_mean, pooled_se) { + return(pooled_mean / pooled_se) +} #' Calculate the Rubin's p-value. #' @@ -248,11 +237,9 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @importFrom stats pnorm #' #' @noRd - rubinP <- function(z_value){ - - return(2 * pnorm(-abs(z_value))) - - } +rubinP <- function(z_value) { + return(2 * pnorm(-abs(z_value))) +} #' Create a tibble of coefficients using Rubin's rules. #' @@ -267,28 +254,26 @@ poolCheckArgs <- function(imputed_glm, type, coh_names, family, exponentiate){ #' @importFrom dplyr tibble #' @importFrom stats qnorm #' @noRd - makeRubinTable <- function(coefs, m, exponentiate){ - pooled_mean <- within_var <- between_var <- pooled_se <- z_value <- low_ci <- upp_ci <- NULL - rubinTable <- tibble( - variable = coefs$variable[[1]], - cohort = coefs$cohort[[1]], - n_obs = coefs$n_obs[[1]], - pooled_mean = rubinMean(coefs), - within_var = rubinWithinVar(coefs), - between_var = rubinBetweenVar(coefs, pooled_mean, m), - pooled_se = rubinPooledSe(within_var, between_var, m), - z_value = rubinZ(pooled_mean, pooled_se), - p_value = rubinP(z_value), - low_ci = pooled_mean - qnorm(0.975) * pooled_se, - upp_ci = pooled_mean + qnorm(0.975) * pooled_se) - - if(exponentiate){ - - rubinTable <- rubinTable %>% - mutate(across(c(pooled_mean, low_ci, upp_ci), ~exp(.))) +makeRubinTable <- function(coefs, m, exponentiate) { + pooled_mean <- within_var <- between_var <- pooled_se <- z_value <- low_ci <- upp_ci <- NULL + rubinTable <- tibble( + variable = coefs$variable[[1]], + cohort = coefs$cohort[[1]], + n_obs = coefs$n_obs[[1]], + pooled_mean = rubinMean(coefs), + within_var = rubinWithinVar(coefs), + between_var = rubinBetweenVar(coefs, pooled_mean, m), + pooled_se = rubinPooledSe(within_var, between_var, m), + z_value = rubinZ(pooled_mean, pooled_se), + p_value = rubinP(z_value), + low_ci = pooled_mean - qnorm(0.975) * pooled_se, + upp_ci = pooled_mean + qnorm(0.975) * pooled_se + ) - } - - return(rubinTable) - - } \ No newline at end of file + if (exponentiate) { + rubinTable <- rubinTable %>% + mutate(across(c(pooled_mean, low_ci, upp_ci), ~ exp(.))) + } + + return(rubinTable) +} From e3fcae329bb79480951a13042c8ff34c1c20dd87 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 25 Apr 2024 10:19:12 +0200 Subject: [PATCH 07/20] chore: styled package| --- R/build-models.R | 2 +- R/create-table-one.R | 7 ++--- R/get-anon-plot-data.R | 8 +++--- R/get-stats.R | 1 - R/lm-tab.R | 39 +++++++++++-------------- R/make-iqr.R | 1 - R/make-lmer-form.R | 6 ++-- R/make-strata.R | 2 -- R/mean-by-group.R | 3 -- R/meta-sep-models.R | 43 ++++++++++++---------------- R/multGlm.R | 39 ++++++++++++------------- R/predict-lmer.R | 2 +- R/quartile-split.R | 1 - R/tidy-env.R | 1 - tests/testthat/test-lm-tab.R | 2 +- tests/testthat/test-make-lmer-form.R | 6 ++-- 16 files changed, 70 insertions(+), 93 deletions(-) diff --git a/R/build-models.R b/R/build-models.R index 3255d50..51b34e9 100644 --- a/R/build-models.R +++ b/R/build-models.R @@ -171,7 +171,7 @@ make_exp_out_cov_form <- function(comb_with_covariates) { outcome <- exposure <- covariates <- NULL formula <- comb_with_covariates %>% - rowwise %>% + rowwise() %>% mutate(formula = paste(outcome, "~1+", exposure, "+", paste(unlist(covariates), collapse = "+"))) return(formula) diff --git a/R/create-table-one.R b/R/create-table-one.R index e1710e7..f1603c5 100644 --- a/R/create-table-one.R +++ b/R/create-table-one.R @@ -319,10 +319,11 @@ dh.createTableOne <- function(stats = NULL, vars = NULL, var_labs = NULL, mutate(value = ifelse(is.na(category), paste0(missing, " (", missing_perc, ")"), value )) %>% - dplyr::select(cohort, variable, category, value) %>% + dplyr::select(cohort, variable, category, value) %>% mutate(category = case_when( category == "med_iqr" ~ "Median \u00b1 (IQR)", - category == "mean_sd" ~ "Mean \u00b1 SD")) + category == "mean_sd" ~ "Mean \u00b1 SD" + )) return(out) } @@ -352,8 +353,6 @@ dh.createTableOne <- function(stats = NULL, vars = NULL, var_labs = NULL, but do not have a corresponding labels for all categories provided in `cat_labs`\n\n", unique(missing_cats$variable) ) - - } } diff --git a/R/get-anon-plot-data.R b/R/get-anon-plot-data.R index e3088fc..2fbb0dc 100644 --- a/R/get-anon-plot-data.R +++ b/R/get-anon-plot-data.R @@ -84,10 +84,10 @@ dh.getAnonPlotData <- function(df = NULL, var_1 = NULL, var_2 = NULL, out <- scatter %>% map(~ - tibble( - x = .[[1]], - y = .[[2]] - )) %>% + tibble( + x = .[[1]], + y = .[[2]] + )) %>% bind_rows(.id = "cohort") %>% dplyr::rename( !!quo_name(var_1) := x, diff --git a/R/get-stats.R b/R/get-stats.R index 54798e3..acf8287 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -383,7 +383,6 @@ check with ds.class \n\n", ################################################################################ if (nrow(fact_ref) > 0) { - ## ---- Combined value for each level of variables ----------------------------- levels_comb <- stats_cat %>% group_by(variable, category) %>% diff --git a/R/lm-tab.R b/R/lm-tab.R index 3695c30..05f940e 100644 --- a/R/lm-tab.R +++ b/R/lm-tab.R @@ -94,13 +94,12 @@ dh.lmTab <- function(model = NULL, type = NULL, coh_names = NULL, coh_ns <- extract_ns_lmer(model, nstudy) coh_coefs <- add_ns_slma(coh_ns, coh_coefs, coh_names) - if(extract_random){ - random <- extract_random(model, coh_names, nstudy) - random <- rename_intercept(random, col_name = "var1") + if (extract_random) { + random <- extract_random(model, coh_names, nstudy) + random <- rename_intercept(random, col_name = "var1") - random <- random %>% - mutate(across(stddev, ~ round(., digits))) - + random <- random %>% + mutate(across(stddev, ~ round(., digits))) } } @@ -142,26 +141,20 @@ dh.lmTab <- function(model = NULL, type = NULL, coh_names = NULL, coefs <- rename_intercept(coefs, col_name = "variable") if (type == "lmer_slma") { - - if(extract_random){ - + if (extract_random) { return( - list( - fixed = coefs, - random = random + list( + fixed = coefs, + random = random + ) ) - ) - - } else{ - - return( - list( - fixed = coefs - ) + } else { + return( + list( + fixed = coefs ) - - } - + ) + } } else { return(coefs) } diff --git a/R/make-iqr.R b/R/make-iqr.R index 35bad98..f1d970b 100644 --- a/R/make-iqr.R +++ b/R/make-iqr.R @@ -109,7 +109,6 @@ dh.makeIQR <- function(df = NULL, vars = NULL, type = c("combine", "split"), stringsAsFactors = FALSE ) } else if (type == "combine") { - ## ---- Identify cohorts which are all missing ----------------------------- missing <- expand.grid(vars, names(conns)) %>% set_names(c("variable", "cohort")) %>% diff --git a/R/make-lmer-form.R b/R/make-lmer-form.R index c7e68a2..9b09e00 100644 --- a/R/make-lmer-form.R +++ b/R/make-lmer-form.R @@ -37,7 +37,6 @@ #' @export dh.makeLmerForm <- function(outcome = NULL, id_var = NULL, age_vars = NULL, random = NULL, fixed = NULL, age_interactions = NULL) { - lmer_form_check_args(outcome, id_var, age_vars, random, fixed, age_interactions) formula_fixed <- make_fixed_effects(age_vars, fixed, age_interactions) @@ -92,8 +91,9 @@ make_fixed_effects <- function(age_vars, fixed, age_interactions) { if (!is.null(age_interactions)) { age_interactions <- c( - combn(paste0(age_interactions, "*", age_vars), 2, paste, collapse = "+"), - paste0(age_interactions, "*", age_vars)) + combn(paste0(age_interactions, "*", age_vars), 2, paste, collapse = "+"), + paste0(age_interactions, "*", age_vars) + ) } if (!is.null(fixed)) { diff --git a/R/make-strata.R b/R/make-strata.R index a96f666..0f61019 100644 --- a/R/make-strata.R +++ b/R/make-strata.R @@ -563,7 +563,6 @@ dh.makeStrata <- function(df = NULL, id_var = NULL, age_var = NULL, var_to_subse #' @noRd .sortSubset <- function(mult_action, nearest_value, subset_name, age_var, newobj, conns) { if (mult_action == "nearest") { - ## Make a variable specifying distance between age of measurement and prefered ## value (provided by "mult_vals") @@ -602,7 +601,6 @@ dh.makeStrata <- function(df = NULL, id_var = NULL, age_var = NULL, var_to_subse #' #' @noRd .reshapeSubset <- function(sorted_subset, id_var, age_var, var_to_subset, var_suffix, conns, newobj, keep_vars) { - # We need a vector the length of our subset with an integer value describing # the name of the subset. We use this to create our final variables names diff --git a/R/mean-by-group.R b/R/mean-by-group.R index b36a60f..e755008 100644 --- a/R/mean-by-group.R +++ b/R/mean-by-group.R @@ -58,8 +58,6 @@ dh.meanByGroup <- function(df = NULL, outcome = NULL, group_var = NULL, ## the binning variable it is quite quick if (is.null(intervals)) { - - ## ---- First we round up the age variable ----------------------------------------------- DSI::datashield.assign( conns, "age_tmp", as.symbol(paste0(df, "$", group_var, "+0.5")) @@ -104,7 +102,6 @@ re-run the function using the `intervals` argument. \n\n", conns = conns ) } else if (!is.null(intervals)) { - ## ---- This is the harder one ------------------------------------------------------------------- ## First we need to create a table defining our age bands. diff --git a/R/meta-sep-models.R b/R/meta-sep-models.R index 15608b3..1d658a6 100644 --- a/R/meta-sep-models.R +++ b/R/meta-sep-models.R @@ -23,7 +23,7 @@ dh.metaSepModels <- function(input = "fit", ref = NULL, exp = NULL, method = NUL output = "both") { exposure <- variable <- cohort <- . <- est <- lowci <- uppci <- model_id <- n_obs <- se <- NULL - + method <- arg_match( arg = method, values = c("DL", "HE", "HS", "HSk", "SJ", "ML", "REML", "EB", "PM", "GENQ") @@ -35,30 +35,25 @@ dh.metaSepModels <- function(input = "fit", ref = NULL, exp = NULL, method = NUL ) if (output %in% c("meta", "both") == TRUE) { - - if(input == "fit"){ - - ## ---- Get coefficients ----------------------------------------------------- - model_coefs <- ref %>% - pmap(function(cohort, fit, ...) { - dh.lmTab( - model = fit, - coh_names = cohort, - type = "glm_slma", - ci_format = "separate", - direction = "wide", - family = "binomial", - digits = 50 - ) %>% - dplyr::filter(cohort != "combined") - }) %>% - set_names(ref$model_id) %>% - bind_rows(.id = "model_id") - - } else{ - + if (input == "fit") { + ## ---- Get coefficients ----------------------------------------------------- + model_coefs <- ref %>% + pmap(function(cohort, fit, ...) { + dh.lmTab( + model = fit, + coh_names = cohort, + type = "glm_slma", + ci_format = "separate", + direction = "wide", + family = "binomial", + digits = 50 + ) %>% + dplyr::filter(cohort != "combined") + }) %>% + set_names(ref$model_id) %>% + bind_rows(.id = "model_id") + } else { model_coefs <- ref - } ## ---- Create tibble respecting grouping order ------------------------------ diff --git a/R/multGlm.R b/R/multGlm.R index 618bdb8..a02662a 100644 --- a/R/multGlm.R +++ b/R/multGlm.R @@ -36,44 +36,43 @@ dh.multGLM <- function(df = NULL, ref = NULL, checks = TRUE, conns = NULL, if (is.null(conns)) { conns <- datashield.connections_find() } - - multCheckArgs(df, ref, vary_df) + + multCheckArgs(df, ref, vary_df) ## ---- Run the models ------------------------------------------------------- suppressWarnings( glm_out <- ref %>% pmap(function(formula, cohort, ...) { - tryCatch( { ds.glmSLMA( - formula = unlist(formula), - dataName = df, - family = family, - weights = weights, - combine.with.metafor = TRUE, - datasources = conns[cohort]) - }, + formula = unlist(formula), + dataName = df, + family = family, + weights = weights, + combine.with.metafor = TRUE, + datasources = conns[cohort] + ) + }, error = function(error_message) { out <- list("failed", error_message) return(out) - } + } ) - }) ) - -# formula = ref$formula + + # formula = ref$formula ## ---- Identify models which failed completely ------------------------------ fail_tmp <- glm_out %>% map(~ .[[1]][[1]][[1]]) %>% str_detect("POTENTIALLY DISCLOSIVE|failed", negate = TRUE) - out <- ref + out <- ref out$fit <- glm_out out$converged <- fail_tmp - + problems <- out %>% dplyr::filter(converged == FALSE) @@ -90,19 +89,17 @@ dh.multGLM <- function(df = NULL, ref = NULL, checks = TRUE, conns = NULL, return(out) } -multCheckArgs <- function(df, ref, vary_df){ - +multCheckArgs <- function(df, ref, vary_df) { if (vary_df == F & is.null(df)) { stop("`df` must not be NULL.", call. = FALSE) } - + if (is.null(ref)) { stop("`ref` must not be NULL.", call. = FALSE) } - } -multHandleError <- function(error_message){ +multHandleError <- function(error_message) { out <- list("failed", error_message) return(out) } diff --git a/R/predict-lmer.R b/R/predict-lmer.R index be43315..8dce3a8 100644 --- a/R/predict-lmer.R +++ b/R/predict-lmer.R @@ -110,7 +110,7 @@ extract_coefficients <- function(model, coh_names) { type = "lmer_slma", coh_names = coh_names, direction = "long", - ci_format = "separate", + ci_format = "separate", digits = 10 ) return(coefs) diff --git a/R/quartile-split.R b/R/quartile-split.R index 6d89ef3..f9f4131 100644 --- a/R/quartile-split.R +++ b/R/quartile-split.R @@ -222,7 +222,6 @@ dh.quartileSplit <- function(df = NULL, var = NULL, new_obj = NULL, band_action quant_ref %>% pmap(function(var_name, cohort, boole_short, ...) { - ## We recode all values of 0 (ie not in the quartile) to NA ds.recodeValues( var.name = boole_short, diff --git a/R/tidy-env.R b/R/tidy-env.R index f827843..e5ca9b7 100644 --- a/R/tidy-env.R +++ b/R/tidy-env.R @@ -36,7 +36,6 @@ dh.tidyEnv <- function(obj = NULL, type = NULL, conns = NULL) { } if (type == "remove") { - ## Check no objects to removed have character length >20 obj_lengths <- tibble( obj = obj, diff --git a/tests/testthat/test-lm-tab.R b/tests/testthat/test-lm-tab.R index 9c47a52..a912fef 100644 --- a/tests/testthat/test-lm-tab.R +++ b/tests/testthat/test-lm-tab.R @@ -298,7 +298,7 @@ test_that("Check that extract_ns_lmer returns vector with correct integers", { # c("cohort", "group", "var1", "var2", "stddev") # ) # }) -# +# # test_that("Check that extract_random returns correct data types", { # expect_equal( # extract_random(lmer.fit, coh_names, nstudy) %>% diff --git a/tests/testthat/test-make-lmer-form.R b/tests/testthat/test-make-lmer-form.R index 27f811c..e78af41 100644 --- a/tests/testthat/test-make-lmer-form.R +++ b/tests/testthat/test-make-lmer-form.R @@ -36,8 +36,10 @@ test_that("make_fixed_effects returns correct string with interaction terms", { fixed = c("fixed_1", "fixed_2"), age_interactions = "fixed_1" ), - c("test_age_1+test_age_2+fixed_1+fixed_2+fixed_1*test_age_1+fixed_1*test_age_2", + c( + "test_age_1+test_age_2+fixed_1+fixed_2+fixed_1*test_age_1+fixed_1*test_age_2", "test_age_1+fixed_1+fixed_2+fixed_1*test_age_1", - "test_age_2+fixed_1+fixed_2+fixed_1*test_age_2") + "test_age_2+fixed_1+fixed_2+fixed_1*test_age_2" + ) ) }) From 8a418e0a793475566fa2f4a8e846c08bec1d0438 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 May 2024 16:51:25 +0200 Subject: [PATCH 08/20] feat: allow no vars to be specified and all returned --- R/get-stats.R | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/R/get-stats.R b/R/get-stats.R index acf8287..c90faf7 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -73,10 +73,6 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, stop("`df` must not be NULL.", call. = FALSE) } - if (is.null(vars)) { - stop("`vars` must not be NULL.", call. = FALSE) - } - if (is.null(conns)) { conns <- datashield.connections_find() } @@ -94,6 +90,10 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, out_cont <- outcome <- same_levels <- se <- stat <- stats_tmp <- stats_wide <- std.dev <- type <- type_w_null <- . <- perc_valid <- perc_total <- Ntotal <- disclosure_fail <- NULL + + if(is.null(df)){ + vars <- .define_default_vars(df, conns) + } ################################################################################ # 1. Remove duplicate variables @@ -545,6 +545,21 @@ check with ds.class \n\n", return(out) } + +#' Define Default Variables +#' +#' This function takes a list of connections as input and returns a vector of unique column names across all connections. +#' +#' @param conns A list of connections to data sources. +#' @return A character vector containing unique column names across all connections. +#' @noRd +.define_default_vars <- function(df, conns){ + all_cols <- ds.colnames(df, conns) + unique_cols <- unique(unlist(all_cols)) + return(unique_cols) +} + + #' Extracts stats using table function #' #' @param ref reference tibble of vars with four columns: variable, cohort, From 66a677a7c6b14824d4722b7caf2e454dd82402f7 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 May 2024 16:51:40 +0200 Subject: [PATCH 09/20] chore: updated dependencies --- DESCRIPTION | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 439f988..c9d094a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,15 +33,16 @@ Imports: DSI, metafor, checkmate, - withr, lme4, - webmockr, tidyselect Suggests: knitr, rmarkdown, testthat, - mockery + mockery, + httr, + webmockr, + withr URL: https://github.com/lifecycle-project/ds-helper/, https: //lifecycle-project.github.io/ds-helper/ BugReports: https://github.com/lifecycle-project/ds-helper/issues/ From c52c0ae62541b18ea548f06d2eb800fd7ef8f3a9 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 May 2024 16:51:57 +0200 Subject: [PATCH 10/20] chore: fixed tests presumably broken by update to dplyr --- tests/testthat/test-lm-tab.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-lm-tab.R b/tests/testthat/test-lm-tab.R index a912fef..9b4a935 100644 --- a/tests/testthat/test-lm-tab.R +++ b/tests/testthat/test-lm-tab.R @@ -113,7 +113,7 @@ ipd_rename_not_expected <- ipd_rename_expected %>% test_that("rename_ipd throws error if provided incorrect variable names", { expect_error( rename_ipd(ipd_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -209,7 +209,7 @@ slma_rename_not_expected <- slma_rename_expected %>% test_that("rename_glm_slma throws error if provided incorrect variable names", { expect_error( rename_glm_slma(slma_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -274,7 +274,7 @@ lmer_rename_not_expected <- lmer_rename_expected %>% test_that("rename_lmer_slma throws error if provided incorrect variable names", { expect_error( rename_lmer_slma(lmer_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -389,7 +389,7 @@ pooled_rename_not_expected <- pooled_rename_expected %>% test_that("rename_slma_pooled throws error if provided incorrect variable names", { expect_error( rename_slma_pooled(pooled_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) From b9e166330a04112f73dc61db4556811c8d072a45 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 May 2024 16:52:14 +0200 Subject: [PATCH 11/20] chore: added variable to null list --- R/pool.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/pool.R b/R/pool.R index b0fa911..03f5baf 100644 --- a/R/pool.R +++ b/R/pool.R @@ -144,7 +144,7 @@ tidyCoefs <- function(coefs, m, type) { #' #' @noRd splitCoefs <- function(tidied_coefs, type, coh_names) { - cohort <- variable <- NULL + cohort <- variable <- . <- NULL if (type == "glm_ipd") { tidied_coefs <- tidied_coefs %>% From 4f5ab1dbc49d7a8108cf4269296e45acfc4b0d62 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 14 May 2024 12:21:31 +0200 Subject: [PATCH 12/20] feat: now return stats even if some cohorts do not contain data frame --- R/get-stats.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/get-stats.R b/R/get-stats.R index c90faf7..d51f5eb 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -76,9 +76,11 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, if (is.null(conns)) { conns <- datashield.connections_find() } - if (checks == TRUE) { - .isDefined(df = df, conns = conns) + conns_exist <- unlist(ds.exists(df)) + excluded <- names(conns)[!conns_exist] + conns <- conns[conns_exist] + warning(paste0("Cohorts ", excluded, " have been excluded as they do not contain data frame ", df), call. = F) } # Not checking whether variable exists because function will show NA if it # doesnt From 83eca2c9d8a6900b39cbbcf3ab58329f25a3c2e1 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 14 May 2024 12:33:22 +0200 Subject: [PATCH 13/20] fix: now only return warning if cohorts are excluded --- R/get-stats.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/get-stats.R b/R/get-stats.R index d51f5eb..1ec8905 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -80,7 +80,9 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, conns_exist <- unlist(ds.exists(df)) excluded <- names(conns)[!conns_exist] conns <- conns[conns_exist] - warning(paste0("Cohorts ", excluded, " have been excluded as they do not contain data frame ", df), call. = F) + if(length(excluded) > 0){ + warning(paste0("Cohorts ", excluded, " have been excluded as they do not contain data frame ", df), call. = F) + } } # Not checking whether variable exists because function will show NA if it # doesnt From 7d2c1f969ba58253be84170963f3b4504e0fc468 Mon Sep 17 00:00:00 2001 From: Tim Cadman Date: Wed, 5 Jun 2024 14:18:01 +0000 Subject: [PATCH 14/20] fix: added missing conns argument --- R/get-stats.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/get-stats.R b/R/get-stats.R index 1ec8905..672a547 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -69,6 +69,7 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, ################################################################################ # 1. First checks ################################################################################ + browser() if (is.null(df)) { stop("`df` must not be NULL.", call. = FALSE) } @@ -77,7 +78,7 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, conns <- datashield.connections_find() } if (checks == TRUE) { - conns_exist <- unlist(ds.exists(df)) + conns_exist <- unlist(ds.exists(df, conns)) excluded <- names(conns)[!conns_exist] conns <- conns[conns_exist] if(length(excluded) > 0){ From 130bed6f4b3d1dcb6a03b6fa122d359fdfe09f82 Mon Sep 17 00:00:00 2001 From: Tim Cadman Date: Wed, 5 Jun 2024 14:19:21 +0000 Subject: [PATCH 15/20] fix: remove browser --- R/get-stats.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/get-stats.R b/R/get-stats.R index 672a547..2e8675a 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -69,7 +69,6 @@ dh.getStats <- function(df = NULL, vars = NULL, digits = 2, conns = NULL, ################################################################################ # 1. First checks ################################################################################ - browser() if (is.null(df)) { stop("`df` must not be NULL.", call. = FALSE) } From 61188607ce2ba2c813f07d02d07a7d019bf2a3d8 Mon Sep 17 00:00:00 2001 From: Tim Cadman Date: Wed, 5 Jun 2024 14:32:01 +0000 Subject: [PATCH 16/20] chore: updated tests because dplyr message changed --- tests/testthat/test-lm-tab.R | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-lm-tab.R b/tests/testthat/test-lm-tab.R index 9b4a935..72ddff5 100644 --- a/tests/testthat/test-lm-tab.R +++ b/tests/testthat/test-lm-tab.R @@ -112,9 +112,7 @@ ipd_rename_not_expected <- ipd_rename_expected %>% test_that("rename_ipd throws error if provided incorrect variable names", { expect_error( - rename_ipd(ipd_rename_not_expected), - "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", - fixed = TRUE + rename_ipd(ipd_rename_not_expected) ) }) @@ -209,7 +207,7 @@ slma_rename_not_expected <- slma_rename_expected %>% test_that("rename_glm_slma throws error if provided incorrect variable names", { expect_error( rename_glm_slma(slma_rename_not_expected), - "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -274,7 +272,7 @@ lmer_rename_not_expected <- lmer_rename_expected %>% test_that("rename_lmer_slma throws error if provided incorrect variable names", { expect_error( rename_lmer_slma(lmer_rename_not_expected), - "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -389,7 +387,7 @@ pooled_rename_not_expected <- pooled_rename_expected %>% test_that("rename_slma_pooled throws error if provided incorrect variable names", { expect_error( rename_slma_pooled(pooled_rename_not_expected), - "Can't select columns that don't exist.\n✖ Column `variable` doesn't exist.", + "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) From 9ccc10c412919daa72a7cd48494d93ffa5aeb857 Mon Sep 17 00:00:00 2001 From: Tim Cadman Date: Wed, 5 Jun 2024 14:32:10 +0000 Subject: [PATCH 17/20] chore: added arrow to dependencies --- DESCRIPTION | 3 ++- NAMESPACE | 1 + R/get-stats.R | 1 + man/dh.pool.Rd | 4 ++-- 4 files changed, 6 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c9d094a..08c03e2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -34,7 +34,8 @@ Imports: metafor, checkmate, lme4, - tidyselect + tidyselect, + arrow (>= 16.1.0) Suggests: knitr, rmarkdown, diff --git a/NAMESPACE b/NAMESPACE index c55b0ba..a1330e1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,7 @@ export(dh.subjHasData) export(dh.tidyEnv) export(dh.trimPredData) export(dh.zByGroup) +import(arrow) import(lme4) importFrom(DSI,datashield.aggregate) importFrom(DSI,datashield.assign) diff --git a/R/get-stats.R b/R/get-stats.R index 2e8675a..5ffc7c1 100644 --- a/R/get-stats.R +++ b/R/get-stats.R @@ -59,6 +59,7 @@ #' @importFrom magrittr %<>% #' @importFrom DSI datashield.connections_find datashield.aggregate #' @importFrom utils capture.output +#' @import arrow #' #' @md #' diff --git a/man/dh.pool.Rd b/man/dh.pool.Rd index 2d0c607..bbeb706 100644 --- a/man/dh.pool.Rd +++ b/man/dh.pool.Rd @@ -36,7 +36,7 @@ A tibble containing Rubin's pooled estimates and confidence intervals. Perform Rubin's pooling on a list of imputed generalized linear models. } \details{ -This function performs Rubin's pooling on a list of imputed generalized linear models. -It extracts coefficients using specified parameters, tidies the coefficients, and then performs +This function performs Rubin's pooling on a list of imputed generalized linear models. +It extracts coefficients using specified parameters, tidies the coefficients, and then performs pooling. } From 676815eccc1f44356ddf3beb71b13bc5b2303fac Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Wed, 12 Jun 2024 16:52:54 +0200 Subject: [PATCH 18/20] test: made tests less sensitive to dplyr version --- tests/testthat/test-lm-tab.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/tests/testthat/test-lm-tab.R b/tests/testthat/test-lm-tab.R index 72ddff5..4683861 100644 --- a/tests/testthat/test-lm-tab.R +++ b/tests/testthat/test-lm-tab.R @@ -207,7 +207,6 @@ slma_rename_not_expected <- slma_rename_expected %>% test_that("rename_glm_slma throws error if provided incorrect variable names", { expect_error( rename_glm_slma(slma_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -272,7 +271,6 @@ lmer_rename_not_expected <- lmer_rename_expected %>% test_that("rename_lmer_slma throws error if provided incorrect variable names", { expect_error( rename_lmer_slma(lmer_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) @@ -387,7 +385,6 @@ pooled_rename_not_expected <- pooled_rename_expected %>% test_that("rename_slma_pooled throws error if provided incorrect variable names", { expect_error( rename_slma_pooled(pooled_rename_not_expected), - "Can't subset columns that don't exist.\n✖ Column `variable` doesn't exist.", fixed = TRUE ) }) From 624a968e19236e8f4c39e4ddb0becc318d94c83c Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Wed, 12 Jun 2024 17:00:34 +0200 Subject: [PATCH 19/20] docs: bumped versio number and redocumented --- DESCRIPTION | 4 +- docs/404.html | 18 +- docs/ISSUE_TEMPLATE.html | 12 +- docs/PULL_REQUEST_TEMPLATE.html | 34 +- docs/articles/TROUBLESHOOTING.html | 30 +- docs/articles/ds-helper-main-vignette.html | 192 ++++++--- .../ds-helper-trajectories-vignette.html | 385 +++++++++++++----- docs/articles/index.html | 20 +- docs/authors.html | 23 +- .../bootstrap-5.3.1/bootstrap.bundle.min.js | 7 + .../bootstrap.bundle.min.js.map | 1 + docs/deps/bootstrap-5.3.1/bootstrap.min.css | 5 + docs/deps/data-deps.txt | 4 +- docs/index.html | 18 +- docs/pkgdown.js | 8 +- docs/pkgdown.yml | 8 +- docs/reference/dh.anyData.html | 12 +- docs/reference/dh.buildModels.html | 18 +- docs/reference/dh.classDiscrepancy.html | 17 +- docs/reference/dh.columnCast.html | 12 +- docs/reference/dh.createTableOne.html | 44 +- docs/reference/dh.defineCases.html | 17 +- docs/reference/dh.dropCols.html | 12 +- docs/reference/dh.findVarsIndex.html | 12 +- docs/reference/dh.getAnonPlotData.html | 17 +- docs/reference/dh.getRmStats.html | 17 +- docs/reference/dh.getStats.html | 12 +- docs/reference/dh.lmTab.html | 19 +- docs/reference/dh.lmeMultPoly.html | 17 +- docs/reference/dh.localProxy.html | 12 +- docs/reference/dh.makeAgePolys.html | 17 +- docs/reference/dh.makeExcludedDf.html | 22 +- docs/reference/dh.makeIQR.html | 16 +- docs/reference/dh.makeLmerForm.html | 12 +- docs/reference/dh.makeStrata.html | 17 +- docs/reference/dh.meanByGroup.html | 12 +- docs/reference/dh.metaManual.html | 12 +- docs/reference/dh.metaSepModels.html | 26 +- docs/reference/dh.multGLM.html | 12 +- docs/reference/dh.pool.html | 128 ++++++ docs/reference/dh.predictLmer.html | 14 +- docs/reference/dh.quartileSplit.html | 12 +- docs/reference/dh.renameVars.html | 12 +- docs/reference/dh.stablisedWeights.html | 12 +- docs/reference/dh.subjHasData.html | 12 +- docs/reference/dh.tidyEnv.html | 12 +- docs/reference/dh.trimPredData.html | 12 +- docs/reference/dh.zByGroup.html | 18 +- docs/reference/dot-onLoad.html | 12 +- docs/reference/dsHelper-defunct.html | 24 +- docs/reference/extract.html | 12 +- docs/reference/index.html | 38 +- docs/reference/isDefined.html | 12 +- docs/search.json | 2 +- docs/sitemap.xml | 3 + 55 files changed, 945 insertions(+), 543 deletions(-) create mode 100644 docs/deps/bootstrap-5.3.1/bootstrap.bundle.min.js create mode 100644 docs/deps/bootstrap-5.3.1/bootstrap.bundle.min.js.map create mode 100644 docs/deps/bootstrap-5.3.1/bootstrap.min.css create mode 100644 docs/reference/dh.pool.html diff --git a/DESCRIPTION b/DESCRIPTION index 08c03e2..5e7894b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: dsHelper Type: Package Title: Helper Functions for Use with 'DataSHIELD' -Version: 1.4 +Version: 1.5 Description: Often we need to automate things with 'DataSHIELD'. These functions help to do that. Authors@R: c(person(given= "Tim", @@ -50,4 +50,4 @@ BugReports: https://github.com/lifecycle-project/ds-helper/issues/ VignetteBuilder: knitr License: GPL-3 Encoding: UTF-8 -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 diff --git a/docs/404.html b/docs/404.html index 1b089bc..c8a3598 100644 --- a/docs/404.html +++ b/docs/404.html @@ -7,10 +7,10 @@ Page not found (404) • dsHelper - - + + - + NA • dsHelperNA • dsHelper Skip to contents -