From 1db16c7c55b70ad0a978bdcda15951a0cff064b9 Mon Sep 17 00:00:00 2001 From: Brandon LeBeau Date: Tue, 27 Feb 2024 13:59:13 -0600 Subject: [PATCH] Revert "Merge branch 'mult-equation'" This reverts commit 5d0f096e834a3d51c35addc9da1de2e44c56145a, reversing changes made to b34a245a27d0154db514f613bbf9042ade619505. --- DESCRIPTION | 4 +- R/data_reg.r | 167 +-------------------------- R/fixef_sim.r | 13 +-- R/parse_formula.r | 43 +++---- R/pow_sim.r | 24 ++-- R/util.r | 15 +-- man/simglm-package.Rd | 1 + tests/testthat/test_mult-equations.r | 41 ------- 8 files changed, 37 insertions(+), 271 deletions(-) delete mode 100644 tests/testthat/test_mult-equations.r diff --git a/DESCRIPTION b/DESCRIPTION index 50dd3cc..87a0a96 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: simglm Type: Package Authors@R: person("Brandon", "LeBeau", email = "lebebr01+simglm@gmail.com", role = c("aut", "cre")) -Version: 0.9.14 +Version: 0.9.13 Date: 2023-01-19 License: MIT + file LICENSE Title: Simulate Models Based on the Generalized Linear Model @@ -38,7 +38,7 @@ Suggests: covr VignetteBuilder: knitr Encoding: UTF-8 -RoxygenNote: 7.3.1 +RoxygenNote: 7.2.3 Author: Brandon LeBeau [aut, cre] Maintainer: Brandon LeBeau URL: https://github.com/lebebr01/simglm diff --git a/R/data_reg.r b/R/data_reg.r index 925cbb2..7818cb5 100644 --- a/R/data_reg.r +++ b/R/data_reg.r @@ -16,162 +16,6 @@ #' @export generate_response <- function(data, sim_args, keep_intermediate = TRUE, ...) { - if(is.list(sim_args[['formula']])) { - gen_data <- lapply(seq_along(sim_args[['formula']]), function(xx) - generate_response_list(data = data, sim_args = sim_args, - formula = sim_args[['formula']][[xx]], - reg_weights = sim_args[['reg_weights']][[xx]], - keep_intermediate = keep_intermediate, ...)) - - outcome_names <- unlist(lapply(seq_along(parse_formula(sim_args)), function(xx) - parse_formula(sim_args)[[xx]][['outcome']])) - outcome_data <- data.frame(do.call('cbind', lapply(seq_along(outcome_names)[2:length(outcome_names)], function(xx) - gen_data[[xx]][[outcome_names[xx]]]))) - names(outcome_data) <- outcome_names[2:length(outcome_names)] - cbind.data.frame(gen_data[[1]], outcome_data) - } else { - generate_response_one(data = data, sim_args = sim_args, - keep_intermediate = keep_intermediate, - ...) - } - -} - -generate_response_list <- function(data, sim_args, formula, reg_weights, - keep_intermediate = TRUE, ...) { - outcome_name <- as.character(formula)[2] - outcome_type <- sim_args[['outcome_type']] - fixed_formula <- as.formula(paste0("~", gsub("^\\s+|\\s+$", "", - gsub("\\+\\s*(\\s+|\\++)\\(.*?\\)", "", - as.character(formula)[3])))) - - fixed_vars <- attr(terms(fixed_formula),"term.labels") - - if(any(grepl('^factor\\(', fixed_vars))) { - fixed_vars <- gsub("factor\\(|\\)$", "", fixed_vars) - } - if(any(grepl('^ns\\(', fixed_vars))) { - fixed_vars <- gsub("ns\\(|\\,.+\\)$", "", fixed_vars) - } - if(any(grepl("^poly\\(", fixed_vars))) { - fixed_vars <- gsub("poly\\(|\\,.+\\)", "", fixed_vars) - } - - if(any(grepl("^ns|^poly", attr(terms(fixed_formula), "term.labels")))) { - fixed_vars <- poly_ns_names(sim_args) - } - - if(any(unlist(lapply(seq_along(sim_args[['fixed']]), function(xx) - sim_args[['fixed']][[xx]]$var_type)) == 'factor')) { - - num_levels <- lapply(seq_along(sim_args[['fixed']]), function(xx) - sim_args[['fixed']][[xx]][['levels']]) - num_levels <- purrr::modify_if(num_levels, is.character, length) - - if(any(unlist(lapply(seq_along(sim_args[['fixed']]), function(xx) - num_levels[[xx]] > 1 & - sim_args[['fixed']][[xx]][['var_type']] == 'factor')) - )) { - fixed_vars <- factor_names(sim_args, fixed_vars) - } - } - - if(any(grepl(':', fixed_vars))) { - fixed_vars <- gsub(":", "\\.", fixed_vars) - } - - # Xmat <- model.matrix(fixed_formula, data.frame(data), contrasts.arg = contrasts) - Xmat <- dplyr::select(data, dplyr::all_of(fixed_vars)) - if(any(grepl('Intercept', names(data)))) { - Xmat <- cbind(data['X.Intercept.'], Xmat) - } - - fixed_outcome <- as.matrix(Xmat) %*% reg_weights - - - if(length(parse_formula(sim_args)[['randomeffect']]) != 0) { - random_formula <- parse_formula(sim_args)[['randomeffect']] - random_formula_parsed <- parse_randomeffect(random_formula) - random_effects_names <- names(sim_args[['randomeffect']]) - - random_formula <- lapply(seq_along(random_formula_parsed[['random_effects']]), function(xx) - as.formula(random_formula_parsed[['random_effects']][xx])) - - Zmat <- lapply(lapply(random_formula, model.matrix, data = data), - data.frame) - - multiple_member <- parse_multiplemember(sim_args, parse_randomeffect(parse_formula(sim_args)[['randomeffect']])) - if(any(multiple_member[['multiple_member_re']])){ - Zmat <- do.call('cbind', Zmat) - } else { - Zmat <- dplyr::bind_cols(Zmat) - } - - rand_effects <- subset(data, select = random_effects_names) - - random_effects <- rowSums(rand_effects * Zmat) - } else { - random_effects <- NULL - random_effects <- 0 - } - - if(keep_intermediate) { - if(is.list(sim_args[['reg_weights']])) { - response_outcomes <- data.frame( - fixed_outcome, - random_effects = random_effects - ) - } else { - response_outcomes <- data.frame( - fixed_outcome = fixed_outcome, - random_effects = random_effects - ) - } - - data <- cbind(data, response_outcomes, row.names = NULL) - } - - if(is.null(data[['error']])) { - data['error'] <- 0 - } - - outcome <- fixed_outcome + random_effects + data[['error']] - - if(!is.null(sim_args[['outcome_type']])){ - if(is.null(sim_args[['multinomial_categories']])) { - multinomial_categories <- NULL - } else { - multinomial_categories <- sim_args[['multinomial_categories']] - } - trans_outcome <- transform_outcome(outcome, - type = sim_args[['outcome_type']], - categories = multinomial_categories) - if(ncol(outcome) > 1) { - names(outcome) <- paste0('untransformed_outcome', 1:ncol(outcome)) - data <- cbind(data, outcome) - } else { - data <- cbind(data, untransformed_outcome = outcome) - } - if(sim_args[['outcome_type']] == 'multinomial') { - data <- cbind(data, trans_outcome) - if(is.null(multinomial_categories)) { - names(data)[names(data) == 'outcome_num'] <- outcome_name - } else { - names(data)[names(data) == 'outcome_category'] <- outcome_name - } - } else { - data[outcome_name] <- trans_outcome - } - } else { - data[outcome_name] <- outcome - } - - data -} - - -generate_response_one <- function(data, sim_args, keep_intermediate = TRUE, ...) { - outcome_name <- parse_formula(sim_args)[['outcome']] outcome_type <- sim_args[['outcome_type']] fixed_formula <- parse_formula(sim_args)[['fixed']] @@ -219,9 +63,9 @@ generate_response_one <- function(data, sim_args, keep_intermediate = TRUE, ...) if(is.list(sim_args[['reg_weights']])) { fixed_outcome <- data.frame(do.call("cbind", - lapply(seq_along(sim_args[['reg_weights']]), - function(xx) - as.matrix(Xmat) %*% sim_args[['reg_weights']][[xx]]))) + lapply(seq_along(sim_args[['reg_weights']]), + function(xx) + as.matrix(Xmat) %*% sim_args[['reg_weights']][[xx]]))) names(fixed_outcome) <- paste0('logit', 1:ncol(fixed_outcome)) } else { fixed_outcome <- as.matrix(Xmat) %*% sim_args[['reg_weights']] @@ -236,7 +80,7 @@ generate_response_one <- function(data, sim_args, keep_intermediate = TRUE, ...) as.formula(random_formula_parsed[['random_effects']][xx])) Zmat <- lapply(lapply(random_formula, model.matrix, data = data), - data.frame) + data.frame) multiple_member <- parse_multiplemember(sim_args, parse_randomeffect(parse_formula(sim_args)[['randomeffect']])) if(any(multiple_member[['multiple_member_re']])){ @@ -305,5 +149,4 @@ generate_response_one <- function(data, sim_args, keep_intermediate = TRUE, ...) } data - -} \ No newline at end of file +} diff --git a/R/fixef_sim.r b/R/fixef_sim.r index ed44ab0..c1d77f9 100644 --- a/R/fixef_sim.r +++ b/R/fixef_sim.r @@ -290,18 +290,7 @@ sim_variable <- function(var_type = c("continuous", "factor", "ordinal", #' @export simulate_fixed <- function(data, sim_args, ...) { - if(is.null(parse_formula(sim_args)[['fixed']])) { - list_formula <- parse_formula(sim_args) - fixed_list <- lapply(seq_along(list_formula), function(xx) - as.character(list_formula[[xx]][['fixed']])) - if(comp_list(fixed_list)) { - fixed_formula <- list_formula[[1]][['fixed']] - } else { - NULL - } - } else { - fixed_formula <- parse_formula(sim_args)[['fixed']] - } + fixed_formula <- parse_formula(sim_args)[['fixed']] fixed_vars <- attr(terms(fixed_formula), "term.labels") diff --git a/R/parse_formula.r b/R/parse_formula.r index 4f99b12..84d996c 100644 --- a/R/parse_formula.r +++ b/R/parse_formula.r @@ -13,30 +13,16 @@ #' @export parse_formula <- function(sim_args) { - if(is.list(sim_args[['formula']])) { - parse_formula_list(sim_args) - } else { - outcome <- as.character(sim_args[['formula']])[2] - - fixed <- as.formula(paste0("~", gsub("^\\s+|\\s+$", "", gsub("\\+\\s*(\\s+|\\++)\\(.*?\\)", "", as.character(sim_args[['formula']])[3])))) - - randomeffect <- gsub("^\\s+|\\s+$", "", unlist(regmatches(as.character(sim_args[['formula']])[3], - gregexpr("(\\+|\\s+)\\(.*?\\)", as.character(sim_args[['formula']])[3])))) - - list(outcome = outcome, - fixed = fixed, - randomeffect = randomeffect) - } -} - -parse_formula_list <- function(sim_args) { - - lapply(seq_along(sim_args[['formula']]), function(xx) - list(outcome = as.character(sim_args[['formula']][[xx]])[2], - fixed = as.formula(paste0("~", gsub("^\\s+|\\s+$", "", gsub("\\+\\s*(\\s+|\\++)\\(.*?\\)", "", as.character(sim_args[['formula']][[xx]])[3])))), - randomeffect = gsub("^\\s+|\\s+$", "", unlist(regmatches(as.character(sim_args[['formula']][[xx]])[3], - gregexpr("(\\+|\\s+)\\(.*?\\)", as.character(sim_args[['formula']][[xx]])[3])))) - )) + outcome <- as.character(sim_args[['formula']])[2] + + fixed <- as.formula(paste0("~", gsub("^\\s+|\\s+$", "", gsub("\\+\\s*(\\s+|\\++)\\(.*?\\)", "", as.character(sim_args[['formula']])[3])))) + + randomeffect <- gsub("^\\s+|\\s+$", "", unlist(regmatches(as.character(sim_args[['formula']])[3], + gregexpr("(\\+|\\s+)\\(.*?\\)", as.character(sim_args[['formula']])[3])))) + + list(outcome = outcome, + fixed = fixed, + randomeffect = randomeffect) } #' Parses random effect specification @@ -165,12 +151,21 @@ parse_power <- function(sim_args, samp_size) { lower.tail = lower_tail[ii], df = df[[xx]], !!!opts[ii]) + # purrr::invoke(stat_dist[ii], + # p = alpha[ii], + # lower.tail = lower_tail[ii], + # df = df[[xx]], + # opts[ii]) }) } else { purrr::exec(stat_dist[ii], p = alpha[ii], lower.tail = lower_tail[ii], !!!opts[ii]) + # purrr::invoke(stat_dist[ii], + # p = alpha[ii], + # lower.tail = lower_tail[ii], + # opts[ii]) } } ) diff --git a/R/pow_sim.r b/R/pow_sim.r index bc9eb3e..bc3f429 100644 --- a/R/pow_sim.r +++ b/R/pow_sim.r @@ -156,16 +156,16 @@ replicate_simulation_vary <- function(sim_args, return_list = FALSE, sim_arguments <- parse_varyarguments(sim_args) + simulation_out <- future.apply::future_lapply(seq_along(sim_arguments), function(xx) { + future.apply::future_replicate(sim_arguments[[xx]][['replications']], + simglm(sim_arguments[[xx]]), + simplify = FALSE, + future.seed = future.seed) + }, future.seed = future.seed) + if(length(within_conditions_name) > 0) { sim_arguments_w <- parse_varyarguments_w(sim_args, name = c('model_fit')) - simulation_out <- future.apply::future_lapply(seq_along(sim_arguments), function(xx) { - future.apply::future_replicate(sim_arguments[[xx]][['replications']], - simglm(sim_arguments[[xx]]), - simplify = FALSE, - future.seed = future.seed) - }, future.seed = future.seed) - power_out <- future.apply::future_lapply(seq_along(simulation_out), function(xx) { future.apply::future_lapply(seq_along(simulation_out[[xx]]), function(yy) { future.apply::future_lapply(seq_along(sim_arguments_w), function(zz) { @@ -176,15 +176,7 @@ replicate_simulation_vary <- function(sim_args, return_list = FALSE, }, future.seed = future.seed) } if(length(within_conditions_name) == 0) { - - power_out <- future.apply::future_lapply(seq_along(sim_arguments), function(xx) { - future.apply::future_replicate(sim_arguments[[xx]][['replications']], - simglm_modelfit( - simglm(sim_arguments[[xx]]), - sim_arguments[[xx]]), - simplify = FALSE, - future.seed = future.seed) - }, future.seed = future.seed) + power_out <- simulation_out } diff --git a/R/util.r b/R/util.r index d9b58d6..7d55d73 100644 --- a/R/util.r +++ b/R/util.r @@ -4,8 +4,6 @@ is_odd <- function(x) x %% 2 != 0 whole_number <- function(x) x %% 1 == 0 -comp_list <- function(x) length(unique.default(x)) == 1L - prop_limits <- function(prop) { if(prop > .5) { u_diff <- 1 - prop @@ -271,18 +269,7 @@ reorder_names <- function(names) { poly_ns_names <- function(sim_args) { - if(is.null(parse_formula(sim_args)[['fixed']])) { - list_formula <- parse_formula(sim_args) - fixed_list <- lapply(seq_along(list_formula), function(xx) - as.character(list_formula[[xx]][['fixed']])) - if(comp_list(fixed_list)) { - fixed_formula <- list_formula[[1]][['fixed']] - } else { - NULL - } - } else { - fixed_formula <- parse_formula(sim_args)[['fixed']] - } + fixed_formula <- parse_formula(sim_args)[['fixed']] fixed_vars <- attr(terms(fixed_formula), "term.labels") diff --git a/man/simglm-package.Rd b/man/simglm-package.Rd index 5eb38f4..851255b 100644 --- a/man/simglm-package.Rd +++ b/man/simglm-package.Rd @@ -3,6 +3,7 @@ \docType{package} \name{simglm-package} \alias{simglm-package} +\alias{_PACKAGE} \title{simglm: Simulate Models Based on the Generalized Linear Model} \description{ Simulates regression models, including both simple regression and generalized linear mixed models with up to three level of nesting. Power simulations that are flexible allowing the specification of missing data, unbalanced designs, and different random error distributions are built into the package. diff --git a/tests/testthat/test_mult-equations.r b/tests/testthat/test_mult-equations.r deleted file mode 100644 index 4f476f8..0000000 --- a/tests/testthat/test_mult-equations.r +++ /dev/null @@ -1,41 +0,0 @@ -context("multiple equations") - -test_that('mutiple equations different outcome', { - set.seed(1212) - - sim_arguments <- list( - formula = list( - symp_post ~ symp_pre + treatment, - symp_followup ~ symp_pre + treatment - ), - fixed = list( - symp_pre = list(var_type = 'continuous', - mean = 0, sd = 1), - treatment = list(var_type = 'factor', - levels = c('control', 'treatment')) - ), - error = list(variance = 1), - sample_size = 100, - reg_weights = list( - c(0, -0.5, -0.25), - c(0, -0.5, 50) - ) - ) - - symp_data <- simulate_fixed(data = NULL, sim_arguments) |> - simulate_error(sim_arguments) |> - generate_response(sim_arguments) - - expect_equal(ncol(symp_data), 10) - expect_equal(nrow(symp_data), 100) - expect_equal(mean(symp_data[symp_data$treatment == 'control', 'symp_post']), - mean(symp_data[symp_data$treatment == 'control', 'symp_followup'])) - expect_gt(mean(symp_data[symp_data$treatment == 'treatment', 'symp_followup']), - mean(symp_data[symp_data$treatment == 'treatment', 'symp_post'])) - expect_gt(mean(symp_data[symp_data$treatment == 'treatment', 'symp_followup']), - mean(symp_data[symp_data$treatment == 'control', 'symp_followup'])) - expect_lt(mean(symp_data[symp_data$treatment == 'treatment', 'symp_post']), - mean(symp_data[symp_data$treatment == 'control', 'symp_post'])) - -}) -