Merge branch 'main' into main

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: parameters
 Title: Processing of Model Parameters
-Version: 0.18.1.4
+Version: 0.18.1.8
 Authors@R: 
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -129,6 +129,7 @@ Suggests:
     GPArotation,
     gt,
     httr,
+    Hmisc,
     ivprobit,
     ivreg,
     knitr,
@@ -198,17 +199,4 @@ Language: en-US
 RoxygenNote: 7.2.0
 Config/testthat/edition: 3
 Roxygen: list(markdown = TRUE)
-Remotes:
-    easystats/insight
-RemoteType: github
-RemoteHost: api.github.com
-RemoteRepo: glmmTMB
-RemoteUsername: glmmTMB
-RemoteRef: ci_tweaks
-RemoteSha: fd8bb78acd8b198147285ce94b1f67043349f570
-RemoteSubdir: glmmTMB
-GithubRepo: glmmTMB
-GithubUsername: glmmTMB
-GithubRef: ci_tweaks
-GithubSHA1: fd8bb78acd8b198147285ce94b1f67043349f570
-GithubSubdir: glmmTMB
+Remotes: easystats/insight

NEWS.md

@@ -18,6 +18,11 @@
 * `model_parameters()` now also includes standard errors and confidence
   intervals for slope-slope-correlations of random effects variances.
 
+* `model_parameters()` for mixed models gains a `ci_random` argument, to toggle
+  whether confidence intervals for random effects parameters should also be
+  computed. Set to `FALSE` if calculation of confidence intervals for random 
+  effects parameters takes too long.
+
 * `ci()` for *glmmTMB* models with `method = "profile"` is now more robust.
 
 ## Bug fixes

R/1_model_parameters.R

@@ -535,7 +535,6 @@ model_parameters.default <- function(model,
     )
     args <- c(args, dots)
     params <- do.call("bootstrap_parameters", args)
-
   } else {
     # set default method for CI
     if (is.null(ci_method) || missing(ci_method)) {

R/3_p_value.R

@@ -174,7 +174,6 @@ p_value.default <- function(model,
   p <- NULL
 
   if (ncol(cs) >= 4) {
-
     # do we have a p-value column based on t?
     pvcn <- which(colnames(cs) == "Pr(>|t|)")
 

R/check_factorstructure.R

@@ -14,7 +14,6 @@
 #' [check_kmo()], [check_sphericity_bartlett()] and [check_clusterstructure()].
 #' @export
 check_factorstructure <- function(x, ...) {
-
   # TODO: detect (and remove?) factors
   # TODO: This could be improved using the correlation package to use different correlation methods
 
@@ -145,7 +144,6 @@ check_kmo <- function(x, ...) {
 #'   approximation in factor analysis. Biometrika, 38(3/4), 337-344.
 #' @export
 check_sphericity_bartlett <- function(x, ...) {
-
   # This could be improved using the correlation package to use different correlation methods
   cormatrix <- stats::cor(x, use = "pairwise.complete.obs", ...)
 

R/ci_generic.R

@@ -8,7 +8,6 @@
                         vcov_args = NULL,
                         verbose = TRUE,
                         ...) {
-
   # check method
   if (is.null(method)) {
     method <- "wald"

R/ci_profile_boot.R

@@ -81,7 +81,8 @@
     out <- as.data.frame(stats::confint(x, method = "profile", level = ci, ...))
   } else {
     out <- tryCatch(as.data.frame(stats::confint(profiled, level = ci, ...)),
-                    error = function(e) NULL)
+      error = function(e) NULL
+    )
     if (is.null(out)) {
       out <- as.data.frame(stats::confint(x, method = "profile", level = ci, ...))
     }

R/cluster_analysis.R

@@ -132,8 +132,6 @@ cluster_analysis <- function(x,
                              dbscan_eps = 15,
                              iterations = 100,
                              ...) {
-
-
   # match arguments
   method <- match.arg(method, choices = c("kmeans", "hkmeans", "pam", "pamk", "hclust", "dbscan", "hdbscan", "mixture"), several.ok = TRUE)
 

R/cluster_centers.R

@@ -17,7 +17,6 @@
 #' cluster_centers(iris[1:4], clusters = k$cluster, fun = median)
 #' @export
 cluster_centers <- function(data, clusters, fun = mean, ...) {
-
   # Get n obs
   params <- data.frame(table(clusters))
   names(params) <- c("Cluster", "n_Obs")

R/cluster_meta.R

@@ -32,7 +32,7 @@
 #' heatmap(m, scale = "none")
 #'
 #' # Extract 3 clusters
-#' predict(m, n=3)
+#' predict(m, n = 3)
 #'
 #' # Convert to dissimilarity
 #' d <- as.dist(abs(m - 1))
@@ -81,7 +81,6 @@ cluster_meta <- function(list_of_clusters, rownames = NULL, ...) {
 
 #' @keywords internal
 .cluster_meta_matrix <- function(data) {
-
   # Internal function
   .get_prob <- function(x) {
     if (any(is.na(x))) {
@@ -117,8 +116,10 @@ cluster_meta <- function(list_of_clusters, rownames = NULL, ...) {
 #' @export
 #' @inheritParams stats::predict
 predict.cluster_meta <- function(object, n = NULL, ...) {
-  if(is.null(n)) stop("The number of clusters to extract `n` must be entered.")
-  d <- as.dist(abs(object - 1))
-  model <- hclust(d)
-  cutree(model, k = n)
+  if (is.null(n)) {
+    stop("The number of clusters to extract `n` must be entered.", call. = FALSE)
+  }
+  d <- stats::as.dist(abs(object - 1))
+  model <- stats::hclust(d)
+  stats::cutree(model, k = n)
 }

R/compare_parameters.R

@@ -150,11 +150,9 @@ compare_parameters <- function(...,
     model_name <- model_names[[i]]
 
     if (inherits(model, "parameters_model")) {
-
       # we already have model parameters object...
       dat <- model
     } else {
-
       # set default-ci_type for Bayesian models
       if (.is_bayesian_model(model) && !ci_method %in% c("hdi", "quantile", "ci", "eti", "si", "bci", "bcai")) {
         ci_method_tmp <- "eti"

R/equivalence_test.R

@@ -226,7 +226,6 @@ equivalence_test.merMod <- function(x,
                                     effects = c("fixed", "random"),
                                     verbose = TRUE,
                                     ...) {
-
   # ==== argument matching ====
 
   rule <- match.arg(tolower(rule), choices = c("bayes", "classic", "cet"))
@@ -270,7 +269,6 @@ equivalence_test.parameters_simulate_model <- function(x,
                                                        ci = .95,
                                                        verbose = TRUE,
                                                        ...) {
-
   # ==== retrieve model, to define rope range for simulated model parameters ====
 
   model <- .get_object(x)
@@ -310,7 +308,6 @@ equivalence_test.parameters_simulate_model <- function(x,
                                           rule = "classic",
                                           verbose = TRUE,
                                           ...) {
-
   # ==== define rope range ====
 
   if (all(range == "default")) {
@@ -601,7 +598,6 @@ format.equivalence_test_lm <- function(x,
                                        format = "text",
                                        zap_small = FALSE,
                                        ...) {
-
   # default brackets are parenthesis for HTML / MD
   if ((is.null(ci_brackets) || isTRUE(ci_brackets)) && (identical(format, "html") || identical(format, "markdown"))) {
     ci_brackets <- c("(", ")")

R/extract_parameters.R

@@ -312,11 +312,13 @@
 .add_sigma_residual_df <- function(params, model) {
   if (is.null(params$Component) || !"sigma" %in% params$Component) {
     sig <- tryCatch(suppressWarnings(insight::get_sigma(model, ci = NULL, verbose = FALSE)),
-                    error = function(e) NULL)
+      error = function(e) NULL
+    )
     attr(params, "sigma") <- as.numeric(sig)
 
     resdf <- tryCatch(suppressWarnings(insight::get_df(model, type = "residual")),
-                      error = function(e) NULL)
+      error = function(e) NULL
+    )
     attr(params, "residual_df") <- as.numeric(resdf)
   }
   params
@@ -351,7 +353,6 @@
                                       drop = NULL,
                                       column = NULL,
                                       verbose = TRUE) {
-
   # check pattern
   if (!is.null(keep) && length(keep) > 1) {
     keep <- paste0("(", paste0(keep, collapse = "|"), ")")
@@ -623,7 +624,6 @@
 
 
 .add_within_between_effects <- function(model, parameters) {
-
   # This function checks whether the model contains predictors that were
   # "demeaned" using the "demean()" function. If so, these columns have an
   # attribute indicating the within or between effect, and in such cases,
@@ -899,8 +899,8 @@
     valid <- names(formals(lavaan::standardizedsolution))
     dots <- list(...)
     dots <- dots[names(dots) %in% valid]
-    args <- c(list( model, se = TRUE, level = ci, type = type), dots)
-    f <- getFromNamespace("standardizedsolution", "lavaan")
+    args <- c(list(model, se = TRUE, level = ci, type = type), dots)
+    f <- utils::getFromNamespace("standardizedsolution", "lavaan")
     data <- do.call("f", args)
     names(data)[names(data) == "est.std"] <- "est"
   }

R/extract_parameters_anova.R

@@ -1,6 +1,5 @@
 #' @keywords internal
 .extract_parameters_anova <- function(model, test = "multivariate") {
-
   # Processing
   if ("manova" %in% class(model)) {
     parameters <- .extract_anova_manova(model)
@@ -193,8 +192,9 @@
     hypothesis <- m_attr$heading[grep("=", m_attr$heading)]
     parameters_xtra <- data.frame(
       Parameter = hypothesis,
-      Coefficient = m_attr$value, 
-      SE = sqrt(as.numeric(diag(m_attr$vcov))))
+      Coefficient = m_attr$value,
+      SE = sqrt(as.numeric(diag(m_attr$vcov)))
+    )
     row.names(parameters_xtra) <- row.names(parameters) <- NULL
     parameters <- cbind(parameters_xtra, parameters)
     parameters$Parameter <- gsub("  ", " ", parameters$Parameter) ## Annoying extra space sometimes
@@ -307,7 +307,7 @@
   if (requireNamespace("effectsize", quietly = TRUE)) {
     power <- tryCatch(
       {
-        cohens_f2 <- effectsize::cohens_f_squared(model, partial = TRUE)
+        cohens_f2 <- effectsize::cohens_f_squared(model, partial = TRUE, verbose = FALSE)
 
         f2 <- cohens_f2$Cohens_f2[match(cohens_f2$Parameter, params$Parameter)]
         u <- params$df[params$Parameter != "Residuals"]