Skip to content

Commit

Permalink
Revert "Merge branch 'mult-equation'"
Browse files Browse the repository at this point in the history 
This reverts commit 5d0f096, reversing
changes made to b34a245.
  • Loading branch information
@lebebr01
lebebr01 committed Feb 27, 2024
1 parent 5d0f096 commit 1db16c7
Show file tree
Hide file tree
Showing 8 changed files with 37 additions and 271 deletions.
4 changes: 2 additions & 2 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ Package: simglm
Type: Package
Authors@R: person("Brandon", "LeBeau", email = "[email protected]",
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
Expand Down Expand Up @@ -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 <[email protected]>
URL: https://github.com/lebebr01/simglm
Expand Down
167 changes: 5 additions & 162 deletions R/data_reg.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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']]
Expand Down Expand Up @@ -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']]
Expand All @@ -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']])){
Expand Down Expand Up @@ -305,5 +149,4 @@ generate_response_one <- function(data, sim_args, keep_intermediate = TRUE, ...)
}

data

}
}
13 changes: 1 addition & 12 deletions R/fixef_sim.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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")

Expand Down
43 changes: 19 additions & 24 deletions R/parse_formula.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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])
}
}
)
Expand Down
24 changes: 8 additions & 16 deletions R/pow_sim.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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) {
Expand All @@ -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
}


Expand Down
15 changes: 1 addition & 14 deletions R/util.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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")

Expand Down
1 change: 1 addition & 0 deletions man/simglm-package.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading

0 comments on commit 1db16c7

Please sign in to comment.