Commit 14b12cf0 authored by Gjalt-Jorn Peters's avatar Gjalt-Jorn Peters

Merge branch 'dev' into 'prod'

Dev

See merge request !8
parents 18514b9b 3ec952b0
Pipeline #239152315 passed with stages
in 11 minutes and 23 seconds
Package: ufs
Type: Package
Title: Quantitative Analysis Made Accessible
Version: 0.4.0
Version: 0.4.1
Authors@R:
c(
person(given = "Gjalt-Jorn",
......
......@@ -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)
......
......@@ -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
}
}
......
......@@ -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()),
......
......@@ -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);
......
......@@ -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)) {
......
......@@ -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
......
......@@ -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,
...);
......
......@@ -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
......
......@@ -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);
......
......@@ -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) {
......
......@@ -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
......
......@@ -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)),
......
#' 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);
}