Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Support for svy2lme #985

Merged
merged 10 commits into from
Jun 30, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 3 additions & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Type: Package
Package: parameters
Title: Processing of Model Parameters
Version: 0.22.0
Version: 0.22.0.1
Authors@R:
c(person(given = "Daniel",
family = "Lüdecke",
Expand Down Expand Up @@ -197,6 +197,7 @@ Suggests:
sparsepca,
survey,
survival,
svylme,
testthat (>= 3.2.1),
tidyselect,
tinytable (>= 0.1.0),
Expand All @@ -215,3 +216,4 @@ Config/testthat/edition: 3
Config/testthat/parallel: true
Config/Needs/website: easystats/easystatstemplate
Config/rcmdcheck/ignore-inconsequential-notes: true
Remotes: easystats/insight, easystats/bayestestR
4 changes: 4 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -170,6 +170,7 @@ S3method(degrees_of_freedom,rqss)
S3method(degrees_of_freedom,selection)
S3method(degrees_of_freedom,serp)
S3method(degrees_of_freedom,summary.lm)
S3method(degrees_of_freedom,svy2lme)
S3method(degrees_of_freedom,systemfit)
S3method(degrees_of_freedom,truncreg)
S3method(degrees_of_freedom,vgam)
Expand Down Expand Up @@ -382,6 +383,7 @@ S3method(model_parameters,stanfit)
S3method(model_parameters,stanmvreg)
S3method(model_parameters,stanreg)
S3method(model_parameters,summary_emm)
S3method(model_parameters,svy2lme)
S3method(model_parameters,svyglm)
S3method(model_parameters,svytable)
S3method(model_parameters,systemfit)
Expand Down Expand Up @@ -536,6 +538,7 @@ S3method(p_value,speedlm)
S3method(p_value,stanreg)
S3method(p_value,summary.lm)
S3method(p_value,survreg)
S3method(p_value,svy2lme)
S3method(p_value,svyglm)
S3method(p_value,svyglm.nb)
S3method(p_value,svyglm.zip)
Expand Down Expand Up @@ -872,6 +875,7 @@ S3method(standard_error,sem)
S3method(standard_error,stanreg)
S3method(standard_error,summary.lm)
S3method(standard_error,survreg)
S3method(standard_error,svy2lme)
S3method(standard_error,svyglm)
S3method(standard_error,svyglm.nb)
S3method(standard_error,svyglm.zip)
Expand Down
6 changes: 6 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
# parameters 0.22.1

## New supported models

* Support for `svy2lme` models from package *svylme*.

# parameters 0.22.0

## Breaking changes
Expand Down
36 changes: 36 additions & 0 deletions R/extract_random_variances.R
Original file line number Diff line number Diff line change
Expand Up @@ -28,7 +28,7 @@

# check for errors
if (is.null(out) && isTRUE(verbose)) {
insight::format_warning("Something went wrong when calculating random effects parameters. Only showing model's fixed effects now. You may use `effects=\"fixed\"` to speed up the call to `model_parameters()`.")

Check warning on line 31 in R/extract_random_variances.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files

file=R/extract_random_variances.R,line=31,col=121,[line_length_linter] Lines should not be more than 120 characters. This line is 213 characters.
}

out
Expand Down Expand Up @@ -108,6 +108,42 @@
.extract_random_variances.MixMod <- .extract_random_variances.glmmTMB


# svy2lme ------------------------

.extract_random_variances.svy2lme <- function(model, ci = 0.95, effects = "random", ...) {
s <- sqrt(as.vector(model$s2))
stdev <- matrix(s * sqrt(diag(model$L)), ncol = 1)
vcnames <- c(paste0("SD (", model$znames, ")"), "SD (Observations)")
grp_names <- names(model$znames)
if (is.null(grp_names)) {
grp_names <- model$znames
}

out <- data.frame(
Parameter = vcnames,
Level = NA,
Coefficient = c(as.vector(stdev), s),
SE = NA,
CI_low = NA,
CI_high = NA,
t = NA,
df_error = NA,
p = NA,
Effects = "random",
Group = c(grp_names, "Residual"),
stringsAsFactors = FALSE
)

# fix intercept names
out$Parameter <- gsub("(Intercept)", "Intercept", out$Parameter, fixed = TRUE)

if (effects == "random") {
out[c("t", "df_error", "p")] <- NULL
}

rownames(out) <- NULL
out
}



Expand Down Expand Up @@ -172,7 +208,7 @@
)

# fix names for uncorrelated slope-intercepts
pattern <- paste0("(", paste0(insight::find_random(model, flatten = TRUE), collapse = "|"), ")\\.\\d+$")

Check warning on line 211 in R/extract_random_variances.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files

file=R/extract_random_variances.R,line=211,col=26,[paste_linter] Use paste(), not paste0(), to collapse a character vector when sep= is not used.
out$Group <- gsub(pattern, "\\1", out$Group)

# remove non-used columns
Expand Down Expand Up @@ -300,7 +336,7 @@

# extract CI for random SD ------------------------

.random_sd_ci <- function(model,

Check warning on line 339 in R/extract_random_variances.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files

file=R/extract_random_variances.R,line=339,col=1,[cyclocomp_linter] Reduce the cyclomatic complexity of this function from 63 to at most 40.
out,
ci_method,
ci, ci_random,
Expand Down
9 changes: 1 addition & 8 deletions R/methods_BayesFactor.R
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,6 @@ model_parameters.BFBayesFactor <- function(model,
es_type = NULL,
include_proportions = FALSE,
verbose = TRUE,
effectsize_type = NULL,
...) {
insight::check_if_installed("BayesFactor")

Expand All @@ -84,12 +83,6 @@ model_parameters.BFBayesFactor <- function(model,
return(NULL)
}

## TODO: remove deprecation warning later
if (!is.null(effectsize_type)) {
insight::format_warning("Argument `effectsize_type` is deprecated. Use `es_type` instead.")
es_type <- effectsize_type
}

out <- bayestestR::describe_posterior(
model,
centrality = centrality,
Expand Down Expand Up @@ -143,12 +136,12 @@ model_parameters.BFBayesFactor <- function(model,
# needs {effectsize} to be installed
insight::check_if_installed("effectsize")

## TODO: add back ci-argument, once effectsize >= 0.7.1 is on CRAN.
tryCatch(
{
effsize <- effectsize::effectsize(model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
rope_ci = rope_ci,
type = es_type,
Expand Down
8 changes: 0 additions & 8 deletions R/methods_aov.R
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,6 @@
#' (e.g., `"g"`, `"l"`, `"two"`...). See section *One-Sided CIs* in
#' the [effectsize_CIs vignette](https://easystats.github.io/effectsize/).
#' @inheritParams model_parameters.default
#' @param effectsize_type Deprecated. Use `es_type` instead.
#' @param ... Arguments passed to [`effectsize::effectsize()`]. For example,
#' to calculate _partial_ effect sizes types, use `partial = TRUE`. For objects
#' of class `htest` or `BFBayesFactor`, `adjust = TRUE` can be used to return
Expand Down Expand Up @@ -110,18 +109,11 @@ model_parameters.aov <- function(model,
drop = NULL,
table_wide = FALSE,
verbose = TRUE,
effectsize_type = NULL,
...) {
# save model object, for later checks
original_model <- model
object_name <- insight::safe_deparse_symbol(substitute(model))

## TODO: remove deprecation warning later
if (!is.null(effectsize_type)) {
insight::format_warning("Argument `effectsize_type` is deprecated. Use `es_type` instead.")
es_type <- effectsize_type
}

if (inherits(model, "aov") && !is.null(type) && type > 1) {
if (requireNamespace("car", quietly = TRUE)) {
model <- car::Anova(model, type = type)
Expand Down
7 changes: 0 additions & 7 deletions R/methods_htest.R
Original file line number Diff line number Diff line change
Expand Up @@ -46,14 +46,7 @@ model_parameters.htest <- function(model,
bootstrap = FALSE,
es_type = NULL,
verbose = TRUE,
effectsize_type = NULL,
...) {
## TODO: remove deprecation warning later
if (!is.null(effectsize_type)) {
insight::format_warning("Argument `effectsize_type` is deprecated. Use `es_type` instead.")
es_type <- effectsize_type
}

if (bootstrap) {
insight::format_error("Bootstrapped h-tests are not yet implemented.")
} else {
Expand Down
7 changes: 0 additions & 7 deletions R/methods_other.R
Original file line number Diff line number Diff line change
Expand Up @@ -41,14 +41,7 @@ model_parameters.Gam <- function(model,
type = NULL,
table_wide = FALSE,
verbose = TRUE,
effectsize_type = NULL,
...) {
## TODO: remove deprecation warning later
if (!is.null(effectsize_type)) {
insight::format_warning("Argument `effectsize_type` is deprecated. Use `es_type` instead.")
es_type <- effectsize_type
}

model_parameters(
summary(model)$parametric.anova,
es_type = es_type,
Expand Down
113 changes: 113 additions & 0 deletions R/methods_svy2lme.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,113 @@
#' @export
model_parameters.svy2lme <- function(model,
ci = 0.95,
effects = "all",
keep = NULL,
drop = NULL,
verbose = TRUE,
include_sigma = FALSE,
...) {
dots <- list(...)
# which component to return?
effects <- match.arg(effects, choices = c("fixed", "random", "all"))
params <- params_variance <- NULL

if (effects %in% c("fixed", "all")) {
# Processing
fun_args <- list(
model,
ci = ci,
ci_method = "wald",
standardize = NULL,
p_adjust = NULL,
wb_component = FALSE,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
include_sigma = include_sigma,
summary = FALSE,
vcov = NULL,
vcov_args = NULL
)
fun_args <- c(fun_args, dots)
params <- do.call(".extract_parameters_mixed", fun_args)

params$Effects <- "fixed"
}

att <- attributes(params)

if (effects %in% c("random", "all")) {
params_variance <- .extract_random_variances(
model,
ci = ci,
effects = effects
)
}

# merge random and fixed effects, if necessary
if (!is.null(params) && !is.null(params_variance)) {
params$Level <- NA
params$Group <- ""
params <- params[match(colnames(params_variance), colnames(params))]
}

params <- rbind(params, params_variance)
# remove empty column
if (!is.null(params$Level) && all(is.na(params$Level))) {
params$Level <- NULL
}

# due to rbind(), we lose attributes from "extract_parameters()",
# so we add those attributes back here...
if (!is.null(att)) {
attributes(params) <- utils::modifyList(att, attributes(params))
}

params <- .add_model_parameters_attributes(
params,
model,
ci = ci,
exponentiate = FALSE,
bootstrap = FALSE,
iterations = 1000,
ci_method = "wald",
p_adjust = NULL,
verbose = verbose,
summary = FALSE,
group_level = FALSE,
wb_component = FALSE,
...
)

attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))

params
}


#' @export
standard_error.svy2lme <- function(model, ...) {
.data_frame(
Parameter = .remove_backticks_from_string(colnames(model$Vbeta)),
SE = as.vector(sqrt(diag(model$Vbeta)))
)
}


#' @export
p_value.svy2lme <- function(model, ...) {
stat <- insight::get_statistic(model)
p <- 2 * stats::pnorm(abs(stat$Statistic), lower.tail = FALSE)
.data_frame(
Parameter = stat$Parameter,
p = as.vector(p)
)
}


#' @export
degrees_of_freedom.svy2lme <- function(model, ...) {
Inf
}
4 changes: 2 additions & 2 deletions R/n_clusters_easystats.R
Original file line number Diff line number Diff line change
Expand Up @@ -527,6 +527,6 @@ plot.n_clusters_dbscan <- plot.n_clusters_elbow
#' @export
plot.n_clusters_hclust <- function(x, ...) {
insight::check_if_installed("pvclust")
graphics::plot(attributes(x)$model)
pvclust::pvrect(attributes(x)$model, alpha = attributes(x)$ci, pv = "si")
graphics::plot(attributes(x)[["model"]])
pvclust::pvrect(attributes(x)[["model"]], alpha = attributes(x)$ci, pv = "si")
}
8 changes: 4 additions & 4 deletions R/utils_format.R
Original file line number Diff line number Diff line change
Expand Up @@ -525,7 +525,7 @@

# helper to format the header / subheader of different model components --------------

.format_model_component_header <- function(x,

Check warning on line 528 in R/utils_format.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files

file=R/utils_format.R,line=528,col=1,[cyclocomp_linter] Reduce the cyclomatic complexity of this function from 42 to at most 40.
type,
split_column,
is_zero_inflated,
Expand Down Expand Up @@ -894,7 +894,7 @@
# or edge cases...

#' @keywords internal
.format_columns_multiple_components <- function(x,

Check warning on line 897 in R/utils_format.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files

file=R/utils_format.R,line=897,col=1,[cyclocomp_linter] Reduce the cyclomatic complexity of this function from 101 to at most 40.
pretty_names,
split_column = "Component",
digits = 2,
Expand Down Expand Up @@ -954,16 +954,16 @@
}

# fix column output
if (inherits(attributes(x)$model, c("lavaan", "blavaan")) && "Label" %in% colnames(x)) {
if (inherits(attributes(x)[["model"]], c("lavaan", "blavaan")) && "Label" %in% colnames(x)) {
x$From <- ifelse(!nzchar(as.character(x$Label), keepNA = TRUE) | x$Label == x$To, x$From, paste0(x$From, " (", x$Label, ")")) # nolint
x$Label <- NULL
}

if (inherits(attributes(x)$model, c("lavaan", "blavaan")) && !"Parameter" %in% colnames(x)) {
if (inherits(attributes(x)[["model"]], c("lavaan", "blavaan")) && !"Parameter" %in% colnames(x)) {
parameter_column <- colnames(x)[1]
}

if (inherits(attributes(x)$model, c("lavaan", "blavaan")) && "Defined" %in% x$Component) {
if (inherits(attributes(x)[["model"]], c("lavaan", "blavaan")) && "Defined" %in% x$Component) {
x$From[x$Component == "Defined"] <- ""
x$Operator[x$Component == "Defined"] <- ""
x$To <- ifelse(x$Component == "Defined", paste0("(", x$To, ")"), x$To)
Expand Down Expand Up @@ -1175,7 +1175,7 @@
# fix non-equal length of columns
final_table <- .fix_nonmatching_columns(
final_table,
is_lavaan = inherits(attributes(x)$model, c("lavaan", "blavaan"))
is_lavaan = inherits(attributes(x)[["model"]], c("lavaan", "blavaan"))
)
do.call(rbind, final_table)
} else {
Expand Down
1 change: 1 addition & 0 deletions inst/WORDLIST
Original file line number Diff line number Diff line change
Expand Up @@ -318,6 +318,7 @@ strengejacke
subclusters
subscale
subscales
svylme
systemfit
th
tidymodels
Expand Down
3 changes: 0 additions & 3 deletions man/model_parameters.BFBayesFactor.Rd

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

3 changes: 0 additions & 3 deletions man/model_parameters.aov.Rd

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

Loading
Loading