Add option to pull coef() instead of ranef() for random effects #1068
There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,196 @@ | ||
| .group_level_total <- function(x, ...) { | ||
| UseMethod(".group_level_total") | ||
| } | ||
|
|
||
|
|
||
| .group_level_total.glmmTMB <- function(x, ...) { | ||
| params <- suppressWarnings(insight::compact_list(stats::coef(x))) | ||
| params_cond <- params$cond | ||
| params_zi <- params$zi | ||
|
|
||
| # handle random effects in conditional component | ||
| if (!is.null(params_cond)) { | ||
| # extract levels of group factors | ||
| group_levels <- insight::compact_list(lapply( | ||
| x$modelInfo$reTrms$cond$flist, | ||
| levels | ||
| )) | ||
| # extract names of slopes | ||
| slope_names <- insight::compact_list(x$modelInfo$reTrms$cond$cnms) | ||
| # reshape "coef()" data | ||
| params_cond <- .reshape_group_level_coefficients( | ||
| x, | ||
| params = params_cond, | ||
| group_levels = group_levels, | ||
| slope_names = slope_names | ||
| ) | ||
| params_cond$Component <- "conditional" | ||
| } | ||
|
|
||
| # handle random effects in zero-inflation component | ||
| if (!is.null(params_zi)) { | ||
| # extract levels of group factors | ||
| group_levels <- insight::compact_list(lapply( | ||
| x$modelInfo$reTrms$zi$flist, | ||
| levels | ||
| )) | ||
| # extract names of slopes | ||
| slope_names <- insight::compact_list(x$modelInfo$reTrms$zi$cnms) | ||
| # reshape "coef()" data | ||
| params_zi <- .reshape_group_level_coefficients( | ||
| x, | ||
| params = params_zi, | ||
| group_levels = group_levels, | ||
| slope_names = slope_names, | ||
| component = "zero_inflated_random" | ||
| ) | ||
| params_zi$Component <- "zero_inflated" | ||
| } | ||
|
|
||
| # create list of data frames | ||
| out <- insight::compact_list(list(params_cond, params_zi)) | ||
|
|
||
| if (length(out) == 1) { | ||
| # unlist if only one component | ||
| out <- out[[1]] | ||
| } else { | ||
| # else, join - we can't use rbind() here, because column | ||
| # names do not necessarily match | ||
| out <- datawizard::data_join(out, join = "bind") | ||
| } | ||
|
|
||
| rownames(out) <- NULL | ||
| out | ||
| } | ||
|
|
||
|
|
||
| .group_level_total.merMod <- function(x, ...) { | ||
| params <- suppressWarnings(stats::coef(x)) | ||
|
|
||
| # extract levels of group factors | ||
| group_levels <- insight::compact_list(lapply(methods::slot(x, "flist"), levels)) | ||
| # extract names of slopes | ||
| slope_names <- insight::compact_list(methods::slot(x, "cnms")) | ||
| # reshape "coef()" data | ||
| params <- .reshape_group_level_coefficients( | ||
| x, | ||
| params = params, | ||
| group_levels = group_levels, | ||
| slope_names = slope_names | ||
| ) | ||
|
|
||
| params | ||
| } | ||
|
|
||
|
|
||
| .group_level_total.brmsfit <- function(x, ...) { | ||
| # extract random effects information | ||
| group_factors <- insight::find_random(x, split_nested = TRUE, flatten = TRUE) | ||
| random_slopes <- insight::find_random_slopes(x) | ||
| params <- NULL | ||
|
|
||
| # create full data frame of all random effects retrieved from coef() | ||
| params <- do.call(rbind, lapply(group_factors, function(i) { | ||
| # we want the posterior distribution from coef(), so we can | ||
| # use bayestestR | ||
| ranef <- stats::coef(x, summary = FALSE)[[i]] | ||
| parameter_names <- dimnames(ranef)[[3]] | ||
| out <- lapply( | ||
| parameter_names, | ||
| function(pn) { | ||
| # summary of posterior | ||
| d <- bayestestR::describe_posterior(as.data.frame(ranef[, , pn]), verbose = FALSE, ...) | ||
| # add information about group factor and levels | ||
| d$Group <- i | ||
| # Parameters in the returned data frame are actually the levels | ||
| # # from the group factors | ||
| d$Level <- d$Parameter | ||
| # the parameter names can be taken from dimnames | ||
| d$Parameter <- pn | ||
| d | ||
| } | ||
| ) | ||
| names(out) <- parameter_names | ||
| do.call(rbind, out) | ||
| })) | ||
|
|
||
| # select parameters to keep. We want all intercepts, and all random slopes | ||
| # from conditional and potential zero-inflation component | ||
| parameters_to_keep <- params$Parameter %in% c("Intercept", random_slopes$random) | ||
| parameters_to_keep <- parameters_to_keep | params$Parameter %in% c("zi_Intercept", random_slopes$zero_inflated_random) | ||
| # furthermore, categorical random slopes have levels in their name, so we | ||
| # try to find those parameters here, too | ||
| if (!is.null(random_slopes$random)) { | ||
| parameters_to_keep <- parameters_to_keep | startsWith(params$Parameter, random_slopes$random) | ||
| } | ||
| if (!is.null(random_slopes$zero_inflated_random)) { | ||
| parameters_to_keep <- parameters_to_keep | startsWith(params$Parameter, paste0("zi_", random_slopes$zero_inflated_random)) | ||
| } | ||
|
|
||
| # add Component column | ||
| params$Component <- "conditional" | ||
| params$Component[startsWith(params$Parameter, "zi_")] <- "zero_inflated" | ||
|
|
||
| # clean names | ||
| params$Parameter <- gsub("^zi_", "", params$Parameter) | ||
| rownames(params) <- NULL | ||
|
|
||
| # make sure first columns are group and level | ||
| datawizard::data_relocate(params[parameters_to_keep, ], c("Group", "Level")) | ||
| } | ||
|
|
||
|
|
||
| # helper ---------------------------------------------------------------------- | ||
|
|
||
| .reshape_group_level_coefficients <- function(x, | ||
| params, | ||
| group_levels, | ||
| slope_names = NULL, | ||
| component = "random") { | ||
| group_factors <- insight::find_random(x) | ||
| random_slopes <- insight::find_random_slopes(x) | ||
|
|
||
| # find all columns for which we can add fixed and random effects | ||
| cols <- c(random_slopes[[component]], "(Intercept)") | ||
|
|
||
| # iterate all random effects, add group name and levels | ||
| for (i in group_factors[[component]]) { | ||
| # overwrite cols? if random slopes are factors, the names are | ||
| # not the variable names, but name + factor level, so we need | ||
| # to upate the columns to select here | ||
| if (!is.null(slope_names) && length(slope_names)) { | ||
| cols <- slope_names[[i]] | ||
| } | ||
| # select columns | ||
| params[[i]] <- params[[i]][cols] | ||
| # add information about group factor and levels | ||
| params[[i]]$Group <- i | ||
| params[[i]]$Level <- group_levels[[i]] | ||
| } | ||
|
|
||
| # if only one component, unlist | ||
| if (length(params) == 1) { | ||
| out <- params[[1]] | ||
| } else { | ||
| # else, join - we can't use rbind() here, because column | ||
| # names do not necessarily match | ||
| class(params) <- "list" | ||
| out <- datawizard::data_join(params, join = "bind") | ||
| } | ||
|
|
||
| # reshape | ||
| to_reshape <- setdiff(colnames(out), c("Group", "Level")) | ||
| out <- datawizard::reshape_longer(out, select = to_reshape) | ||
|
|
||
| # rename | ||
| out <- datawizard::data_rename( | ||
| out, | ||
| select = c(Parameter = "name", Coefficient = "value") | ||
| ) | ||
|
|
||
| # make sure first columns are group and level | ||
| out <- datawizard::data_relocate(out, c("Group", "Level")) | ||
|
|
||
| # remove those without valid values | ||
| out[stats::complete.cases(out), ] | ||
| } | ||
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Oops, something went wrong.
Oops, something went wrong.
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
Uh oh!
There was an error while loading. Please reload this page.