plot.n_factors: Add % of variance to plot (#314)

* Add % of variance to n_factors plot

* lintrs, news, desc

* lintr

* minor x-axis

* Revert "minor x-axis"

This reverts commit 4c12bbf.

* remotes

* lintr

* lintr

* lintr

* wordlist

* lintr

* use GH to avoid warning

* fix

* lintr

* lintr

* styler

---------

Co-authored-by: Daniel <[email protected]>

Author: DominiqueMakowski

DESCRIPTION

@@ -117,4 +117,4 @@ Config/Needs/website:
     rstudio/bslib,
     r-lib/pkgdown,
     easystats/easystatstemplate
-Remotes: easystats/bayestestR
+Remotes: easystats/parameters, easystats/bayestestR

NEWS.md

@@ -1,3 +1,10 @@
+# see 0.8.2
+
+## Minor Changes
+
+* `plot.n_factors()` now shows a dashed line over the bars, indicating the
+  cumulate explained variance by the number of factors.
+
 # see 0.8.1
 
 ## Major Changes

R/data_plot.R

@@ -132,6 +132,9 @@ add_plot_attributes <- function(x) {
   if (!is.null(info$title)) {
     out[[length(out) + 1L]] <- ggplot2::labs(title = info$title)
   }
+  if (!is.null(info$subtitle)) {
+    out[[length(out) + 1L]] <- ggplot2::labs(subtitle = info$subtitle)
+  }
 
   out
 }
@@ -176,7 +179,7 @@ add_plot_attributes <- function(x) {
 
 #' @keywords internal
 .dynGet <- function(x,
-                    ifnotfound = stop(gettextf("%s not found", sQuote(x)), domain = NA),
+                    ifnotfound = stop(gettextf("%s not found", sQuote(x)), domain = NA, call. = FALSE),
                     minframe = 1L,
                     inherits = FALSE) {
   x <- insight::safe_deparse(x)

R/geom_binomdensity.R

@@ -62,7 +62,7 @@ geom_binomdensity <- function(data,
 
   # Other parameters
   data$.side <- ifelse(data[[y]] == y_levels[1], "top", "bottom")
-  data$.justification <- as.numeric(!(data[[y]] == y_levels[1]))
+  data$.justification <- as.numeric(data[[y]] != y_levels[1])
   data$.scale <- .geom_binomdensity_scale(data, x, y, scale)
 
   # ggdist geom

R/geom_from_list.R

@@ -114,58 +114,68 @@
 #' @export
 geom_from_list <- function(x, ...) {
   # Additional parameters ------------------------------------------------------
-  args <- x[!names(x) %in% c("geom", "aes", "data", "width", "height", "position", "show.legend")]
+  arguments <- x[!names(x) %in% c("geom", "aes", "data", "width", "height", "position", "show.legend")]
 
   if (is.null(x$geom)) {
     return(NULL)
   }
 
   if (inherits(x$geom, "function")) {
-    return(do.call(x$geom, args))
+    return(do.call(x$geom, args = arguments))
   }
 
   if (x$geom %in% c("density_2d", "density_2d_filled", "density_2d_polygon")) {
-    if (!"contour" %in% names(args)) args$contour <- TRUE
-    if (!"contour_var" %in% names(args)) args$contour_var <- "density"
+    if (!"contour" %in% names(arguments)) arguments$contour <- TRUE
+    if (!"contour_var" %in% names(arguments)) arguments$contour_var <- "density"
   }
 
   # If they are not geoms, return immediately
   if (x$geom == "labs") {
-    return(do.call(ggplot2::labs, args))
+    return(do.call(ggplot2::labs, args = arguments))
   }
   if (x$geom == "guides") {
-    return(do.call(ggplot2::guides, args))
+    return(do.call(ggplot2::guides, args = arguments))
   }
   if (x$geom == "coord_flip") {
-    return(do.call(ggplot2::coord_flip, args))
+    return(do.call(ggplot2::coord_flip, args = arguments))
   }
   if (x$geom == "facet_wrap") {
-    return(do.call(ggplot2::facet_wrap, args))
+    return(do.call(ggplot2::facet_wrap, args = arguments))
   }
   if (x$geom == "facet_grid") {
-    return(do.call(ggplot2::facet_grid, args))
+    return(do.call(ggplot2::facet_grid, args = arguments))
   }
   if (x$geom == "smooth") {
-    if (!is.null(x$aes)) args$mapping <- do.call(ggplot2::aes, lapply(x$aes, .str_to_sym))
-    if (!"method" %in% names(args)) args$method <- "loess"
-    if (!"formula" %in% names(args)) args$formula <- "y ~ x"
-    return(do.call(ggplot2::geom_smooth, args))
+    if (!is.null(x$aes)) {
+      arguments$mapping <- do.call(ggplot2::aes, args = lapply(x$aes, .str_to_sym))
+    }
+    if (!"method" %in% names(arguments)) {
+      arguments$method <- "loess"
+    }
+    if (!"formula" %in% names(arguments)) {
+      arguments$formula <- "y ~ x"
+    }
+    return(do.call(ggplot2::geom_smooth, args = arguments))
   }
 
   if (startsWith(x$geom, "scale_") || startsWith(x$geom, "theme") || startsWith(x$geom, "see_")) {
-    return(do.call(x$geom, args))
+    return(do.call(x$geom, args = arguments))
   }
 
   if (startsWith(x$geom, "ggside::")) {
     insight::check_if_installed("ggside")
-    if (!is.null(x$aes)) args$mapping <- do.call(ggplot2::aes, lapply(x$aes, .str_to_sym))
-    return(do.call(eval(parse(text = x$geom)), args))
+    if (!is.null(x$aes)) {
+      arguments$mapping <- do.call(ggplot2::aes, args = lapply(x$aes, .str_to_sym))
+    }
+    return(do.call(eval(parse(text = x$geom)), args = arguments))
   }
 
   if (startsWith(x$geom, "ggraph::")) {
     insight::check_if_installed("ggraph")
-    if (!is.null(x$aes)) args$mapping <- do.call(ggplot2::aes, lapply(x$aes, .str_to_sym))
-    return(do.call(eval(parse(text = x$geom)), args))
+    if (!is.null(x$aes)) {
+      arguments$mapping <- do.call(ggplot2::aes, args = lapply(x$aes, .str_to_sym))
+    }
+    return(do.call(eval(parse(text = x$geom)), args = arguments))
   }
 
   # Default parameters
@@ -179,7 +189,7 @@ geom_from_list <- function(x, ...) {
   }
 
   # Default for violin
-  if (x$geom == "violin") {
+  if (x$geom == "violin") { # nolint
     stat <- "ydensity"
     position <- "dodge"
   } else if (x$geom == "boxplot") {
@@ -212,7 +222,7 @@ geom_from_list <- function(x, ...) {
 
   # Aesthetics
   if ("aes" %in% names(x)) {
-    aes_list <- do.call(ggplot2::aes, lapply(x$aes, .str_to_sym))
+    aes_list <- do.call(ggplot2::aes, args = lapply(x$aes, .str_to_sym))
   } else {
     aes_list <- NULL
   }
@@ -231,7 +241,7 @@ geom_from_list <- function(x, ...) {
     geom = x$geom,
     mapping = aes_list,
     data = x$data,
-    params = args,
+    params = arguments,
     show.legend = show.legend,
     ...
   )

R/plot.check_collinearity.R

@@ -69,11 +69,11 @@ plot.see_check_collinearity <- function(x,
   xlim <- nrow(x)
   if (ylim < 10) ylim <- 10
 
-  if (!is.null(ci_data)) {
-    x <- cbind(x, ci_data)
-  } else {
+  if (is.null(ci_data)) {
     x$VIF_CI_low <- NA_real_
     x$VIF_CI_high <- NA_real_
+  } else {
+    x <- cbind(x, ci_data)
   }
 
   # make sure legend is properly sorted
@@ -118,33 +118,33 @@ plot.see_check_collinearity <- function(x,
       fill = colors[3],
       color = NA,
       alpha = 0.15
-    ) +
-    {
-      if (!is.null(ci_data)) {
-        list(
-          ggplot2::geom_linerange(
-            linewidth = size_line,
-            na.rm = TRUE
-          ),
-          ggplot2::geom_segment(
-            data = x[x$VIF_CI_high > ylim * 1.15, ],
-            mapping = aes(
-              x = .data$x,
-              xend = .data$x,
-              y = .data$y,
-              yend = .data$VIF_CI_high
-            ),
-            lineend = "round",
-            linejoin = "round",
-            arrow = ggplot2::arrow(
-              ends = "last", type = "closed",
-              angle = 20, length = ggplot2::unit(0.03, "native")
-            ),
-            show.legend = FALSE
-          )
-        )
-      }
-    } +
+    )
+
+  if (!is.null(ci_data)) {
+    p <- p +
+      ggplot2::geom_linerange(
+        linewidth = size_line,
+        na.rm = TRUE
+      ) +
+      ggplot2::geom_segment(
+        data = x[x$VIF_CI_high > ylim * 1.15, ],
+        mapping = aes(
+          x = .data$x,
+          xend = .data$x,
+          y = .data$y,
+          yend = .data$VIF_CI_high
+        ),
+        lineend = "round",
+        linejoin = "round",
+        arrow = ggplot2::arrow(
+          ends = "last", type = "closed",
+          angle = 20, length = ggplot2::unit(0.03, "native")
+        ),
+        show.legend = FALSE
+      )
+  }
+
+  p <- p +
     geom_point2(
       size = size_point,
       na.rm = TRUE

R/plot.check_heteroscedasticity.R

@@ -24,21 +24,19 @@ plot.see_check_heteroscedasticity <- function(x, data = NULL, ...) {
 
   faminfo <- insight::model_info(model)
   r <- tryCatch(
-    {
-      if (inherits(model, "merMod")) {
-        stats::residuals(model, scaled = TRUE)
-      } else if (inherits(model, c("glmmTMB", "MixMod"))) {
-        sigma <- if (faminfo$is_mixed) {
-          sqrt(insight::get_variance_residual(model))
-        } else {
-          .sigma_glmmTMB_nonmixed(model, faminfo)
-        }
-        stats::residuals(model) / sigma
-      } else if (inherits(model, "glm")) {
-        stats::rstandard(model, type = "pearson")
+    if (inherits(model, "merMod")) {
+      stats::residuals(model, scaled = TRUE)
+    } else if (inherits(model, c("glmmTMB", "MixMod"))) {
+      sig <- if (faminfo$is_mixed) {
+        sqrt(insight::get_variance_residual(model))
       } else {
-        stats::rstandard(model)
+        .sigma_glmmTMB_nonmixed(model, faminfo)
       }
+      stats::residuals(model) / sig
+    } else if (inherits(model, "glm")) {
+      stats::rstandard(model, type = "pearson")
+    } else {
+      stats::rstandard(model)
     },
     error = function(e) {
       NULL

R/plot.check_model.R

@@ -209,9 +209,9 @@ plot.see_check_model <- function(x,
     pw <- plots(p, n_columns = n_columns)
     .safe_print_plots(pw, ...)
     invisible(pw)
-  } else {
-    return(p)
   }
+
+  p
 }
 
 

R/plot.check_normality.R

@@ -68,7 +68,7 @@ plot.see_check_normality <- function(x,
       alpha_level = alpha
     )
   } else {
-    if (type == "qq") {
+    if (type == "qq") { # nolint
       model_info <- attributes(x)$model_info
       if (inherits(model, c("lme", "lmerMod", "merMod", "glmmTMB", "afex_aov", "BFBayesFactor"))) {
         res_ <- suppressMessages(sort(stats::residuals(model), na.last = NA))

R/plot.check_outliers.R

@@ -41,9 +41,9 @@ plot.see_check_outliers <- function(x,
                                     ...) {
   type <- match.arg(type)
   influential_obs <- attributes(x)$influential_obs
-  methods <- attr(x, "methods", exact = TRUE)
+  outlier_methods <- attr(x, "methods", exact = TRUE)
 
-  if (type == "dots" && !is.null(influential_obs) && (is.null(methods) || length(methods) == 1)) {
+  if (type == "dots" && !is.null(influential_obs) && (is.null(outlier_methods) || length(outlier_methods) == 1)) {
     .plot_diag_outliers_new(
       influential_obs,
       show_labels = show_labels,
@@ -52,12 +52,10 @@ plot.see_check_outliers <- function(x,
       dot_alpha_level = dot_alpha,
       colors = colors
     )
+  } else if (length(outlier_methods) == 1) {
+    .plot_diag_outliers(x, show_labels = show_labels, size_text = size_text, rescale_distance = rescale_distance)
   } else {
-    if (length(methods == 1)) {
-      .plot_diag_outliers(x, show_labels = show_labels, size_text = size_text, rescale_distance = rescale_distance)
-    } else {
-      .plot_outliers_multimethod(x, rescale_distance)
-    }
+    .plot_outliers_multimethod(x, rescale_distance)
   }
 }