Support for svy2lme (#985)

* Support for svy2lme

* fix

* fix

* news, desc

* add tests

* some fixes

* fix tests

* fix partial matching

* wordlist

* fix

DESCRIPTION

@@ -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",
@@ -197,6 +197,7 @@ Suggests:
     sparsepca,
     survey,
     survival,
+    svylme,
     testthat (>= 3.2.1),
     tidyselect,
     tinytable (>= 0.1.0),
@@ -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

NAMESPACE

@@ -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)
@@ -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)
@@ -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)
@@ -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)

NEWS.md

@@ -1,3 +1,9 @@
+# parameters 0.22.1
+
+## New supported models
+
+* Support for `svy2lme` models from package *svylme*.
+
 # parameters 0.22.0
 
 ## Breaking changes

R/extract_random_variances.R

@@ -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
+}
 
 
 

R/methods_BayesFactor.R

@@ -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")
 
@@ -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,
@@ -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,

R/methods_aov.R

@@ -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
@@ -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)

R/methods_htest.R

@@ -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 {

R/methods_other.R

@@ -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,

R/methods_svy2lme.R

@@ -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
+}

R/n_clusters_easystats.R

@@ -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")
 }

R/utils_format.R

@@ -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)
@@ -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 {

inst/WORDLIST

@@ -318,6 +318,7 @@ strengejacke
 subclusters
 subscale
 subscales
+svylme
 systemfit
 th
 tidymodels