Merge branch 'dev' into 'prod'

Dev

See merge request !8

DESCRIPTION

 Package: ufs
 Type: Package
 Title: Quantitative Analysis Made Accessible
-Version: 0.4.0
+Version: 0.4.1
 Authors@R: 
     c(
         person(given = "Gjalt-Jorn",

NAMESPACE

@@ -122,6 +122,7 @@ export(extractVarName)
 export(faConfInt)
 export(fa_failsafe)
 export(factorLoadingDiamondCIplot)
+export(factorLoadingHeatmap)
 export(findShortestInterval)
 export(formatCI)
 export(formatPvalue)
@@ -208,6 +209,8 @@ export(suspectParticipants)
 export(uniDimColors)
 export(varsToDiamondPlotDf)
 export(vecTxt)
+export(vecTxtB)
+export(vecTxtM)
 export(vecTxtQ)
 export(zotero_construct_export_call)
 export(zotero_download_and_export_items)

R/CIM.R

@@ -146,7 +146,6 @@ CIM <- function(data,
 
   dataframeName <- deparse(substitute(data));
 
-
   abbrScaleNames <- abbreviate(names(scales));
   abbrScales <-
     lapply(seq_along(scales), function(i) {
@@ -180,7 +179,7 @@ CIM <- function(data,
                            cfa1s = list(),
                            cfa2s = list(),
                            cfas = list(),
-                           diamondplots = list(),
+                           factorLoadingPlots = list(),
                            faDfs = list(),
                            scales = scales,
                            abbrScales = abbrScales,
@@ -202,7 +201,7 @@ CIM <- function(data,
     res$intermediate$cfa1s[[rowVar]] <- list();
     res$intermediate$cfa2s[[rowVar]] <- list();
     res$intermediate$cfas[[rowVar]] <- list();
-    res$intermediate$diamondplots[[rowVar]] <- list();
+    res$intermediate$factorLoadingPlots[[rowVar]] <- list();
     res$intermediate$faDfs[[rowVar]] <- list();
 
     ### Get index of this row
@@ -421,46 +420,60 @@ CIM <- function(data,
             }
 
             ### Make dataframe with factor loading confidence intervals
-            if ('psych' %in% class(efa)) {
+            if (n.iter > 1) {
+              if ('psych' %in% class(efa)) {
 
-              factorLoadingCIs[[rowVar]][[colVar]] <-
-                ufs::faConfInt(res$intermediate$efas[[rowVar]][[colVar]]);
-              loadingCIs <-
-                factorLoadingCIs[[rowVar]][[colVar]];
+                factorLoadingCIs[[rowVar]][[colVar]] <-
+                  ufs::faConfInt(res$intermediate$efas[[rowVar]][[colVar]]);
+                loadingCIs <-
+                  factorLoadingCIs[[rowVar]][[colVar]];
 
-              ciSummaryList[[rowIndex]][[colIndex]] <-
-                (loadingCIs[[1]]$hi < loadingCIs[[2]]$lo) |
-                (loadingCIs[[2]]$hi < loadingCIs[[1]]$lo);
+                ciSummaryList[[rowIndex]][[colIndex]] <-
+                  (loadingCIs[[1]]$hi < loadingCIs[[2]]$lo) |
+                  (loadingCIs[[2]]$hi < loadingCIs[[1]]$lo);
 
-              faDf <- matrix(unlist(factorLoadingCIs[[rowVar]][[colVar]]),
-                             ncol=6);
-            } else {
-              faDf <- matrix(rep(NA, 6*ncol(abbrVarsDat)),
-                             ncol=6);
-            }
+                faDf <- matrix(unlist(factorLoadingCIs[[rowVar]][[colVar]]),
+                               ncol=6);
 
-            ### Get abbreviated scale names
-            abbr <- abbreviate(names(scales));
+              } else {
+                faDf <- matrix(rep(NA, 6*ncol(abbrVarsDat)),
+                               ncol=6);
 
-            ### Set row and column names
-            rownames(faDf) <- c(abbrScales[[abbrScaleNames[rowVar]]],
-                                abbrScales[[abbrScaleNames[colVar]]]);
-                                # paste0(abbr[rowVar], 1:length(scales[[rowVar]])),
-                                # paste0(abbr[colVar], 1:length(scales[[colVar]])));
-            colnames(faDf) <- c(rep(c('lo', 'est', 'hi'), 2));
+              }
+              colnames(faDf) <- c(rep(c('lo', 'est', 'hi'), 2));
 
-            faDfReordered <- faDf[order(rownames(faDf)),
-                                  ];
-            res$intermediate$faDfs[[rowVar]][[colVar]] <-
-              list(faDf_raw = faDf,
-                   faDf = faDfReordered,
-                   faDf_rounded = round(faDfReordered, 2));
+          } else {
 
-            if (ufs::opts$get('debug')) {
-              cat0("\n\nJust stored this dataframe to create a gTable later on:\n\n");
-              print(res$intermediate$faDfs[[rowVar]][[colVar]]$faDf_rounded);
-              cat0("\n\n");
-            }
+            faDf <-
+              as.data.frame(
+                unclass(
+                  res$intermediate$efas[[rowVar]][[colVar]]$loadings
+                )
+              );
+
+          }
+
+          ### Get abbreviated scale names
+          abbr <- abbreviate(names(scales));
+
+          ### Set row and column names
+          rownames(faDf) <- c(abbrScales[[abbrScaleNames[rowVar]]],
+                              abbrScales[[abbrScaleNames[colVar]]]);
+          # paste0(abbr[rowVar], 1:length(scales[[rowVar]])),
+          # paste0(abbr[colVar], 1:length(scales[[colVar]])));
+
+          faDfReordered <- faDf[order(rownames(faDf)),
+          ];
+          res$intermediate$faDfs[[rowVar]][[colVar]] <-
+            list(faDf_raw = faDf,
+                 faDf = faDfReordered,
+                 faDf_rounded = round(faDfReordered, 2));
+
+          if (ufs::opts$get('debug')) {
+            cat0("\n\nJust stored this dataframe to create a gTable later on:\n\n");
+            print(res$intermediate$faDfs[[rowVar]][[colVar]]$faDf_rounded);
+            cat0("\n\n");
+          }
 
             ###------------------------------------------------------------------
             ###------------------------------------------------------------------
@@ -498,15 +511,30 @@ CIM <- function(data,
                 sort(c(rowVar, colVar));
               titleString <- paste0(titleString[1], ' & ', titleString[2], "\n",
                                     fitText);
-              grobsList[[rowIndex]][[colIndex]] <-
-                res$intermediate$diamondplots[[rowVar]][[colVar]] <-
+
+              if (n.iter > 1) {
+
+                grobsList[[rowIndex]][[colIndex]] <-
+                  res$intermediate$factorLoadingPlots[[rowVar]][[colVar]] <-
                   factorLoadingDiamondCIplot(res$intermediate$efas[[rowVar]][[colVar]],
                                              colors=colors,
                                              sortAlphabetically=TRUE) +
-              #faDfDiamondCIplot(faDf, xlab=NULL) +
+                  #faDfDiamondCIplot(faDf, xlab=NULL) +
                   ggplot2::ggtitle(titleString);
-            #           textGrob(paste0("Upper diag:\n", rowVar,
-            #                           " and ", colVar));
+                #           textGrob(paste0("Upper diag:\n", rowVar,
+                #                           " and ", colVar));
+
+              } else {
+
+                grobsList[[rowIndex]][[colIndex]] <-
+                  res$intermediate$factorLoadingPlots[[rowVar]][[colVar]] <-
+                    factorLoadingHeatmap(
+                      res$intermediate$efas[[rowVar]][[colVar]],
+                      sortAlphabetically=TRUE
+                    );
+
+              }
+
             } else {
               grobsList[[rowIndex]][[colIndex]] <-
                 grid::textGrob('Not possible');
@@ -528,34 +556,41 @@ CIM <- function(data,
               cat0("\n\n");
             }
 
-            grobsList[[rowIndex]][[colIndex]] <-
-              gridExtra::gtable_combine(headerTable,
-                                        grobsList[[rowIndex]][[colIndex]],
-                                        along=2);
+            if (n.iter > 1) {
 
-            prevWidths <- grobsList[[rowIndex]][[colIndex]]$widths;
+              grobsList[[rowIndex]][[colIndex]] <-
+                gridExtra::gtable_combine(headerTable,
+                                          grobsList[[rowIndex]][[colIndex]],
+                                          along=2);
 
-            ### Add variable names
-            titleString <-
-              sort(c(rowVar, colVar));
-            titleString <- paste0(titleString[1], ' & ', titleString[2]);
-            grobsList[[rowIndex]][[colIndex]] <-
-              gridExtra::gtable_combine(makeHeaderTable(titleString,
-                                                        colSpan=6),
-                                        grobsList[[rowIndex]][[colIndex]],
-                                        along=2);
-
-            ### Set widths (again, based on
-            ### https://github.com/baptiste/gridextra/wiki/tableGrob
-            grobsList[[rowIndex]][[colIndex]]$widths <-
-              grid::unit(rep(.95 * (1/ncol(grobsList[[rowIndex]][[colIndex]])),
-                             ncol(grobsList[[rowIndex]][[colIndex]])),
-                         "npc");
+              prevWidths <- grobsList[[rowIndex]][[colIndex]]$widths;
+
+              ### Add variable names
+              titleString <-
+                sort(c(rowVar, colVar));
+              titleString <- paste0(titleString[1], ' & ', titleString[2]);
+              grobsList[[rowIndex]][[colIndex]] <-
+                gridExtra::gtable_combine(
+                  makeHeaderTable(
+                    titleString,
+                    colSpan=ncol(res$intermediate$faDfs[[colVar]][[rowVar]]$faDf_rounded)
+                  ),
+                  grobsList[[rowIndex]][[colIndex]],
+                  along=2
+                );
+
+              ### Set widths (again, based on
+              ### https://github.com/baptiste/gridextra/wiki/tableGrob
+              grobsList[[rowIndex]][[colIndex]]$widths <-
+                grid::unit(rep(.95 * (1/ncol(grobsList[[rowIndex]][[colIndex]])),
+                               ncol(grobsList[[rowIndex]][[colIndex]])),
+                           "npc");
+            }
           }
         }
       }
       ### Finally, construct content; for diagonal, omega etc; for
-      ### upper diagonal, diamondPlots; for lower diagnoal, numbers
+      ### upper diagonal, factorLoadingPlots; for lower diagnoal, numbers
 
     }
   }

R/associationsDiamondPlot.R

@@ -105,9 +105,7 @@ associationsDiamondPlot <- function(dat, covariates, criteria,
                                     outputFile = NULL,
                                     outputWidth = 10,
                                     outputHeight = 10,
-                                    ggsaveParams = list(units='cm',
-                                                        dpi=300,
-                                                        type="cairo"),
+                                    ggsaveParams = ufs::opts$get("ggsaveParams"),
                                     ...) {
 
   res <- list(input = as.list(environment()),

R/attenuate.d.R

@@ -12,7 +12,7 @@
 #' @references Bobko, P., Roth, P. L., & Bobko, C. (2001). Correcting
 #' the Effect Size of d for Range Restriction and Unreliability.
 #' *Organizational Research Methods, 4*(1), 46–61.
-#' \url{https://doi.org/10.1177/109442810141003}
+#' \doi{10.1177/109442810141003}
 #'
 #' @examples
 #' attenuate.d(.5, .8);

R/biAxisDiamondPlot.R

@@ -100,9 +100,7 @@ biAxisDiamondPlot <- function(dat, items = NULL,
                               outputFile = NULL,
                               outputWidth = 10,
                               outputHeight = 10,
-                              ggsaveParams = list(units='cm',
-                                                  dpi=300,
-                                                  type="cairo"),
+                              ggsaveParams = ufs::opts$get("ggsaveParams"),
                               ...) {
 
   if (length(leftAnchors) != length(rightAnchors)) {

R/convert.d.to.nnc.R

@@ -25,7 +25,7 @@
 #' @seealso [behaviorchange::nnc()]
 #' @references Gruijters, S. L., & Peters, G. Y. (2019). Gauging the
 #' impact of behavior change interventions: A tutorial on the Numbers
-#' Needed to Treat. *PsyArXiv.* doi:[10.31234/osf.io/2bau7](https://doi.org/10.31234/osf.io/2bau7)
+#' Needed to Treat. *PsyArXiv.* \doi{10.31234/osf.io/2bau7}
 #' @keywords utilities
 #' @rdname nncConversion
 #' @examples

R/descr.R

@@ -43,7 +43,7 @@
 #' @author Gjalt-Jorn Peters
 #'
 #' Maintainer: Gjalt-Jorn Peters <gjalt-jorn@@userfriendlyscience.com>
-#' @seealso \code{\link{summary}}, [psych::describe()
+#' @seealso \code{\link{summary}}, [psych::describe()]
 #' @references Hartigan, J. A.; Hartigan, P. M. The Dip Test of Unimodality.
 #' Ann. Statist. 13 (1985), no. 1, 70--84. doi:10.1214/aos/1176346577.
 #' https://projecteuclid.org/euclid.aos/1176346577.
@@ -181,8 +181,36 @@ pander.descr <- function(x, headerPrefix = "",
 #' @method as.data.frame descr
 #' @rdname descriptives
 #' @export
-as.data.frame.descr <- function(x, row.names=NULL, optional=FALSE, ...) {
-  res <- as.data.frame(t(matrix(unlist(x)[c(1,2,5,6,7,8,9,10,11,12,13,14,15,16,17,18)])),
+as.data.frame.descr <- function(x, row.names=NULL,
+                                optional=FALSE, ...) {
+
+  if (!is.null(attr(x, 'digits'))) {
+    res <-
+      unlist(lapply(
+        x,
+        function(valList) {
+          return(
+            unlist(
+              lapply(
+                valList,
+                function(val) {
+                  if (is.numeric(val)) {
+                    return(round(val, attr(x, 'digits')));
+                  } else {
+                    return(val);
+                  }
+                }
+              )
+            )
+          );
+        }
+      ));
+  } else {
+    res <-
+      unlist(x);
+  }
+  res <- res[c(1,2,5,6,7,8,9,10,11,12,13,14,15,16,17,18)];
+  res <- as.data.frame(t(matrix(res)),
                        row.names=row.names,
                        optional=optional,
                        ...);

R/diamondPlot.R

@@ -82,9 +82,7 @@ diamondPlot <- function(data,
                         outputFile = NULL,
                         outputWidth = 10,
                         outputHeight = 10,
-                        ggsaveParams = list(units='cm',
-                                            dpi=300,
-                                            type="cairo"),
+                        ggsaveParams = ufs::opts$get("ggsaveParams"),
                         ...) {
 
   ### In case we want to check for a complete dataframe

R/disattenuate.d.R

@@ -13,7 +13,7 @@
 #' @references Bobko, P., Roth, P. L., & Bobko, C. (2001). Correcting
 #' the Effect Size of d for Range Restriction and Unreliability.
 #' *Organizational Research Methods, 4*(1), 46–61.
-#' \url{https://doi.org/10.1177/109442810141003}
+#' \doi{10.1177/109442810141003}
 #'
 #' @examples
 #' disattenuate.d(.5, .8);

R/duoComparisonDiamondPlot.R

@@ -25,9 +25,7 @@ duoComparisonDiamondPlot <- function(dat, items = NULL,
                                      outputFile = NULL,
                                      outputWidth = 10,
                                      outputHeight = 10,
-                                     ggsaveParams = list(units='cm',
-                                                         dpi=300,
-                                                         type="cairo"),
+                                     ggsaveParams = ufs::opts$get("ggsaveParams"),
                                      ...) {
 
   if (length(unique(stats::na.omit(dat[, compareBy]))) != 2) {

R/escapeRegex_(from_Hmisc).R

@@ -22,7 +22,7 @@
 #'
 #' Maintainer: Gjalt-Jorn Peters <gjalt-jorn@@userfriendlyscience.com>
 #' @seealso \code{\link[base]{grep}}, \code{Hmisc},
-#' \url{http://biostat.mc.vanderbilt.edu/wiki/Main/Hmisc},
+#' \url{https://hbiostat.org/R/Hmisc/},
 #' \url{https://github.com/harrelfe/Hmisc}
 #' @keywords manip character programming
 #' @examples

R/factorLoadingDiamondCIplot.R

@@ -46,7 +46,7 @@
 #' ###  may generate warnings because of the bootstrapping of
 #' ###  the confidence intervals)
 #'
-#' factorLoadingDiamondCIplot(psych::fa(Bechtoldt,
+#' factorLoadingDiamondCIplot(psych::fa(psych::Bechtoldt,
 #'                                      nfactors=2,
 #'                                      n.iter=50,
 #'                                      n.obs=200));
@@ -54,7 +54,7 @@
 #' ### And using a lower alpha value for the diamonds to
 #' ### make them more transparent
 #'
-#' factorLoadingDiamondCIplot(psych::fa(Bechtoldt,
+#' factorLoadingDiamondCIplot(psych::fa(psych::Bechtoldt,
 #'                                      nfactors=2,
 #'                                      n.iter=50,
 #'                                      n.obs=200),
@@ -62,7 +62,7 @@
 #'                            size=1);
 #' }
 #'
-#' @export factorLoadingDiamondCIplot
+#' @export
 factorLoadingDiamondCIplot <- function(fa,
                                        xlab='Factor Loading',
                                        colors = viridis::viridis_pal()(max(2, fa$factors)),

R/factorLoadingHeatmap.R

+#' Two-dimensional visualisation of factor analyses
+#'
+#' This function uses the [diamondPlot()] to visualise the results of
+#' a factor analyses. Because the factor loadings computed in factor analysis
+#' are point estimates, they may vary from sample to sample. The factor
+#' loadings for any given sample are usually not relevant; samples are but
+#' means to study populations, and so, researchers are usually interested in
+#' population values for the factor loadings. However, tables with lots of
+#' loadings can quickly become confusing and intimidating. This function aims
+#' to facilitate working with and interpreting factor analysis based on
+#' confidence intervals by visualising the factor loadings and their confidence
+#' intervals.
+#'
+#'
+#' @param fa The object produced by the [psych::fa()] function from the
+#' [psych::psych] package. It is important that the `n.iter` argument
+#' of [psych::fa()] was set to a realistic number, because otherwise, no
+#' confidence intervals will be available.
+#' @param xlab The label for the x axis.
+#' @param colors The colors used for the factors. The default uses the discrete
+#' [viridis()] palette, which is optimized for perceptual uniformity,
+#' maintaining its properties when printed in grayscale, and designed for
+#' colourblind readers. A vector can also be supplied; the colors must be valid
+#' arguments to [colorRamp()] (and therefore, to
+#' [col2rgb()]).
+#' @param labels The labels to use for the items (on the Y axis).
+#' @param showLoadings Whether to show the factor loadings or not.
+#' @param heatmap Whether to produce a heatmap or use diamond plots.
+#' @param theme The ggplot2 theme to use.
+#' @param sortAlphabetically Whether to sort the items alphabetically.
+#' @param digits Number of digits to round to.
+#' @param labs The labels to pass to ggplot2.
+#' @param themeArgs Additional theme arguments to pass to ggplot2.
+#' @param \dots Additional arguments will be passed to
+#' [ggDiamondLayer()]. This can be used to set, for example, the
+#' transparency (alpha value) of the diamonds to a lower value using e.g.
+#' `alpha=.5`.
+#' @return A [ggplot2::ggplot()] plot with several
+#' [ggDiamondLayer()]s is returned.
+#' @author Gjalt-Jorn Peters
+#'
+#' Maintainer: Gjalt-Jorn Peters <gjalt-jorn@@userfriendlyscience.com>
+#' @seealso [psych::fa()]ss, [meansDiamondPlot()],
+#' [meanSDtoDiamondPlot()], [diamondPlot()],
+#' [ggDiamondLayer()]
+#' @keywords hplot
+#' @examples
+#'
+#' \dontrun{
+#' ### (Not run during testing because it takes too long and
+#' ###  may generate warnings because of the bootstrapping of
+#' ###  the confidence intervals)
+#'
+#' factorLoadingHeatmap(psych::fa(psych::Bechtoldt,
+#'                                nfactors=2,
+#'                                n.iter=50,
+#'                                n.obs=200));
+#'
+#' ### And using a lower alpha value for the diamonds to
+#' ### make them more transparent
+#'
+#' factorLoadingHeatmap(psych::fa(psych::Bechtoldt,
+#'                                nfactors=2,
+#'                                n.iter=50,
+#'                                n.obs=200),
+#'                      alpha=.5,
+#'                      size=1);
+#' }
+#'
+#' @export
+factorLoadingHeatmap <- function(fa,
+                                 xlab='Factor Loading',
+                                 colors = viridis::viridis_pal()(max(2, fa$factors)),
+                                 labels=NULL,
+                                 showLoadings = FALSE,
+                                 heatmap = FALSE,
+                                 theme=ggplot2::theme_minimal(),
+                                 sortAlphabetically = FALSE,
+                                 digits=2,
+                                 labs = list(title = NULL,
+                                             x = NULL,
+                                             y = NULL),
+                                 themeArgs = list(panel.grid = ggplot2::element_blank(),
+                                                  legend.position = "none",
+                                                  axis.text.x = ggplot2::element_blank()),
+                                 ...) {
+
+  ### Create list for CIs per factor
+  loadings <- as.data.frame(unclass(fa$loadings));
+
+  dotsList <- as.list(substitute(list(...)));
+
+  if ('alpha' %in% names(dotsList)) {
+    alpha <- dotsList$alpha;
+  } else {
+    alpha <- 1;
+  }
+
+  if (is.null(labels)) {
+    labels <- rownames(unclass(fa$loadings));
+  }
+
+  if (sortAlphabetically) {
+    sortOrder <- order(labels);
+  } else {
+    sortOrder <- seq_along(labels);
+  }
+
+  tmpDf <-
+    utils::stack(loadings);
+
+  tmpDf$Variable <-
+    factor(
+      rep(row.names(loadings),
+          ncol(loadings)),
+      levels = row.names(loadings)[rev(sortOrder)],
+      labels = row.names(loadings)[rev(sortOrder)],
+      ordered = TRUE
+    );
+
+  tmpDf$Factor <-
+    factor(
+      tmpDf$ind,
+      levels = names(loadings),
+      labels = names(loadings),
+      ordered = TRUE
+    );
+
+  tmpDf$loadingLabel <-
+    round(tmpDf$values, digits);
+
+  tmpDf$absLoading <-
+    abs(tmpDf$values);
+
+  ### Create empty plot
+  res <-
+    ggplot2::ggplot(
+      data = tmpDf,
+      mapping = ggplot2::aes_string(
+        x = "Factor",
+        y = "Variable",
+        color = 'absLoading',
+        fill = 'absLoading')
+    ) +
+      ggplot2::scale_color_viridis_c(direction=-1,
+                                     limits = c(0, 1)) +
+      ggplot2::scale_fill_viridis_c(direction=-1,
+                                    limits = c(0, 1)) +
+      theme +
+    do.call(
+      ggplot2::labs,
+      labs
+    ) +
+      do.call(
+        ggplot2::theme,
+        themeArgs
+      );
+
+  if (heatmap) {
+    res <-
+      res +
+      ggplot2::geom_tile();
+  } else {
+    res <-
+      res +
+      ggplot2::geom_point(
+        mapping = ggplot2::aes_string(size = 'absLoading')
+      );
+  }
+
+  if (showLoadings) {
+    res <-
+      res +
+      ggplot2::geom_text(
+        mapping = ggplot2::aes_string(label = 'loadingLabel')
+      );
+  }
+
+  return(res);
+}