From 3ae72f3815b31a1cdcc293bbe5d431fb92d64b9c Mon Sep 17 00:00:00 2001 From: Dominique Makowski Date: Mon, 1 Apr 2019 09:39:51 +0800 Subject: [PATCH 1/4] 0.4.9 --- DESCRIPTION | 2 +- LICENSE | 2 +- NAMESPACE | 5 +- R/analyze.R | 30 - R/analyze.anova.R | 339 - R/analyze.blavaan.R | 219 - R/analyze.fa.R | 262 - R/analyze.glm.R | 185 - R/analyze.glmerMod.R | 205 - R/analyze.htest.R | 145 - R/analyze.lavaan.R | 109 - R/analyze.lm.R | 184 - R/analyze.lmerModLmerTest.R | 210 - R/analyze.principal.R | 43 - R/analyze.stanreg.R | 681 -- R/as.data.frame.density.R | 16 - R/assess.R | 106 - R/bayes_cor.R | 337 - R/cite_packages.R | 42 - R/correlation.R | 330 - R/crawford.test.R | 292 - R/crawford_dissociation.test.R | 86 - R/create_intervals.R | 54 - R/{affective.R => data_affective.R} | 0 R/{emotion.R => data_emotion.R} | 0 R/deprecated.R | 10118 ++++++++++++++++ R/dprime.R | 131 - R/find_best_model.R | 20 - R/find_best_model.lavaan.R | 92 - R/find_best_model.lmerModLmerTest.R | 91 - R/find_best_model.stanreg.R | 139 - R/find_combinations.R | 104 - R/find_distance_cluster.R | 27 - R/find_highest_density_point.R | 18 - R/find_matching_string.R | 33 - R/find_random_effects.R | 19 - R/find_season.R | 39 - R/format_digit.R | 18 + R/formatting.R | 144 - R/get_R2.R | 306 - R/get_contrasts.R | 234 - R/get_data.R | 80 - R/get_formula.R | 54 - R/get_graph.R | 233 - R/get_info.R | 166 - R/get_means.R | 149 - R/get_predicted.R | 20 - R/get_predicted.glm.R | 116 - R/get_predicted.lm.R | 100 - R/get_predicted.merMod.R | 159 - R/get_predicted.stanreg.R | 161 - R/golden.R | 17 - R/hdi.R | 132 - R/interpret_R2.R | 141 - R/interpret_RMSEA.R | 48 - R/interpret_bf.R | 112 - R/interpret_d.R | 174 - R/interpret_lavaan.R | 146 - R/interpret_odds.R | 231 - R/interpret_omega_sq.R | 54 - R/interpret_r.R | 186 - R/is.mixed.R | 49 - R/is.standardized.R | 41 - R/mellenbergh.test.R | 83 - R/model_to_priors.R | 99 - R/mpe.R | 41 - R/n_factors.R | 305 - R/odds_to_probs.R | 81 - R/overlap.R | 40 - R/percentile.R | 33 - R/plot.psychobject.R | 12 - R/power_analysis.R | 89 - R/print.psychobject.R | 13 - R/probs_to_odds.R | 30 - R/psychobject.R | 6 - R/refdata.R | 158 - R/remove_empty_cols.R | 13 - R/remove_outliers.R | 43 - R/rnorm_perfect.R | 26 - R/rope.R | 61 - R/simulate.R | 56 - R/standardize.R | 493 - R/startup_message.R | 3 + R/summary.psychobject.R | 25 - R/values.R | 11 - README.md | 5 +- man/HDImax.Rd | 2 +- man/HDImin.Rd | 2 +- man/R2_LOO_Adjusted.Rd | 2 +- man/R2_nakagawa.Rd | 2 +- man/R2_tjur.Rd | 2 +- man/affective.Rd | 2 +- man/analyze.Rd | 2 +- man/analyze.aov.Rd | 4 +- man/analyze.blavaan.Rd | 2 +- man/analyze.fa.Rd | 4 +- man/analyze.glm.Rd | 2 +- man/analyze.glmerMod.Rd | 2 +- man/analyze.htest.Rd | 2 +- man/analyze.lavaan.Rd | 2 +- man/analyze.lm.Rd | 2 +- man/analyze.lmerModLmerTest.Rd | 2 +- man/analyze.principal.Rd | 4 +- man/analyze.stanreg.Rd | 4 +- man/as.data.frame.density.Rd | 2 +- man/assess.Rd | 2 +- man/bayes_cor.Rd | 2 +- man/bayes_cor.test.Rd | 2 +- man/cite_packages.Rd | 2 +- man/correlation.Rd | 2 +- man/crawford.test.Rd | 2 +- man/crawford.test.freq.Rd | 2 +- man/crawford_dissociation.test.Rd | 4 +- man/create_intervals.Rd | 2 +- man/dprime.Rd | 2 +- man/emotion.Rd | 2 +- man/find_best_model.Rd | 2 +- man/find_best_model.lavaan.Rd | 2 +- man/find_best_model.lmerModLmerTest.Rd | 2 +- man/find_best_model.stanreg.Rd | 2 +- man/find_combinations.Rd | 2 +- man/find_combinations.formula.Rd | 2 +- man/find_distance_cluster.Rd | 2 +- man/find_highest_density_point.Rd | 2 +- man/find_matching_string.Rd | 2 +- man/find_random_effects.Rd | 2 +- man/find_season.Rd | 2 +- man/format_bf.Rd | 2 +- man/format_digit.Rd | 25 +- man/format_formula.Rd | 2 +- man/format_loadings.Rd | 2 +- man/format_p.Rd | 2 +- man/format_string.Rd | 2 +- man/get_R2.Rd | 2 +- man/get_R2.glm.Rd | 2 +- man/get_R2.lm.Rd | 2 +- man/get_R2.merMod.Rd | 2 +- man/get_R2.stanreg.Rd | 2 +- man/get_cfa_model.Rd | 2 +- man/get_contrasts.Rd | 2 +- man/get_contrasts.glm.Rd | 2 +- man/get_contrasts.glmerMod.Rd | 2 +- man/get_contrasts.lm.Rd | 2 +- man/get_contrasts.lmerMod.Rd | 2 +- man/get_contrasts.lmerModLmerTest.Rd | 2 +- man/get_contrasts.stanreg.Rd | 2 +- man/get_data.Rd | 2 +- man/get_formula.Rd | 2 +- man/get_graph.Rd | 2 +- man/get_graph.fa.Rd | 2 +- man/get_graph.lavaan.Rd | 2 +- man/get_graph.psychobject_correlation.Rd | 2 +- man/get_info.Rd | 2 +- man/get_info.lm.Rd | 2 +- man/get_info.lmerModLmerTest.Rd | 2 +- man/get_loadings_max.Rd | 2 +- man/get_means.Rd | 2 +- man/get_predicted.Rd | 2 +- man/get_predicted.glm.Rd | 2 +- man/get_predicted.lm.Rd | 2 +- man/get_predicted.merMod.Rd | 2 +- man/get_predicted.stanreg.Rd | 2 +- man/golden.Rd | 2 +- man/hdi.Rd | 2 +- man/interpret_R2.Rd | 2 +- man/interpret_R2_posterior.Rd | 2 +- man/interpret_RMSEA.Rd | 2 +- man/interpret_bf.Rd | 2 +- man/interpret_d.Rd | 2 +- man/interpret_d_posterior.Rd | 2 +- man/interpret_lavaan.Rd | 2 +- man/interpret_lavaan.blavaan.Rd | 2 +- man/interpret_lavaan.lavaan.Rd | 2 +- man/interpret_odds.Rd | 4 +- man/interpret_odds_posterior.Rd | 2 +- man/interpret_omega_sq.Rd | 2 +- man/interpret_r.Rd | 2 +- man/interpret_r_posterior.Rd | 2 +- man/is.mixed.Rd | 2 +- man/is.mixed.stanreg.Rd | 2 +- man/is.psychobject.Rd | 2 +- man/is.standardized.Rd | 2 +- man/mellenbergh.test.Rd | 2 +- man/model_to_priors.Rd | 2 +- man/mpe.Rd | 4 +- man/n_factors.Rd | 2 +- man/odds_to_d.Rd | 2 +- man/odds_to_probs.Rd | 2 +- man/omega_sq.Rd | 2 +- man/overlap.Rd | 2 +- man/percentile.Rd | 2 +- man/percentile_to_z.Rd | 2 +- man/plot.psychobject.Rd | 2 +- man/plot_loadings.Rd | 2 +- man/power_analysis.Rd | 2 +- man/print.psychobject.Rd | 2 +- man/probs_to_odds.Rd | 2 +- man/refdata.Rd | 2 +- man/remove_empty_cols.Rd | 2 +- man/remove_outliers.Rd | 2 +- man/reorder_matrix.Rd | 2 +- man/rnorm_perfect.Rd | 2 +- man/rope.Rd | 2 +- man/simulate_data_regression.Rd | 2 +- man/standardize.Rd | 2 +- man/standardize.data.frame.Rd | 2 +- man/standardize.glm.Rd | 2 +- man/standardize.lm.Rd | 2 +- man/standardize.numeric.Rd | 2 +- man/standardize.stanreg.Rd | 2 +- man/summary.psychobject.Rd | 2 +- man/values.Rd | 2 +- tests/testthat/test-analyze.aov.R | 23 - tests/testthat/test-analyze.fa.R | 14 - tests/testthat/test-analyze.glm.R | 16 - tests/testthat/test-analyze.glmerMod.R | 20 - tests/testthat/test-analyze.htest.R | 23 - tests/testthat/test-analyze.lavaan.R | 12 - tests/testthat/test-analyze.lm.R | 24 - tests/testthat/test-analyze.lmerModLmerTest.R | 15 - tests/testthat/test-analyze.stanreg.R | 112 - tests/testthat/test-assess.R | 28 - tests/testthat/test-bayes_cor.R | 21 - tests/testthat/test-correlation.R | 61 - tests/testthat/test-crawford.test.R | 54 - .../test-crawford_dissociation.test.R | 12 - tests/testthat/test-create_intervals.R | 10 - tests/testthat/test-deprecated.R | 1233 ++ tests/testthat/test-dprime.R | 17 - tests/testthat/test-find_best_model.stanreg.R | 21 - .../testthat/test-find_combinations.formula.R | 7 - tests/testthat/test-find_matching_string.R | 5 - tests/testthat/test-find_random_effects.R | 7 - tests/testthat/test-find_season.R | 7 - tests/testthat/test-formatting.R | 20 - tests/testthat/test-get_R2.R | 19 - tests/testthat/test-get_contrasts.R | 34 - tests/testthat/test-get_info.R | 28 - tests/testthat/test-get_means.R | 36 - tests/testthat/test-get_predicted.R | 100 - tests/testthat/test-hdi.R | 10 - tests/testthat/test-interpret_R2.R | 11 - tests/testthat/test-interpret_RMSEA.R | 7 - tests/testthat/test-interpret_bf.R | 7 - tests/testthat/test-interpret_d.R | 8 - tests/testthat/test-interpret_odds.R | 10 - tests/testthat/test-interpret_r.R | 6 - tests/testthat/test-is.mixed.stanreg.R | 9 - tests/testthat/test-is.psychobject.R | 7 - tests/testthat/test-is.standardized.R | 8 - tests/testthat/test-mellenbergh.test.R | 25 - tests/testthat/test-model_to_priors.R | 7 - tests/testthat/test-n_factors.R | 11 - tests/testthat/test-odds_to_probs.R | 15 - tests/testthat/test-overlap.R | 7 - tests/testthat/test-plot.psychobject.R | 8 - tests/testthat/test-power_analysis.R | 8 - tests/testthat/test-print.psychobject.R | 8 - tests/testthat/test-probs_to_odds.R | 6 - tests/testthat/test-refdata.R | 9 - tests/testthat/test-remove_empty_cols.R | 11 - tests/testthat/test-rnorm_perfect.R | 9 - tests/testthat/test-standardize.R | 63 - tests/testthat/test-values.psychobject.R | 8 - vignettes/bayesian.Rmd | 671 +- vignettes/bayesian.html | 1314 +- vignettes/overview.R | 60 +- vignettes/overview.Rmd | 133 +- vignettes/overview.html | 496 +- 269 files changed, 12152 insertions(+), 12780 deletions(-) delete mode 100644 R/analyze.R delete mode 100644 R/analyze.anova.R delete mode 100644 R/analyze.blavaan.R delete mode 100644 R/analyze.fa.R delete mode 100644 R/analyze.glm.R delete mode 100644 R/analyze.glmerMod.R delete mode 100644 R/analyze.htest.R delete mode 100644 R/analyze.lavaan.R delete mode 100644 R/analyze.lm.R delete mode 100644 R/analyze.lmerModLmerTest.R delete mode 100644 R/analyze.principal.R delete mode 100644 R/analyze.stanreg.R delete mode 100644 R/as.data.frame.density.R delete mode 100644 R/assess.R delete mode 100644 R/bayes_cor.R delete mode 100644 R/cite_packages.R delete mode 100644 R/correlation.R delete mode 100644 R/crawford.test.R delete mode 100644 R/crawford_dissociation.test.R delete mode 100644 R/create_intervals.R rename R/{affective.R => data_affective.R} (100%) rename R/{emotion.R => data_emotion.R} (100%) create mode 100644 R/deprecated.R delete mode 100644 R/dprime.R delete mode 100644 R/find_best_model.R delete mode 100644 R/find_best_model.lavaan.R delete mode 100644 R/find_best_model.lmerModLmerTest.R delete mode 100644 R/find_best_model.stanreg.R delete mode 100644 R/find_combinations.R delete mode 100644 R/find_distance_cluster.R delete mode 100644 R/find_highest_density_point.R delete mode 100644 R/find_matching_string.R delete mode 100644 R/find_random_effects.R delete mode 100644 R/find_season.R create mode 100644 R/format_digit.R delete mode 100644 R/formatting.R delete mode 100644 R/get_R2.R delete mode 100644 R/get_contrasts.R delete mode 100644 R/get_data.R delete mode 100644 R/get_formula.R delete mode 100644 R/get_graph.R delete mode 100644 R/get_info.R delete mode 100644 R/get_means.R delete mode 100644 R/get_predicted.R delete mode 100644 R/get_predicted.glm.R delete mode 100644 R/get_predicted.lm.R delete mode 100644 R/get_predicted.merMod.R delete mode 100644 R/get_predicted.stanreg.R delete mode 100644 R/golden.R delete mode 100644 R/hdi.R delete mode 100644 R/interpret_R2.R delete mode 100644 R/interpret_RMSEA.R delete mode 100644 R/interpret_bf.R delete mode 100644 R/interpret_d.R delete mode 100644 R/interpret_lavaan.R delete mode 100644 R/interpret_odds.R delete mode 100644 R/interpret_omega_sq.R delete mode 100644 R/interpret_r.R delete mode 100644 R/is.mixed.R delete mode 100644 R/is.standardized.R delete mode 100644 R/mellenbergh.test.R delete mode 100644 R/model_to_priors.R delete mode 100644 R/mpe.R delete mode 100644 R/n_factors.R delete mode 100644 R/odds_to_probs.R delete mode 100644 R/overlap.R delete mode 100644 R/percentile.R delete mode 100644 R/plot.psychobject.R delete mode 100644 R/power_analysis.R delete mode 100644 R/print.psychobject.R delete mode 100644 R/probs_to_odds.R delete mode 100644 R/psychobject.R delete mode 100644 R/refdata.R delete mode 100644 R/remove_empty_cols.R delete mode 100644 R/remove_outliers.R delete mode 100644 R/rnorm_perfect.R delete mode 100644 R/rope.R delete mode 100644 R/simulate.R delete mode 100644 R/standardize.R create mode 100644 R/startup_message.R delete mode 100644 R/summary.psychobject.R delete mode 100644 R/values.R delete mode 100644 tests/testthat/test-analyze.aov.R delete mode 100644 tests/testthat/test-analyze.fa.R delete mode 100644 tests/testthat/test-analyze.glm.R delete mode 100644 tests/testthat/test-analyze.glmerMod.R delete mode 100644 tests/testthat/test-analyze.htest.R delete mode 100644 tests/testthat/test-analyze.lavaan.R delete mode 100644 tests/testthat/test-analyze.lm.R delete mode 100644 tests/testthat/test-analyze.lmerModLmerTest.R delete mode 100644 tests/testthat/test-analyze.stanreg.R delete mode 100644 tests/testthat/test-assess.R delete mode 100644 tests/testthat/test-bayes_cor.R delete mode 100644 tests/testthat/test-correlation.R delete mode 100644 tests/testthat/test-crawford.test.R delete mode 100644 tests/testthat/test-crawford_dissociation.test.R delete mode 100644 tests/testthat/test-create_intervals.R create mode 100644 tests/testthat/test-deprecated.R delete mode 100644 tests/testthat/test-dprime.R delete mode 100644 tests/testthat/test-find_best_model.stanreg.R delete mode 100644 tests/testthat/test-find_combinations.formula.R delete mode 100644 tests/testthat/test-find_matching_string.R delete mode 100644 tests/testthat/test-find_random_effects.R delete mode 100644 tests/testthat/test-find_season.R delete mode 100644 tests/testthat/test-formatting.R delete mode 100644 tests/testthat/test-get_R2.R delete mode 100644 tests/testthat/test-get_contrasts.R delete mode 100644 tests/testthat/test-get_info.R delete mode 100644 tests/testthat/test-get_means.R delete mode 100644 tests/testthat/test-get_predicted.R delete mode 100644 tests/testthat/test-hdi.R delete mode 100644 tests/testthat/test-interpret_R2.R delete mode 100644 tests/testthat/test-interpret_RMSEA.R delete mode 100644 tests/testthat/test-interpret_bf.R delete mode 100644 tests/testthat/test-interpret_d.R delete mode 100644 tests/testthat/test-interpret_odds.R delete mode 100644 tests/testthat/test-interpret_r.R delete mode 100644 tests/testthat/test-is.mixed.stanreg.R delete mode 100644 tests/testthat/test-is.psychobject.R delete mode 100644 tests/testthat/test-is.standardized.R delete mode 100644 tests/testthat/test-mellenbergh.test.R delete mode 100644 tests/testthat/test-model_to_priors.R delete mode 100644 tests/testthat/test-n_factors.R delete mode 100644 tests/testthat/test-odds_to_probs.R delete mode 100644 tests/testthat/test-overlap.R delete mode 100644 tests/testthat/test-plot.psychobject.R delete mode 100644 tests/testthat/test-power_analysis.R delete mode 100644 tests/testthat/test-print.psychobject.R delete mode 100644 tests/testthat/test-probs_to_odds.R delete mode 100644 tests/testthat/test-refdata.R delete mode 100644 tests/testthat/test-remove_empty_cols.R delete mode 100644 tests/testthat/test-rnorm_perfect.R delete mode 100644 tests/testthat/test-standardize.R delete mode 100644 tests/testthat/test-values.psychobject.R diff --git a/DESCRIPTION b/DESCRIPTION index c26a509..0516363 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: psycho Type: Package Title: Efficient and Publishing-Oriented Workflow for Psychological Science -Version: 0.4.0 +Version: 0.4.9 Authors@R: c( person("Dominique", "Makowski", diff --git a/LICENSE b/LICENSE index bbed267..156ea7f 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ -YEAR: 2018 +YEAR: 2019 COPYRIGHT HOLDER: Dominique Makowski \ No newline at end of file diff --git a/NAMESPACE b/NAMESPACE index 46e4941..f9725ee 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -156,7 +156,6 @@ import(lmerTest) import(loo) import(ppcor) import(purrr) -import(rstanarm) import(rstantools) import(tidyr) importFrom(BayesFactor,correlationBF) @@ -179,6 +178,8 @@ importFrom(lavaan,fitmeasures) importFrom(lavaan,parameterEstimates) importFrom(lme4,findbars) importFrom(lme4,getME) +importFrom(loo,kfold) +importFrom(loo,loo) importFrom(nFactors,moreStats) importFrom(nFactors,nScree) importFrom(psych,VSS) @@ -187,8 +188,6 @@ importFrom(purrr,discard) importFrom(purrr,keep) importFrom(qgraph,cor_auto) importFrom(rstanarm,bayes_R2) -importFrom(rstanarm,kfold) -importFrom(rstanarm,loo) importFrom(rstanarm,normal) importFrom(scales,rescale) importFrom(stats,approx) diff --git a/R/analyze.R b/R/analyze.R deleted file mode 100644 index d8e2032..0000000 --- a/R/analyze.R +++ /dev/null @@ -1,30 +0,0 @@ -#' Analyze objects. -#' -#' Analyze objects. See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=analyze.stanreg]{analyze.stanreg}} -#' \item{\link[=analyze.lmerModLmerTest]{analyze.merModLmerTest}} -#' \item{\link[=analyze.glmerMod]{analyze.glmerMod}} -#' \item{\link[=analyze.lm]{analyze.lm}} -#' \item{\link[=analyze.glm]{analyze.glm}} -#' } -#' \itemize{ -#' \item{\link[=analyze.htest]{analyze.htest}} -#' \item{\link[=analyze.aov]{analyze.aov}} -#' } -#' \itemize{ -#' \item{\link[=analyze.fa]{analyze.fa}} -#' \item{\link[=analyze.principal]{analyze.principal}} -#' \item{\link[=analyze.lavaan]{analyze.lavaan}} -#' \item{\link[=analyze.blavaan]{analyze.blavaan}} -#' } -#' -#' @param x object to analyze. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -analyze <- function(x, ...) { - UseMethod("analyze") -} diff --git a/R/analyze.anova.R b/R/analyze.anova.R deleted file mode 100644 index 43fe0a6..0000000 --- a/R/analyze.anova.R +++ /dev/null @@ -1,339 +0,0 @@ -#' Analyze aov and anova objects. -#' -#' Analyze aov and anova objects. -#' -#' @param x aov object. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_omega_sq]{interpret_omega_sq}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' df <- psycho::affective -#' -#' x <- aov(df$Tolerating ~ df$Salary) -#' x <- aov(df$Tolerating ~ df$Salary * df$Sex) -#' -#' x <- anova(lm(df$Tolerating ~ df$Salary * df$Sex)) -#' -#' -#' summary(analyze(x)) -#' print(analyze(x)) -#' -#' df <- psycho::emotion %>% -#' mutate(Recall = ifelse(Recall == TRUE, 1, 0)) %>% -#' group_by(Participant_ID, Emotion_Condition) %>% -#' summarise(Recall = sum(Recall) / n()) -#' -#' x <- aov(Recall ~ Emotion_Condition + Error(Participant_ID), data = df) -#' x <- anova(lmerTest::lmer(Recall ~ Emotion_Condition + (1 | Participant_ID), data = df)) -#' analyze(x) -#' summary(x) -#' } -#' -#' @references -#' \itemize{ -#' \item{Levine, T. R., & Hullett, C. R. (2002). Eta squared, partial eta squared, and misreporting of effect size in communication research. Human Communication Research, 28(4), 612-625.} -#' \item{Pierce, C. A., Block, R. A., & Aguinis, H. (2004). Cautionary note on reporting eta-squared values from multifactor ANOVA designs. Educational and psychological measurement, 64(6), 916-924.} -#' } -#' -#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/os2 -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import broom -#' -#' @export -analyze.aov <- function(x, effsize_rules = "field2013", ...) { - if (!"aov" %in% class(x)) { - if (!"Residuals" %in% row.names(x)) { - if (!is.null(x$Within)) { - x <- x$Within - message("(Repeated measures ANOVAs are bad, you should use mixed-models...)") - } else { - return(.analyze.anova_lmer(x)) - } - } - } else { - if (!is.null(x$Within)) { - x <- x$Within - message("(Repeated measures ANOVAs are bad, you should use mixed-models...)") - } - } - - - - - # Processing - # ------------- - - - # Effect Size - omega <- tryCatch({ - omega_sq(x, partial = TRUE) - }, warning = function(w) { - stop("I believe there are within and between subjects variables that caused the error. You should REALLY use mixed-models.") - }) - - - - - all_values <- x %>% - broom::tidy() %>% - dplyr::full_join(data.frame("Omega" = omega) %>% - tibble::rownames_to_column("term"), by = "term") %>% - mutate_("Effect_Size" = "interpret_omega_sq(Omega, rules = 'field2013')") %>% - rename_( - "Effect" = "term", - "Sum_Squares" = "sumsq", - "Mean_Square" = "meansq", - "F" = "statistic", - "p" = "p.value" - ) - - varnames <- all_values$Effect - df_residuals <- all_values[all_values$Effect == "Residuals", ]$df - - values <- list() - for (var in varnames) { - values[[var]] <- list() - current_values <- dplyr::filter_(all_values, "Effect == var") - values[[var]]$df <- current_values$df - values[[var]]$Sum_Squares <- current_values$Sum_Squares - values[[var]]$Mean_Square <- current_values$Mean_Square - values[[var]]$F <- current_values$F - values[[var]]$p <- current_values$p - values[[var]]$Omega <- current_values$Omega - values[[var]]$Effect_Size <- current_values$Effect_Size - - if (var != "Residuals") { - if (current_values$p < .05) { - significance <- "significant" - } else { - significance <- "not significant" - } - - if (grepl(":", var)) { - effect <- "interaction between" - varname <- stringr::str_replace_all(var, ":", " and ") - } else { - varname <- var - effect <- "effect of" - } - - values[[var]]$text <- paste0( - "The ", - effect, - " ", - varname, - " is ", - significance, - " (F(", - current_values$df, - ", ", - df_residuals, - ") = ", - format_digit(current_values$F), - ", p ", - format_p(current_values$p, stars = FALSE), - ") and can be considered as ", - current_values$Effect_Size, - " (Partial Omega-squared = ", - format_digit(current_values$Omega), - ")." - ) - } - } - - # Summary - # ------------- - summary <- all_values - - # Text - # ------------- - text <- c() - for (var in varnames[varnames != "Residuals"]) { - text <- c(text, paste(" -", values[[var]]$text)) - } - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - -#' @export -analyze.anova <- analyze.aov - -#' @export -analyze.aovlist <- analyze.aov - - - -#' @keywords internal -.analyze.anova_lmer <- function(x) { - if (!"NumDF" %in% colnames(x)) { - stop("Cannot analyze the anova from lme4. Please refit the model using lmerTest.") - } - - summary <- x %>% - as.data.frame() %>% - tibble::rownames_to_column("term") %>% - rename_( - "Effect" = "term", - "df" = "NumDF", - "df_Residuals" = "DenDF", - "Sum_Squares" = "`Sum Sq`", - "Mean_Square" = "`Mean Sq`", - "F" = "`F value`", - "p" = "`Pr(>F)`" - ) %>% - select_("Effect", "df", "df_Residuals", "Sum_Squares", "Mean_Square", "F", "p") - - varnames <- summary$Effect - - values <- list() - for (var in varnames) { - values[[var]] <- list() - current_values <- dplyr::filter_(summary, "Effect == var") - values[[var]]$df <- current_values$df - values[[var]]$df_Residuals <- current_values$df_Residuals - values[[var]]$Sum_Squares <- current_values$Sum_Squares - values[[var]]$Mean_Square <- current_values$Mean_Square - values[[var]]$F <- current_values$F - values[[var]]$p <- current_values$p - # values[[var]]$Omega <- current_values$Omega - # values[[var]]$Effect_Size <- current_values$Effect_Size - - if (current_values$p < .05) { - significance <- "significant" - } else { - significance <- "not significant" - } - - if (grepl(":", var)) { - effect <- "interaction between" - varname <- stringr::str_replace_all(var, ":", " and ") - } else { - varname <- var - effect <- "effect of" - } - - values[[var]]$text <- paste0( - "The ", - effect, - " ", - varname, - " is ", - significance, - " (F(", - current_values$df, - ", ", - format_digit(current_values$df_Residuals, 0), - ") = ", - format_digit(current_values$F), - ", p ", - format_p(current_values$p, stars = FALSE), - ")." - ) - } - - - # Text - # ------------- - text <- c() - for (var in varnames[varnames != "Residuals"]) { - text <- c(text, paste(" -", values[[var]]$text)) - } - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - -#' Partial Omega Squared. -#' -#' Partial Omega Squared. -#' -#' @param x aov object. -#' @param partial Return partial omega squared. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' -#' x <- aov(df$Tolerating ~ df$Salary) -#' x <- aov(df$Tolerating ~ df$Salary * df$Sex) -#' -#' omega_sq(x) -#' @seealso http://stats.stackexchange.com/a/126520 -#' -#' @author Arnoud Plantinga -#' @importFrom stringr str_trim -#' @export -omega_sq <- function(x, partial = TRUE) { - if ("aov" %in% class(x)) { - summary_aov <- summary(x)[[1]] - } else { - summary_aov <- x - } - residRow <- nrow(summary_aov) - dfError <- summary_aov[residRow, 1] - msError <- summary_aov[residRow, 3] - nTotal <- sum(summary_aov$Df) - dfEffects <- summary_aov[1:{ - residRow - 1 - }, 1] - ssEffects <- summary_aov[1:{ - residRow - 1 - }, 2] - msEffects <- summary_aov[1:{ - residRow - 1 - }, 3] - ssTotal <- rep(sum(summary_aov[1:residRow, 2]), 3) - Omegas <- abs((ssEffects - dfEffects * msError) / (ssTotal + msError)) - names(Omegas) <- stringr::str_trim(rownames(summary_aov)[1:{ - residRow - 1 - }]) - - partOmegas <- abs((dfEffects * (msEffects - msError)) / - (ssEffects + (nTotal - dfEffects) * msError)) - names(partOmegas) <- stringr::str_trim(rownames(summary_aov)[1:{ - residRow - 1 - }]) - - if (partial == TRUE) { - return(partOmegas) - } else { - return(Omegas) - } -} diff --git a/R/analyze.blavaan.R b/R/analyze.blavaan.R deleted file mode 100644 index 6e24bc8..0000000 --- a/R/analyze.blavaan.R +++ /dev/null @@ -1,219 +0,0 @@ -#' Analyze blavaan (SEM or CFA) objects. -#' -#' Analyze blavaan (SEM or CFA) objects. -#' -#' @param x lavaan object. -#' @param CI Credible interval level. -#' @param standardize Compute standardized coefs. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lavaan) -#' -#' model <- " visual =~ x1 + x2 + x3\ntextual =~ x4 + x5 + x6\nspeed =~ x7 + x8 + x9 " -#' x <- lavaan::cfa(model, data = HolzingerSwineford1939) -#' -#' rez <- analyze(x) -#' print(rez) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso -#' https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM -#' -#' @importFrom lavaan parameterEstimates fitmeasures -#' @importFrom blavaan standardizedposterior -#' -#' @export -analyze.blavaan <- function(x, CI = 90, standardize = FALSE, ...) { - fit <- x - - - # Processing - # ------------- - values <- list() - values$CI <- CI - - # Fit measures - values$Fit_Measures <- interpret_lavaan(fit) - - - # Text - # ------------- - computations <- .get_info_computations(fit) - fitmeasures <- values$Fit_Measures$text - text <- paste0( - "A Bayesian model was fitted (", - computations, - "). The fit indices are as following: ", - fitmeasures - ) - - # Summary - # ------------- - summary <- .summary_blavaan(fit, CI = CI, standardize = standardize) - - # Plot - # ------------- - plot <- "Use `get_graph` in association with ggraph." - - output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - -#' @keywords internal -.get_info_computations <- function(fit) { - chains <- blavaan::blavInspect(fit, "n.chains") - sample <- fit@external$sample - warmup <- fit@external$burnin - text <- paste0( - chains, - " chains, each with iter = ", - sample, - "; warmup = ", - warmup - ) - return(text) -} - - - - -#' @keywords internal -.process_blavaan <- function(fit, standardize = FALSE, CI = 90) { - # Get relevant rows - PE <- parameterEstimates(fit, - se = FALSE, ci = FALSE, remove.eq = FALSE, remove.system.eq = TRUE, - remove.ineq = FALSE, remove.def = FALSE, - add.attributes = TRUE - ) - if (!("group" %in% names(PE))) PE$group <- 1 - newpt <- fit@ParTable - pte2 <- which(newpt$free > 0) - relevant_rows <- match( - with(newpt, paste(lhs[pte2], op[pte2], rhs[pte2], group[pte2], sep = "")), - paste(PE$lhs, PE$op, PE$rhs, PE$group, sep = "") - ) - - # Priors - priors <- rep(NA, nrow(PE)) - priors[relevant_rows] <- newpt$prior[pte2] - priors[is.na(PE$prior)] <- "" - - - - - # Posterior - if (standardize == FALSE) { - posteriors <- blavaan::blavInspect(fit, "draws") %>% - as.matrix() %>% - as.data.frame() - names(posteriors) <- names(lavaan::coef(fit)) - } else { - posteriors <- blavaan::standardizedposterior(fit) %>% - as.data.frame() - } - - - - # Effects - MPE <- c() - Median <- c() - MAD <- c() - Effect <- c() - CI_lower <- c() - CI_higher <- c() - for (effect in names(posteriors)) { - posterior <- posteriors[[effect]] - Effect <- c(Effect, effect) - MPE <- c(MPE, mpe(posterior)$MPE) - Median <- c(Median, median(posterior)) - MAD <- c(MAD, mad(posterior)) - - CI_values <- HDI(posterior, prob = CI / 100) - CI_lower <- c(CI_lower, CI_values$values$HDImin) - CI_higher <- c(CI_higher, CI_values$values$HDImax) - } - - if (standardize == FALSE) { - Effects <- rep(NA, nrow(PE)) - Effects[relevant_rows] <- Effect - MPEs <- rep(NA, nrow(PE)) - MPEs[relevant_rows] <- MPE - Medians <- rep(NA, nrow(PE)) - Medians[relevant_rows] <- Median - MADs <- rep(NA, nrow(PE)) - MADs[relevant_rows] <- MAD - CI_lowers <- rep(NA, nrow(PE)) - CI_lowers[relevant_rows] <- CI_lower - CI_highers <- rep(NA, nrow(PE)) - CI_highers[relevant_rows] <- CI_higher - } else { - Effects <- Effect - MPEs <- MPE - Medians <- Median - MADs <- MAD - CI_lowers <- CI_lower - CI_highers <- CI_higher - } - - data <- data.frame( - "Effect" = Effects, - "Median" = Medians, - "MAD" = MADs, - "MPE" = MPEs, - "CI_lower" = CI_lowers, - "CI_higher" = CI_highers, - "Prior" = priors - ) - - return(data) -} - - - -#' @keywords internal -.summary_blavaan <- function(fit, CI = 90, standardize = FALSE) { - solution <- lavaan::parameterEstimates(fit, se = TRUE, ci = TRUE, standardized = FALSE, level = CI / 100) - - solution <- solution %>% - rename( - "From" = "rhs", - "To" = "lhs", - "Operator" = "op", - "Coef" = "est", - "SE" = "se", - "CI_lower" = "ci.lower", - "CI_higher" = "ci.upper" - ) %>% - mutate(Type = dplyr::case_when( - Operator == "=~" ~ "Loading", - Operator == "~" ~ "Regression", - Operator == "~~" ~ "Correlation", - TRUE ~ NA_character_ - )) %>% - select(one_of(c("To", "Operator", "From", "Type"))) %>% - mutate_("Effect" = "as.character(paste0(To, Operator, From))") %>% - full_join(.process_blavaan(fit, CI = CI, standardize = standardize) %>% - mutate_("Effect" = "as.character(Effect)"), by = "Effect") %>% - select_("-Effect") %>% - mutate_( - "Median" = "replace_na(Median, 1)", - "MAD" = "replace_na(MAD, 0)", - "MPE" = "replace_na(MPE, 100)" - ) %>% - select(one_of(c("From", "Operator", "To", "Median", "MAD", "CI_lower", "CI_higher", "MPE", "Prior", "Type"))) %>% - dplyr::filter_("Operator != '~1'") - - - return(solution) -} diff --git a/R/analyze.fa.R b/R/analyze.fa.R deleted file mode 100644 index 30c6d47..0000000 --- a/R/analyze.fa.R +++ /dev/null @@ -1,262 +0,0 @@ -#' Analyze fa objects. -#' -#' Analyze fa objects. -#' -#' @param x An psych object. -#' @param labels Supply a additional column with e.g. item labels. -#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(psych) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' -#' results <- analyze(x) -#' print(results) -#' summary(results) -#' plot(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -analyze.fa <- function(x, labels = NULL, treshold = "max", ...) { - loadings <- format_loadings(x, labels) - - values <- list() - values$variance <- x$Vaccounted - values$loadings <- loadings$loadings - values$loadings_max <- loadings$max - values$cfa_model <- get_cfa_model(loadings$loadings, treshold = treshold) - - text <- .fa_variance_text(values$variance) - text <- paste0(text, "\n\n", format(values$cfa_model)) - summary <- values$loadings - plot <- plot_loadings(values$loadings) - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - -#' @export -.fa_variance_text <- function(variance) { - variance <- as.data.frame(variance) - n_factors <- ncol(variance) - - if (ncol(variance) == 1) { - t <- as.data.frame(t(variance)) - tot_var <- t$`Proportion Var` - text <- paste0( - "The unique component accounted for ", - format_digit(tot_var * 100), - "% of the total variance." - ) - } else { - t <- as.data.frame(t(variance)) - tot_var <- max(t$`Cumulative Var`) - - factors <- names(variance) - var <- variance["Proportion Var", ] - text_var <- paste0(factors, - " = ", - format_digit(var * 100), - "%", - collapse = ", " - ) - - text <- paste0( - "The ", - n_factors, - " components accounted for ", - format_digit(tot_var * 100), - "% of the total variance (" - ) - text <- paste0(text, text_var, ").") - } - - return(text) -} - - - - - - - -#' Format the loadings of a factor analysis. -#' -#' Format the loadings of a factor analysis. -#' -#' @param x An psych object. -#' @param labels Supply a additional column with e.g. item labels. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' format_loadings(x) -#' } -#' -#' @import dplyr -#' @export -format_loadings <- function(x, labels = NULL) { - - - # Check loadings and remove those inferior to a treshold - loadings <- x$loadings %>% - unclass() %>% - as.data.frame() - - # Save n factors - n_factors <- length(loadings) - - # Add item labels - loadings$Item <- rownames(loadings) - if (length(labels) == nrow(loadings)) { - loadings$Label <- labels - } else { - loadings$Label <- 1:nrow(loadings) - } - - # Keep Order - loadings$N <- 1:nrow(loadings) - - - # Select the max loading for each item - max <- get_loadings_max(loadings) - - - # Reorder the loading matrix accordingly - loadings <- loadings[max$N, ] %>% - select_("N", "Item", "Label", "everything()") - - return(list(loadings = loadings, max = max)) -} - - - -#' Get loadings max. -#' -#' Get loadings max. -#' -#' @param loadings Formatted loadings. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' get_loadings_max(format_loadings(x)$loadings) -#' } -#' -#' @import dplyr -#' @export -get_loadings_max <- function(loadings) { - max <- loadings %>% - tidyr::gather_("Component", "Loading", names(loadings)[!names(loadings) %in% c("Item", "N", "Label")]) %>% - dplyr::group_by_("Item") %>% - dplyr::slice_("which.max(abs(Loading))") %>% - dplyr::arrange_("Component", "desc(Loading)") - return(max) -} - - - -#' Get CFA model. -#' -#' Get CFA model. -#' -#' @param loadings Formatted loadings. -#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' loadings <- format_loadings(x)$loadings -#' get_cfa_model(loadings, treshold = "max") -#' get_cfa_model(loadings, treshold = 0.1) -#' } -#' -#' @import dplyr -#' @export -get_cfa_model <- function(loadings, treshold = "max") { - if (treshold == "max") { - filtered_loadings <- get_loadings_max(loadings) - } else { - filtered_loadings <- loadings %>% - tidyr::gather_("Component", "Loading", names(loadings)[!names(loadings) %in% c("Item", "N", "Label")]) %>% - filter_("Loading > treshold") - } - - cfa_model <- filtered_loadings %>% - select_("Item", "Component") %>% - group_by_("Component") %>% - summarise_("Observed" = 'paste(Item, collapse=" + ")') %>% - transmute_("Latent_Variable" = 'paste(Component, Observed, sep=" =~ ")') %>% - pull() - - cfa_model <- c("#Latent variables", cfa_model) %>% - paste(collapse = "\n") - - return(cfa_model) -} - - - - -#' Plot loadings. -#' -#' Plot loadings. -#' -#' @param loadings Loadings by variable. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' plot_loadings(format_loadings(x)$loadings) -#' } -#' -#' @import dplyr -#' @export -plot_loadings <- function(loadings) { - if (all(loadings$Label != loadings$N)) { - loadings$Item <- paste0(loadings$Label, " (", loadings$Item, ")") - } - - p <- loadings %>% - gather("Component", "Loading", matches("\\d$")) %>% - mutate_("Loading" = "abs(Loading)") %>% - mutate_("Item" = "factor(Item, levels=rev(get_loadings_max(loadings)$Item))") %>% - ggplot(aes_string(y = "Loading", x = "Item", fill = "Component")) + - geom_bar(stat = "identity") + - coord_flip() + - ylab("\nLoading Strength") + - xlab("Item\n") - - return(p) -} diff --git a/R/analyze.glm.R b/R/analyze.glm.R deleted file mode 100644 index 28792f6..0000000 --- a/R/analyze.glm.R +++ /dev/null @@ -1,185 +0,0 @@ -#' Analyze glm objects. -#' -#' Analyze glm objects. -#' -#' @param x glm object. -#' @param CI Confidence interval bounds. Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @seealso \link[=get_R2.glm]{"get_R2.glm"} -#' -#' @import dplyr -#' @importFrom stats formula -#' @importFrom stringr str_squish -#' @export -analyze.glm <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - if (fit$family$family != "binomial") { - stop(paste("Models of family", fit$family$family, "not supported yet.")) - } - - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # R2 <- tjur_D(fit) - R2 <- get_R2(fit, method = "nakagawa") - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$z <- summary$`z.value` - summary$p <- summary$`Pr...z..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_odds(tail(summary$Coef_std, -1), log = TRUE, rules = effsize_rules)) - - summary <- dplyr::select_( - summary, "Variable", "Coef", "SE", "z", "Coef_std", "SE_std", - "p", "Effect_Size" - ) - - if (!is.null(CI)) { - CI_values <- suppressMessages(confint(fit, level = CI / 100)) - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"], null_treshold = 0.0001), - ", ", - format_digit(summary[varname, "CI_higher"], null_treshold = 0.0001), - "]" - ) - } else { - CI_text <- "" - } - - - - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", z = ", - format_digit(summary[varname, "z"], 2), ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), ")." - ) - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - CI_lower = summary[varname, "CI_lower"], - CI_higher = summary[varname, "CI_higher"], - z = summary[varname, "z"], - Coef_std = summary[varname, "Coef_std"], - SE_std = summary[varname, "SE_std"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - outcome, - " (formula = ", - stringr::str_squish(paste0(format(stats::formula(fit)), collapse = "")), - ") has an explanatory power of ", - format_digit(R2 * 100, 2), - "%. ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/analyze.glmerMod.R b/R/analyze.glmerMod.R deleted file mode 100644 index 07109b8..0000000 --- a/R/analyze.glmerMod.R +++ /dev/null @@ -1,205 +0,0 @@ -#' Analyze glmerMod objects. -#' -#' Analyze glmerMod objects. -#' -#' @param x merModLmerTest object. -#' @param CI Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @importFrom MuMIn r.squaredGLMM -#' @importFrom MuMIn std.coef -#' @importFrom stringr str_squish -#' @import lmerTest -#' @import dplyr -#' @export -analyze.glmerMod <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - info <- get_info(fit) - R2 <- tryCatch({ - get_R2(fit) - }, error = function(e) { - warning("Couldn't compute R2. Might be caused by the presence of missing data.") - R2 <- list(R2m = NA, R2c = NA) - return(R2) - }) - - - - - - - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$z <- summary$`z.value` - summary$p <- summary$`Pr...z..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_odds(tail(summary$Coef_std, -1), log = TRUE, rules = effsize_rules)) - - - # Summary - summary <- dplyr::select_(summary, "Variable", "Coef", "SE", "z", "p", "Coef_std", "SE_std", "Effect_Size") - - # CI computation - if (!is.null(CI)) { - CI_values <- tryCatch({ - suppressMessages(confint(fit, level = CI / 100)) - }, error = function(e) { - warning("Couldn't compute CI. Skipping.") - CI_values <- NA - return(CI_values) - }) - if (!all(is.na(CI_values))) { - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } else { - CI <- NULL - } - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - values$model$R2m <- R2$R2m - values$model$R2c <- R2$R2c - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"], null_treshold = 0.0001), - ", ", - format_digit(summary[varname, "CI_higher"], null_treshold = 0.0001), - "]" - ) - } else { - CI_text <- "" - } - - - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } else { - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), - ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", z = ", - format_digit(summary[varname, "z"], 2), - ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), - ")." - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - z = summary[varname, "z"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - info$outcome, - " (formula = ", - format(info$formula), - ") has an explanatory power (conditional R2) of ", - format_digit(R2$R2c * 100, 2), - "%, in which the fixed effects' part is ", - format_digit(R2$R2m * 100, 2), "% (marginal R2). ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/analyze.htest.R b/R/analyze.htest.R deleted file mode 100644 index ae16acf..0000000 --- a/R/analyze.htest.R +++ /dev/null @@ -1,145 +0,0 @@ -#' Analyze htest (correlation, t-test...) objects. -#' -#' Analyze htest (correlation, t-test...) objects. -#' -#' @param x htest object. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' -#' x <- t.test(df$Tolerating, df$Adjusting) -#' x <- t.test(df$Tolerating ~ df$Sex) -#' x <- t.test(df$Tolerating, mu = 2) -#' x <- cor.test(df$Tolerating, df$Adjusting) -#' -#' results <- analyze(x) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' -#' @export -analyze.htest <- function(x, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - values <- list() - values$method <- x$method - values$names <- x$data.name - values$statistic <- x$statistic - values$effect <- x$estimate - values$p <- x$p.value - values$df <- x$parameter - values$CI <- x$conf.int - values$signif <- ifelse(values$p < .05, "significant", "not significant") - values$CI_level <- attr(values$CI, "conf.level") * 100 - values$CI_format <- paste0(values$CI_level, "% CI [", format_digit(values$CI[1]), ", ", format_digit(values$CI[2]), "]") - - - - # Text - # ------------- - - # CORRELATION - if (grepl("correlation", values$method)) { - text <- paste0( - "The ", - values$method, - " between ", - values$names, - " is ", - values$signif, - ", ", - interpret_r(values$effect, rules = effsize_rules), - " (r(", - format_digit(values$df), - ") = ", - format_digit(values$effect), - ", ", - values$CI_format, - ", p ", - format_p(values$p, stars = FALSE), - ")." - ) - - # T-TEST - } else if (grepl("t-test", values$method)) { - if (names(x$null.value) == "mean") { - means <- paste0( - " (mean = ", - format_digit(values$effect), - ")" - ) - vars <- paste0(values$names, means, " and mu = ", x$null.value) - } else { - means <- paste0( - c( - paste0( - names(values$effect), " = ", - format_digit(values$effect) - ), - paste0( - "difference = ", - format_digit(values$effect[1] - values$effect[2]) - ) - ), - collapse = ", " - ) - vars <- paste0(values$names, " (", means, ")") - } - - values$effect <- values$effect[1] - values$effect[2] - - text <- paste0( - "The ", - values$method, - " suggests that the difference ", - ifelse(grepl(" by ", values$names), "of ", "between "), - vars, - " is ", - values$signif, - " (t(", - format_digit(values$df), - ") = ", - format_digit(values$statistic), - ", ", - values$CI_format, - ", p ", - format_p(values$p, stars = FALSE), - ")." - ) - # OTHER - } else { - stop(paste0("The ", values$method, " is not implemented yet.")) - } - - - # Summary - # ------------- - summary <- data.frame( - effect = values$effect, - statistic = values$statistic, - df = values$df, - p = values$p, - CI_lower = values$CI[1], - CI_higher = values$CI[2] - ) - rownames(summary) <- NULL - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/analyze.lavaan.R b/R/analyze.lavaan.R deleted file mode 100644 index a9fd6ef..0000000 --- a/R/analyze.lavaan.R +++ /dev/null @@ -1,109 +0,0 @@ -#' Analyze lavaan SEM or CFA) objects. -#' -#' Analyze lavaan (SEM or CFA) objects. -#' -#' @param x lavaan object. -#' @param CI Confidence interval level. -#' @param standardize Compute standardized coefs. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lavaan) -#' -#' model <- " visual =~ x1 + x2 + x3\ntextual =~ x4 + x5 + x6\nspeed =~ x7 + x8 + x9 " -#' x <- lavaan::cfa(model, data = HolzingerSwineford1939) -#' -#' rez <- analyze(x) -#' print(rez) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso -#' https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM -#' -#' -#' @importFrom lavaan parameterEstimates fitmeasures -#' -#' @export -analyze.lavaan <- function(x, CI = 95, standardize = FALSE, ...) { - fit <- x - - - # Processing - # ------------- - values <- list() - values$CI <- CI - - # Fit measures - values$Fit_Measures <- interpret_lavaan(fit) - - - - - # Summary - # ------------- - summary <- .summary_lavaan(fit, CI = CI, standardize = standardize) - - # Plot - # ------------- - plot <- "Use `get_graph` in association with ggraph." - - output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - - - - - -#' @keywords internal -.summary_lavaan <- function(fit, CI = 95, standardize = FALSE) { - if (standardize == FALSE) { - solution <- lavaan::parameterEstimates(fit, se = TRUE, standardized = standardize, level = CI / 100) - } else { - solution <- lavaan::standardizedsolution(fit, se = TRUE, level = CI / 100) %>% - rename_("est" = "est.std") - } - - solution <- solution %>% - rename( - "From" = "rhs", - "To" = "lhs", - "Operator" = "op", - "Coef" = "est", - "SE" = "se", - "p" = "pvalue", - "CI_lower" = "ci.lower", - "CI_higher" = "ci.upper" - ) %>% - mutate(Type = dplyr::case_when( - Operator == "=~" ~ "Loading", - Operator == "~" ~ "Regression", - Operator == "~~" ~ "Correlation", - TRUE ~ NA_character_ - )) %>% - mutate_("p" = "replace_na(p, 0)") - - if ("group" %in% names(solution)) { - solution <- solution %>% - rename("Group" = "group") %>% - select(one_of(c("Group", "From", "Operator", "To", "Coef", "SE", "CI_lower", "CI_higher", "p", "Type"))) - } else { - solution <- select(solution, one_of(c("From", "Operator", "To", "Coef", "SE", "CI_lower", "CI_higher", "p", "Type"))) - } - - return(solution) -} diff --git a/R/analyze.lm.R b/R/analyze.lm.R deleted file mode 100644 index 0e1a86b..0000000 --- a/R/analyze.lm.R +++ /dev/null @@ -1,184 +0,0 @@ -#' Analyze lm objects. -#' -#' Analyze lm objects. -#' -#' @param x lm object. -#' @param CI Confidence interval bounds. Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) -#' fit <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris) -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' @importFrom stats formula -#' @importFrom stringr str_squish -#' @export -analyze.lm <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - R2 <- get_R2(fit) - R2adj <- R2$R2.adj - R2 <- R2$R2 - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$t <- summary$`t.value` - summary$p <- summary$`Pr...t..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit", data = data), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_d(tail(summary$Coef_std, -1), rules = effsize_rules)) - - summary <- dplyr::select_( - summary, "Variable", "Coef", "SE", "t", "Coef_std", "SE_std", - "p", "Effect_Size" - ) - - if (!is.null(CI)) { - CI_values <- confint(fit, level = CI / 100) - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - values$model$R2 <- R2 - values$model$R2adj <- R2adj - - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"], null_treshold = 0.0001), - ", ", - format_digit(summary[varname, "CI_higher"], null_treshold = 0.0001), - "]" - ) - } else { - CI_text <- "" - } - - - - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", t = ", - format_digit(summary[varname, "t"], 2), ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), ")." - ) - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - CI_lower = summary[varname, "CI_lower"], - CI_higher = summary[varname, "CI_higher"], - t = summary[varname, "t"], - Coef_std = summary[varname, "Coef_std"], - SE_std = summary[varname, "SE_std"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - outcome, - " (formula = ", - stringr::str_squish(paste0(format(stats::formula(fit)), collapse = "")), - ") explains ", - format_digit(R2 * 100, 2), - "% of the variance of the endogen (adj. R2 = ", - format_digit(R2adj * 100, 2), - "). ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/analyze.lmerModLmerTest.R b/R/analyze.lmerModLmerTest.R deleted file mode 100644 index 828196c..0000000 --- a/R/analyze.lmerModLmerTest.R +++ /dev/null @@ -1,210 +0,0 @@ -#' Analyze lmerModLmerTest objects. -#' -#' Analyze lmerModLmerTest objects. -#' -#' @param x lmerModLmerTest object. -#' @param CI Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lmerTest) -#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @importFrom MuMIn r.squaredGLMM -#' @importFrom MuMIn std.coef -#' @importFrom stringr str_squish -#' @import dplyr -#' @export -analyze.lmerModLmerTest <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - info <- get_info(fit) - R2 <- get_R2(fit) - - - - # TODO: Bootstrapped p values - # nsim determines p-value decimal places - # boot.out = lme4::bootMer(fit, lme4::fixef, nsim=1000) - # p = rbind( - # (1-apply(boot.out$t<0, 2, mean))*2, - # (1-apply(boot.out$t>0, 2, mean))*2) - # p = apply(p, 2, min) - - - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$df <- as.numeric(summary$df) - summary$t <- summary$`t.value` - summary$p <- summary$`Pr...t..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_d(tail(summary$Coef_std, -1), rules = effsize_rules)) - - summary <- dplyr::select_( - summary, "Variable", "Coef", "SE", "t", "df", "p", "Coef_std", "SE_std", "Effect_Size" - ) - - # CI computation - if (!is.null(CI)) { - CI_values <- tryCatch({ - suppressMessages(confint(fit, level = CI / 100)) - }, error = function(e) { - warning("Couldn't compute CI. Skipping.") - CI_values <- NA - return(CI_values) - }) - if (!all(is.na(CI_values))) { - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } else { - CI <- NULL - } - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - values$model$R2m <- R2$R2m - values$model$R2c <- R2$R2c - - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"], null_treshold = 0.0001), - ", ", - format_digit(summary[varname, "CI_higher"], null_treshold = 0.0001), - "]" - ) - } else { - CI_text <- "" - } - - - - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } else { - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), - ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", t(", - format_digit(summary[varname, "df"], 0), - ") = ", - format_digit(summary[varname, "t"], 2), - ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), - ")." - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - CI_lower = summary[varname, "CI_lower"], - CI_higher = summary[varname, "CI_higher"], - t = summary[varname, "t"], - df = summary[varname, "df"], - Coef_std = summary[varname, "Coef_std"], - SE_std = summary[varname, "SE_std"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - info$outcome, - " (formula = ", - format(info$formula), - ") has an total explanatory power (conditional R2) of ", - format_digit(R2$R2c * 100, 2), - "%, in which the fixed effects explain ", - format_digit(R2$R2m * 100, 2), "% of the variance (marginal R2). ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/analyze.principal.R b/R/analyze.principal.R deleted file mode 100644 index 2b80261..0000000 --- a/R/analyze.principal.R +++ /dev/null @@ -1,43 +0,0 @@ -#' Analyze fa objects. -#' -#' Analyze fa objects. -#' -#' @param x An psych object. -#' @param labels Supply a additional column with e.g. item labels. -#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(psych) -#' -#' x <- psych::pca(psych::Thurstone.33, 2) -#' -#' results <- analyze(x) -#' print(results) -#' summary(results) -#' plot(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -analyze.principal <- function(x, labels = NULL, treshold = "max", ...) { - loadings <- format_loadings(x, labels) - - values <- list() - values$variance <- x$Vaccounted - values$loadings <- loadings$loadings - values$loadings_max <- loadings$max - values$cfa_model <- get_cfa_model(loadings$loadings, treshold = treshold) - - text <- .fa_variance_text(values$variance) - text <- paste0(text, "\n\n", format(values$cfa_model)) - summary <- values$loadings - plot <- plot_loadings(values$loadings) - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/analyze.stanreg.R b/R/analyze.stanreg.R deleted file mode 100644 index 96f0c1c..0000000 --- a/R/analyze.stanreg.R +++ /dev/null @@ -1,681 +0,0 @@ -#' Analyze stanreg objects. -#' -#' Analyze stanreg objects. -#' -#' @param x A stanreg model. -#' @param CI Credible interval bounds. -#' @param index Index of effect existence to report. Can be 'overlap' or 'ROPE'. -#' @param ROPE_bounds Bounds of the ROPE. If NULL and effsize is TRUE, than the ROPE. -#' will have default values c(-0.1, 0.1) and computed on the standardized posteriors. -#' @param effsize Compute Effect Sizes according to Cohen (1988). For linear models only. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return Contains the following indices: -#' \itemize{ -#' \item{the Median of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models).} -#' \item{the Median Absolute Deviation (MAD), a robust measure of dispertion (could be seen as a robust version of SD).} -#' \item{the Credible Interval (CI) (by default, the 90\% CI; see Kruschke, 2018), representing a range of possible parameter.} -#' \item{the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).} -#' \item{the Overlap (O), the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution.} -#' \item{the ROPE, the proportion of the 95\% CI of the posterior distribution that lies within the region of practical equivalence.} -#' } -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' data <- attitude -#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) -#' -#' results <- analyze(fit, effsize = TRUE) -#' summary(results) -#' print(results) -#' plot(results) -#' -#' -#' fit <- rstanarm::stan_lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -#' results <- analyze(fit) -#' summary(results) -#' -#' fit <- rstanarm::stan_glm(Sex ~ Adjusting, -#' data = psycho::affective, family = "binomial" -#' ) -#' results <- analyze(fit) -#' summary(results) -#' -#' fit <- rstanarm::stan_glmer(Sex ~ Adjusting + (1 | Salary), -#' data = psycho::affective, family = "binomial" -#' ) -#' results <- analyze(fit) -#' summary(results) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso -#' \link[=get_R2.stanreg]{"get_R2.stanreg"} -#' \link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} -#' -#' @import rstanarm -#' @import loo -#' @import tidyr -#' @import dplyr -#' @import ggplot2 -#' @importFrom stats quantile as.formula -#' @importFrom utils head tail capture.output -#' @importFrom broom tidy -#' @importFrom stringr str_squish str_replace -#' @export -analyze.stanreg <- function(x, CI = 90, index = "overlap", ROPE_bounds = NULL, effsize = FALSE, effsize_rules = "cohen1988", ...) { - fit <- x - - # Info -------------------------------------------------------------------- - - # Algorithm - if (fit$algorithm == "optimizing") { - stop("Can't analyze models fitted with 'optimizing' algorithm.") - } - computations <- capture.output(fit$stanfit) - computations <- paste0(computations[2], computations[3], collapse = "") - computations <- stringr::str_remove_all(computations, ", total post-warmup draws.*") - computations <- stringr::str_remove_all(computations, " draws per chain") - computations <- stringr::str_replace_all(computations, "=", " = ") - - # Extract posterior distributions - posteriors <- as.data.frame(fit) - - - # Varnames - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - varnames <- names(fit$coefficients) - varnames <- varnames[grepl("b\\[", varnames) == FALSE] - - # Initialize empty values - values <- list(model = list(), effects = list()) - - values$model$formula <- fit$formula - values$model$outcome <- outcome - values$model$predictors <- predictors - - # Priors - info_priors <- rstanarm::prior_summary(fit) - values$priors <- info_priors - - # R2 ---------------------------------------------------------------------- - - R2 <- get_R2(fit, silent = TRUE) - if (is.list(R2)) { - posteriors$R2 <- R2$R2_posterior - R2.adj <- R2$R2.adj - if (!"R2" %in% varnames) { - varnames <- c("R2", varnames) - } - R2 <- TRUE - } else { - R2 <- FALSE - } - - # Random effect info -------------------------------------------- - if (is.mixed(fit)) { - random_info <- broom::tidy(fit, parameters = "varying") %>% - dplyr::rename_( - "Median" = "estimate", - "MAD" = "std.error" - ) - values$random <- random_info - } - - # Standardized posteriors -------------------------------------------- - if (effsize == TRUE) { - posteriors_std <- standardize(fit, method = "refit") - # Avoir some problems - if (length(setdiff(names(posteriors_std), varnames[varnames != "R2"])) != 0) { - names(posteriors_std) <- varnames[varnames != "R2"] - } - } else { - posteriors_std <- as.data.frame(fit) - } - - # Get indices of each variable -------------------------------------------- - - # Loop over all variables - for (varname in varnames) { - if (varname == "R2") { - values$effects[[varname]] <- .process_R2(varname, - posteriors, - info_priors, - R2.adj = R2.adj, - CI = CI, - effsize = effsize - ) - } else if (varname == "(Intercept)") { - values$effects[[varname]] <- .process_intercept(varname, - posteriors, - info_priors, - predictors, - CI = CI, - effsize = effsize - ) - } else { - values$effects[[varname]] <- .process_effect(varname, - posteriors, - posteriors_std = posteriors_std, - info_priors, - predictors, - CI = CI, - effsize = effsize, - effsize_rules = effsize_rules, - fit = fit, - index = index, - ROPE_bounds = ROPE_bounds - ) - } - } - - - # Summary -------------------------------------------------------------------- - summary <- data.frame() - for (varname in varnames) { - summary <- rbind( - summary, - data.frame( - Variable = varname, - Median = values$effects[[varname]]$median, - MAD = values$effects[[varname]]$mad, - CI_lower = values$effects[[varname]]$CI_values[1], - CI_higher = values$effects[[varname]]$CI_values[2], - Median_std = values$effects[[varname]]$std_median, - MAD_std = values$effects[[varname]]$std_mad, - MPE = values$effects[[varname]]$MPE, - ROPE = values$effects[[varname]]$ROPE, - Overlap = values$effects[[varname]]$overlap - ) - ) - } - - if (effsize == FALSE) { - summary <- select_(summary, "-Median_std", "-MAD_std") - } - - if (index == "ROPE") { - summary <- select_(summary, "-Overlap") - } else { - summary <- select_(summary, "-ROPE") - } - - # Text -------------------------------------------------------------------- - # ------------------------------------------------------------------------- - # Model - info <- paste0( - "We fitted a ", - ifelse(fit$algorithm == "sampling", "Markov Chain Monte Carlo", fit$algorithm), - " ", - fit$family$family, - " (link = ", - fit$family$link, - ") model (", - computations, - ") to predict ", - outcome, - " (formula = ", stringr::str_squish(paste0(format(fit$formula), collapse = "")), - "). The model's priors were set as follows: " - ) - - # Priors - text_priors <- rstanarm::prior_summary(fit) - if ("adjusted_scale" %in% names(text_priors$prior) & !is.null(text_priors$prior$adjusted_scale)) { - scale <- paste0( - "), scale = (", - paste(sapply(text_priors$prior$adjusted_scale, format_digit), collapse = ", ") - ) - } else { - scale <- paste0( - "), scale = (", - paste(sapply(text_priors$prior$scale, format_digit), collapse = ", ") - ) - } - - info_priors_text <- paste0( - " ~ ", - text_priors$prior$dist, - " (location = (", - paste(text_priors$prior$location, collapse = ", "), - scale, - "))" - ) - - # Coefs - coefs_text <- c() - for (varname in varnames) { - effect_text <- values$effects[[varname]]$text - if (effsize == TRUE) { - if (!varname %in% c("(Intercept)", "R2")) { - effsize_text <- stringr::str_replace( - values$effects[[varname]]$EffSize_text, - "The effect's size", - "It" - )[1] - effect_text <- paste(effect_text, effsize_text) - } - } - coefs_text <- c(coefs_text, effect_text) - } - - # Text - if ("R2" %in% varnames) { - text <- c( - info, - "", - info_priors_text, - "", - "", - paste0( - coefs_text[1], - coefs_text[2] - ), - "", - tail(coefs_text, -2) - ) - } else { - text <- c( - info, - "", - info_priors_text, - "", - "", - coefs_text[1], - "", - tail(coefs_text, -1) - ) - } - - - - - # Plot -------------------------------------------------------------------- - # ------------------------------------------------------------------------- - - plot <- posteriors[varnames] %>% - # select(-`(Intercept)`) %>% - gather() %>% - rename_(Variable = "key", Coefficient = "value") %>% - ggplot(aes_string(x = "Variable", y = "Coefficient", fill = "Variable")) + - geom_violin() + - geom_boxplot(fill = "grey", alpha = 0.3, outlier.shape = NA) + - stat_summary( - fun.y = "mean", geom = "errorbar", - aes_string(ymax = "..y..", ymin = "..y.."), - width = .75, linetype = "dashed", colour = "red" - ) + - geom_hline(aes(yintercept = 0)) + - theme_classic() + - coord_flip() + - scale_fill_brewer(palette = "Set1") + - scale_colour_brewer(palette = "Set1") - - - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - - - - - - - - - - - -#' @keywords internal -.get_info_priors <- function(varname, info_priors, predictors = NULL) { - # Prior - # TBD: this doesn't work with categorical predictors :( - values <- list() - - if (varname == "(Intercept)") { - values["prior_distribution"] <- info_priors$prior_intercept$dist - values["prior_location"] <- info_priors$prior_intercept$location - values["prior_scale"] <- info_priors$prior_intercept$scale - values["prior_adjusted_scale"] <- info_priors$prior_intercept$adjusted_scale - } else { - if (varname %in% predictors) { - predictor_index <- which(predictors == varname) - if (length(info_priors$prior$dist) == 1) { - info_priors$prior$dist <- rep( - info_priors$prior$dist, - length(info_priors$prior$location) - ) - } - values["prior_distribution"] <- info_priors$prior$dist[predictor_index] - values["prior_location"] <- info_priors$prior$location[predictor_index] - values["prior_scale"] <- info_priors$prior$scale[predictor_index] - values["prior_adjusted_scale"] <- info_priors$prior$adjusted_scale[predictor_index] - } - } - return(values) -} - - - - - - - - -#' @keywords internal -.process_R2 <- function(varname, posteriors, info_priors, R2.adj = NULL, CI = 90, effsize = FALSE) { - values <- .get_info_priors(varname, info_priors) - posterior <- posteriors[, varname] - - # Find basic posterior indices - values$posterior <- posterior - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- NA - values$MPE_values <- NA - values$overlap <- NA - values$ROPE <- NA - values$adjusted_r_squared <- R2.adj - - # Text - values$text <- paste0( - "The model has an explanatory power (R2) of about ", - format_digit(values$median * 100), - "% (MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1], null_treshold = 0.0001), - ", ", - format_digit(values$CI_values[2], null_treshold = 0.0001), - "]" - ) - - if (is.null(R2.adj) | is.na(R2.adj)) { - values$text <- paste0( - values$text, - ")." - ) - } else { - values$text <- paste0( - values$text, - ", adj. R2 = ", - format_digit(R2.adj), - ")." - ) - } - - - # Effize - if (effsize == TRUE) { - values$std_posterior <- NA - values$std_median <- NA - values$std_mad <- NA - values$std_mean <- NA - values$std_sd <- NA - values$std_CI_values <- NA - values$std_CI_values <- NA - - values$EffSize <- NA - values$EffSize_text <- NA - values$EffSize_VeryLarge <- NA - values$EffSize_Large <- NA - values$EffSize_Moderate <- NA - values$EffSize_Small <- NA - values$EffSize_VerySmall <- NA - values$EffSize_Opposite <- NA - } else { - values$std_median <- NA - values$std_mad <- NA - } - - return(values) -} - - - - -#' @keywords internal -.process_intercept <- function(varname, posteriors, info_priors, predictors, CI = 90, effsize = FALSE) { - values <- .get_info_priors(varname, info_priors, predictors) - posterior <- posteriors[, varname] - - # Find basic posterior indices - values$posterior <- posterior - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- NA - values$MPE_values <- NA - values$overlap <- NA - values$ROPE <- NA - - - - # Text - values$text <- paste0( - " The intercept is at ", - format_digit(values$median), - " (MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1], null_treshold = 0.0001), - ", ", - format_digit(values$CI_values[2], null_treshold = 0.0001), - "]). Within this model:" - ) - - # Effize - if (effsize == TRUE) { - values$std_posterior <- NA - values$std_median <- NA - values$std_mad <- NA - values$std_mean <- NA - values$std_sd <- NA - values$std_CI_values <- NA - values$std_CI_values <- NA - - values$EffSize <- NA - values$EffSize_text <- NA - values$EffSize_VeryLarge <- NA - values$EffSize_Large <- NA - values$EffSize_Moderate <- NA - values$EffSize_Small <- NA - values$EffSize_VerySmall <- NA - values$EffSize_Opposite <- NA - } else { - values$std_median <- NA - values$std_mad <- NA - } - - return(values) -} - - - - -#' @keywords internal -.process_effect <- function(varname, - posteriors, - posteriors_std, - info_priors, - predictors, - CI = 90, - effsize = FALSE, - effsize_rules = FALSE, - fit, - index = "overlap", - ROPE_bounds = NULL) { - values <- .get_info_priors(varname, info_priors, predictors) - posterior <- posteriors[, varname] - - - # Find basic posterior indices - values$posterior <- posterior - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- mpe(posterior)$MPE - values$MPE_values <- mpe(posterior)$values - - # Index - values$overlap <- 100 * overlap( - posterior, - rnorm_perfect( - length(posterior), - 0, - sd(posterior) - ) - ) - - if (!is.null(ROPE_bounds)) { - rope <- rope(posterior, bounds = ROPE_bounds) - values$ROPE_decision <- rope$rope_decision - values$ROPE <- rope$rope_probability - } else { - values$ROPE <- NA - values$ROPE_decision <- NA - } - - if (index == "overlap") { - index <- paste0( - "Overlap = ", - format_digit(values$overlap, null_treshold = 0.01), - "%)." - ) - } else if (index == "ROPE") { - if (!is.null(ROPE_bounds)) { - index <- paste0( - "ROPE = ", - format_digit(values$ROPE, null_treshold = 0.001), - ")." - ) - } else { - if (effsize == TRUE) { - rope <- rope(posteriors_std[, varname], bounds = c(-0.1, 0.1)) - values$ROPE_decision <- rope$rope_decision - values$ROPE <- rope$rope_probability - index <- paste0( - "ROPE = ", - format_digit(values$ROPE, null_treshold = 0.001), - ")." - ) - } else { - warning("you need to specify ROPE_bounds (e.g. 'c(-0.1, 0.1)'). Computing overlap instead.") - index <- paste0( - "Overlap = ", - format_digit(values$overlap, null_treshold = 0.01), - "%)." - ) - } - } - } else { - warning("Parameter 'index' should be 'overlap' or 'ROPE'. Computing overlap.") - index <- paste0( - "Overlap = ", - format_digit(values$overlap, null_treshold = 0.01), - "%)." - ) - } - - - - - - # Text - if (grepl(":", varname)) { - splitted <- strsplit(varname, ":")[[1]] - if (length(splitted) == 2) { - name <- paste0( - "interaction between ", - splitted[1], " and ", splitted[2] - ) - } else { - name <- varname - } - } else { - name <- paste0("effect of ", varname) - } - - direction <- ifelse(values$median > 0, "positive", "negative") - - values$text <- paste0( - " - The ", - name, - " has a probability of ", - format_digit(values$MPE), - "% of being ", - direction, - " (Median = ", - format_digit(values$median, null_treshold = 0.0001), - ", MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1], null_treshold = 0.0001), ", ", - format_digit(values$CI_values[2], null_treshold = 0.0001), "], ", - index - ) - - - - # Effize - if (effsize == TRUE) { - posterior_std <- posteriors_std[, varname] - values$std_posterior <- posterior_std - values$std_median <- median(posterior_std) - values$std_mad <- mad(posterior_std) - values$std_mean <- mean(posterior_std) - values$std_sd <- sd(posterior_std) - values$std_CI_values <- HDI(posterior_std, prob = CI / 100) - values$std_CI_values <- c(values$std_CI_values$values$HDImin, values$std_CI_values$values$HDImax) - - if (fit$family$family == "binomial" & fit$family$link == "logit") { - EffSize <- interpret_odds_posterior(posterior_std, log = TRUE, rules = effsize_rules) - } else { - EffSize <- interpret_d_posterior(posterior_std, rules = effsize_rules) - } - - values$EffSize <- EffSize$summary - values$EffSize$Variable <- varname - values$EffSize_text <- EffSize$text - } else { - values$std_median <- NA - values$std_mad <- NA - } - - return(values) -} diff --git a/R/as.data.frame.density.R b/R/as.data.frame.density.R deleted file mode 100644 index d950efd..0000000 --- a/R/as.data.frame.density.R +++ /dev/null @@ -1,16 +0,0 @@ -#' Coerce to a Data Frame. -#' -#' Functions to check if an object is a data frame, or coerce it if possible. -#' -#' @param x any R object. -#' @param ... additional arguments to be passed to or from methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @method as.data.frame density -#' @export -as.data.frame.density <- function(x, ...) { - df <- data.frame(x = x$x, y = x$y) - - return(df) -} diff --git a/R/assess.R b/R/assess.R deleted file mode 100644 index ce1ad76..0000000 --- a/R/assess.R +++ /dev/null @@ -1,106 +0,0 @@ -#' Compare a patient's score to a control group -#' -#' Compare a patient's score to a control group. -#' -#' @param patient Single value (patient's score). -#' @param controls Vector of values (control's scores). -#' @param mean Mean of the control sample. -#' @param sd SD of the control sample. -#' @param n Size of the control sample. -#' @param CI Credible interval bounds. -#' @param treshold Significance treshold. -#' @param iter Number of iterations. -#' @param color_controls Color of the controls distribution. -#' @param color_CI Color of CI distribution. -#' @param color_score Color of the line representing the patient's score. -#' @param color_size Size of the line representing the patient's score. -#' @param alpha_controls Alpha of the CI distribution. -#' @param alpha_CI lpha of the controls distribution. -#' @param verbose Print possible warnings. -#' -#' @return output -#' -#' @examples -#' result <- assess(patient = 124, mean = 100, sd = 15, n = 100) -#' print(result) -#' plot(result) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @details Until relatively recently the standard way of testing for a difference between a case and controls was to convert the case’s score to a z score using the control sample mean and standard deviation (SD). If z was less than -1.645 (i.e., below 95% of the controls) then it was concluded that the case was significantly lower than controls. However, this method has serious disadvantages (Crawford and Garthwaite, 2012). -#' -#' @importFrom stats ecdf -#' @import ggplot2 -#' @import dplyr -#' @export -assess <- function(patient, - mean = 0, - sd = 1, - n = NULL, - controls = NULL, - CI = 95, - treshold = 0.05, - iter = 10000, - color_controls = "#2196F3", - color_CI = "#E91E63", - color_score = "black", - color_size = 2, - alpha_controls = 1, - alpha_CI = 0.8, - verbose = TRUE) { - if (is.null(controls)) { - if (is.null(n)) { - if (verbose == TRUE) { - warning("Sample size (n) not provided, thus set to 1000.") - } - n <- 1000 - } - } - - - - - # If score is list - if (length(patient) > 1) { - if (verbose == TRUE) { - warning("Multiple scores were provided. Returning a list of results.") - } - results <- list() - for (i in seq_len(length(patient))) { - results[[i]] <- crawford.test( - patient[i], - controls, - mean, - sd, - n, - CI, - treshold, - iter, - color_controls, - color_CI, - color_score, - color_size, - alpha_controls, - alpha_CI - ) - return(results) - } - } else { - result <- crawford.test( - patient, - controls, - mean, - sd, - n, - CI, - treshold, - iter, - color_controls, - color_CI, - color_score, - color_size, - alpha_controls, - alpha_CI - ) - return(result) - } -} diff --git a/R/bayes_cor.R b/R/bayes_cor.R deleted file mode 100644 index f3de50e..0000000 --- a/R/bayes_cor.R +++ /dev/null @@ -1,337 +0,0 @@ -#' Performs a Bayesian correlation. -#' -#' Performs a Bayesian correlation. -#' -#' @param x First continuous variable. -#' @param y Second continuous variable. -#' @param CI Credible interval bounds. -#' @param iterations The number of iterations to sample. -#' @param effsize_rules_r Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}. -#' @param effsize_rules_bf Grid for effect size interpretation. See \link[=interpret_bf]{interpret_bf}. -#' -#' @return A psychobject. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' x <- psycho::affective$Concealing -#' y <- psycho::affective$Tolerating -#' -#' bayes_cor.test(x, y) -#' summary(bayes_cor.test(x, y)) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom BayesFactor correlationBF posterior -#' @importFrom stats complete.cases cor.test -#' @import dplyr -#' @export -bayes_cor.test <- function(x, y, CI = 90, iterations = 10000, effsize_rules_r = "cohen1988", effsize_rules_bf = "jeffreys1961") { - - - # Varnames ---------------------------------------------------------------- - - - if (is.null(names(x))) { - var1 <- deparse(substitute(x)) - } else { - var1 <- names(x) - x <- pull(x) - } - - if (is.null(names(y))) { - var2 <- deparse(substitute(y)) - } else { - var2 <- names(y) - y <- pull(y) - } - - # Remove missing - var_x <- x[complete.cases(x, y)] - var_y <- y[complete.cases(x, y)] - - # Correlation ------------------------------------------------------------- - - # Stop if same variable - if (cor.test(var_x, var_y)$estimate > 0.999) { - return(1) - } - - - cor <- BayesFactor::correlationBF(var_x, var_y) - posterior <- as.vector(suppressMessages(BayesFactor::posterior(cor, iterations = iterations, progress = FALSE))) - - values <- list() - values$posterior <- posterior - values$bf <- as.vector(cor)[1] - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI <- HDI(posterior, prob = CI / 100)$text - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- mpe(posterior)$MPE - values$MPE_values <- mpe(posterior)$values - - norm <- rnorm_perfect(length(posterior), 0, sd(posterior)) - values$overlap <- overlap(posterior, norm) * 100 - - rope_indices <- rope(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = TRUE) - values$rope_decision <- rope_indices$rope_decision - values$rope_probability <- rope_indices$rope_probability - values$rope_overlap <- rope_indices$rope_overlap - - - summary <- data.frame( - Median = values$median, - MAD = values$mad, - CI_lower = values$CI_values[1], - CI_higher = values$CI_values[2], - MPE = values$MPE, - BF = values$bf, - Overlap = values$overlap, - Rope = values$rope_decision - ) - rownames(summary) <- paste0(var1, " / ", var2) - - values$effect_size <- interpret_r_posterior(posterior, rules = effsize_rules_r) - interpretation_r <- interpret_r(values$median, strength = FALSE, rules = effsize_rules_r) - interpretation_bf <- interpret_bf(values$bf, direction = FALSE, rules = effsize_rules_bf) - if (values$bf < 1) { - interpretation_bf <- paste(interpretation_bf, "in favour of an absence of a ") - } else { - interpretation_bf <- paste(interpretation_bf, "in favour of the existence of a ") - } - - text <- paste0( - "Results of the Bayesian correlation indicate ", - interpretation_bf, - interpretation_r, - " association between ", - var1, - " and ", - var2, - " (r = ", - format_digit(values$median), - ", MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1], null_treshold = 0.0001), - ", ", - format_digit(values$CI_values[2], null_treshold = 0.0001), - "]). ", - values$effect_size$text - ) - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - -#' Bayesian Correlation Matrix. -#' -#' Bayesian Correlation Matrix. -#' -#' @param df The dataframe. -#' @param df2 Optional dataframe to correlate with the first one. -#' @param reorder Reorder matrix by correlation strength. Only for square matrices. -#' -#' @return A list of dataframes -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' df <- psycho::affective -#' cor <- bayes_cor(df) -#' summary(cor) -#' print(cor) -#' plot(cor) -#' -#' df <- select(psycho::affective, Adjusting, Tolerating) -#' df2 <- select(psycho::affective, -Adjusting, -Tolerating) -#' cor <- bayes_cor(df, df2) -#' summary(cor) -#' print(cor) -#' plot(cor) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -bayes_cor <- function(df, df2 = NULL, reorder = TRUE) { - df <- purrr::keep(df, is.numeric) - - if (!is.null(df2)) { - df2 <- purrr::keep(df2, is.numeric) - combinations <- expand.grid(names(df), names(df2)) - df <- cbind(df, df2) - } else { - combinations <- expand.grid(names(df), names(df)) - } - - size_row <- length(unique(combinations$Var1)) - size_col <- length(unique(combinations$Var2)) - dimnames <- list( - unique(combinations$Var1), - unique(combinations$Var2) - ) - - r <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - mpe <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - bf <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - ci <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - text <- matrix("", nrow = size_row, ncol = size_col, dimnames = dimnames) - - counter <- 0 - for (j in seq_len(size_col)) { - for (i in seq_len(size_row)) { - counter <- counter + 1 - - x <- df[[as.character(combinations$Var1[counter])]] - y <- df[[as.character(combinations$Var2[counter])]] - result <- bayes_cor.test(x, y) - - if (!is.psychobject(result)) { - text[i, j] <- "" - r[i, j] <- 1 - mpe[i, j] <- 100 - bf[i, j] <- Inf - ci[i, j] <- "100% CI [1, 1]" - } else { - text[i, j] <- paste0( - " - ", - names(df)[j], - " / ", - names(df)[i], - ": ", - result$text - ) - text[i, j] <- stringr::str_remove(text[i, j], "between x and y ") - r[i, j] <- result$values$median - mpe[i, j] <- result$values$MPE - bf[i, j] <- result$values$bf - ci[i, j] <- result$values$CI - } - } - } - - - # Reorder - if (is.null(df2) & reorder == TRUE) { - r <- reorder_matrix(r, r) - mpe <- reorder_matrix(mpe, r) - bf <- reorder_matrix(bf, r) - ci <- reorder_matrix(ci, r) - text <- reorder_matrix(text, r) - } - - - stars <- ifelse(bf > 30, "***", - ifelse(bf > 10, "**", - ifelse(bf > 3, "*", "") - ) - ) - - - - summary <- round(r, 2) - summary <- matrix(paste(summary, stars, sep = ""), ncol = ncol(r), dimnames = dimnames(r)) - - if (is.null(df2)) { - summary[upper.tri(summary, diag = TRUE)] <- "" # remove upper triangle - summary <- summary[-1, -ncol(summary)] # Remove first row and last column - - text[upper.tri(text, diag = TRUE)] <- "" # remove upper triangle - text <- text[-1, -ncol(text)] # Remove first row and last column - } - - summary <- as.data.frame(summary) - text <- as.vector(text) - text <- text[!text == ""] - - - # Values - values <- list( - r = r, - mpe = mpe, - bf = bf, - ci = ci, - stars = stars - ) - - # Plot - plot <- round(r, 2) %>% - as.data.frame() %>% - tibble::rownames_to_column("Var1") %>% - gather_("Var2", "Correlation", as.character(unique(combinations$Var2))) %>% - ggplot(aes_string(x = "Var2", y = "Var1", fill = "Correlation", label = "Correlation")) + - geom_tile(color = "white") + - scale_fill_gradient2( - low = "#2196F3", high = "#E91E63", mid = "white", - midpoint = 0, limit = c(-1, 1) - ) + - theme_minimal() + - theme( - axis.title = element_blank(), - axis.text.x = element_text( - angle = 45, - vjust = 1, - hjust = 1 - ), - legend.position = "none" - ) + - coord_fixed() + - geom_text(color = "black") - - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - -#' Reorder square matrix. -#' -#' Reorder square matrix. -#' -#' @param mat A square matrix. -#' @param dmat A square matrix with values to use as distance. -#' -#' @examples -#' library(psycho) -#' -#' r <- correlation(iris) -#' r <- r$values$r -#' r <- reorder_matrix(r) -#' @importFrom stats as.dist hclust -#' @export -reorder_matrix <- function(mat, dmat = NULL) { - if (is.null(dmat)) { - dmat <- mat - } - - if (ncol(mat) != nrow(mat) | ncol(dmat) != nrow(dmat)) { - warning("Matrix must be squared.") - return(mat) - } - - dmat <- as.dist((1 - dmat) / 2, diag = TRUE, upper = TRUE) - hc <- hclust(dmat) - mat <- mat[hc$order, hc$order] - return(mat) -} diff --git a/R/cite_packages.R b/R/cite_packages.R deleted file mode 100644 index 85fc05d..0000000 --- a/R/cite_packages.R +++ /dev/null @@ -1,42 +0,0 @@ -#' Citations of loaded packages. -#' -#' Get the citations of loaded packages. -#' -#' @param session A `devtools::sessionInfo()` object. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' cite_packages(sessionInfo()) -#' } -#' -#' @author \href{https://github.com/DominiqueMakowski}{Dominique Makowski} -#' -#' @export -cite_packages <- function(session) { - pkgs <- session$otherPkgs - citations <- c() - for (pkg_name in names(pkgs)) { - pkg <- pkgs[[pkg_name]] - - citation <- format(citation(pkg_name))[[2]] %>% - stringr::str_split("\n") %>% - flatten() %>% - paste(collapse = "SPLIT") %>% - stringr::str_split("SPLITSPLIT") - - i <- 1 - while (stringr::str_detect(citation[[1]][i], "To cite ")) { - i <- i + 1 - } - - - citation <- citation[[1]][i] %>% - stringr::str_remove_all("SPLIT") %>% - stringr::str_trim() %>% - stringr::str_squish() - - citations <- c(citations, citation) - } - return(data.frame("Packages" = citations)) -} diff --git a/R/correlation.R b/R/correlation.R deleted file mode 100644 index 1846f85..0000000 --- a/R/correlation.R +++ /dev/null @@ -1,330 +0,0 @@ -#' Multiple Correlations. -#' -#' Compute different kinds of correlation matrices. -#' -#' @param df The dataframe. -#' @param df2 Optional dataframe to correlate with the first one. -#' @param type A character string indicating which correlation type is to be -#' computed. One of "full" (default), "partial" (partial correlations), -#' "semi" (semi-partial correlations), "glasso" -#' (Graphical lasso- estimation of Gaussian graphical models) or "cor_auto" -#' (will use the qgraph::cor_auto function to return pychoric or polyserial -#' correlations if needed). -#' @param method A character string indicating which correlation coefficient is -#' to be computed. One of "pearson" (default), "kendall", or "spearman" can be -#' abbreviated. -#' @param adjust What adjustment for multiple tests should be used? ("holm", -#' "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"). See -#' \link[stats]{p.adjust} for details about why to use "holm" rather than -#' "bonferroni"). -#' @param i_am_cheating Set to TRUE to run many uncorrected correlations. -#' -#' @return output -#' -#' @examples -#' df <- attitude -#' -#' # Normal correlations -#' results <- psycho::correlation(df) -#' print(results) -#' plot(results) -#' -#' # Partial correlations with correction -#' results <- psycho::correlation(df, -#' type = "partial", -#' method = "spearman", -#' adjust = "holm" -#' ) -#' print(results) -#' plot(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats na.omit p.adjust cor runif -#' @importFrom psych corr.test -#' @importFrom ggplot2 theme element_text -#' @importFrom stringr str_to_title -#' @import ggcorrplot -#' @import ppcor -#' @import dplyr -#' @export -correlation <- function(df, - df2 = NULL, - type = "full", - method = "pearson", - adjust = "holm", - i_am_cheating = FALSE) { - - # Processing - # ------------------- - if (method == "bayes" | method == "bayesian") { - return(bayes_cor(df, df2, reorder = TRUE)) - } - - - # N samples - n <- nrow(df) - - # Remove non numeric - df <- purrr::keep(df, is.numeric) - if (is.null(df2) == FALSE) { - df2 <- purrr::keep(df2, is.numeric) - } - - # P-fishing prevention - if (ncol(df) > 10 && adjust == "none" && i_am_cheating == FALSE) { - warning("We've detected that you are running a lot (> 10) of correlation tests without adjusting the p values. To help you in your p-fishing, we've added some interesting variables: You never know, you might find something significant!\nTo deactivate this, change the 'i_am_cheating' argument to TRUE.") - df_complete <- dplyr::mutate_all(df, dplyr::funs_("replace(., is.na(.), 0)")) - df$Local_Air_Density <- svd(df_complete)$u[, 1] - df$Reincarnation_Cycle <- runif(nrow(df), max = 100) - df$Communism_Level <- -1 * svd(df_complete)$u[, 2] - df$Alien_Mothership_Distance <- rnorm(nrow(df), mean = 50000, sd = 5000) - df$Schopenhauers_Optimism <- svd(df_complete)$u[, 3] - df$Hulks_Power <- runif(nrow(df), max = 10) - } - - - - # Compute r coefficients - if (type == "full") { - corr <- psych::corr.test(df, y = df2, use = "pairwise", method = method, adjust = "none") - r <- corr$r - p <- corr$p - t <- corr$t - ci <- corr$ci - ci.adj <- corr$ci.adj - } else { - if (is.null(df2) == FALSE) { - df <- cbind(df, df2) - } - - df <- stats::na.omit(df) # enable imputation - if (type == "semi") { - corr <- ppcor::spcor(df, method = method) - r <- corr$estimate - p <- corr$p.value - t <- corr$statistic - ci <- "Not available for partial and semipartial correlations." - ci.adj <- "Not available for partial and semipartial correlations." - } - else if (type == "partial") { - corr <- ppcor::pcor(df, method = method) - r <- corr$estimate - p <- corr$p.value - t <- corr$statistic - ci <- "Not available for partial and semipartial correlations." - ci.adj <- "Not available for partial and semipartial correlations." - } - else if (type == "glasso") { - corr <- qgraph::EBICglasso(cor(df), n, gamma = 0.5) - r <- corr - p <- NULL - t <- NULL - ci <- "Not available for glasso estimation." - ci.adj <- "Not available for glasso estimation." - } - else if (type == "cor_auto") { - corr <- qgraph::cor_auto(df, forcePD = FALSE) - r <- corr - p <- NULL - t <- NULL - ci <- "Not available for cor_auto estimation." - ci.adj <- "Not available for cor_auto estimation." - } - else { - warning("type parameter must be 'full', 'semi', 'partial', 'glasso' or 'cor_auto'") - return() - } - } - - - - # Adjust P values - if (is.null(p) == FALSE) { - if (adjust != "none") { - if ((type == "full" & is.null(df2) == FALSE) | (type == "semi")) { - p[, ] <- p.adjust(p, method = adjust) - } else { - p[lower.tri(p)] <- p.adjust(p[lower.tri(p)], method = adjust, n = choose(nrow(p), 2)) - p[upper.tri(p)] <- p.adjust(p[upper.tri(p)], method = adjust, n = choose(nrow(p), 2)) - } - } - } - - - - - # Values - # ------------- - values <- list(r = r, p = p, t = t, ci = ci, ci.adj = ci.adj, n = n) - - - - - - # Summary - # ------------- - - # Define notions for significance levels; spacing is important. - if (is.null(p) == FALSE) { - stars <- ifelse(p < .001, "***", - ifelse(p < .01, "** ", - ifelse(p < .05, "* ", " ") - ) - ) - } else { - stars <- "" - } - - - # build a new correlation matrix with significance stars - table <- matrix(paste0(round(r, 2), stars), ncol = ncol(r)) - - - # Format - rownames(table) <- colnames(df) - if (isSymmetric(r)) { - diag(table) <- paste0(diag(round(r, 2)), " ") - colnames(table) <- colnames(df) - table[upper.tri(table, diag = TRUE)] <- "" # remove upper triangle - table <- as.data.frame(table) - # remove last column and return the matrix (which is now a data frame) - summary <- cbind(table[seq_len(length(table) - 1)]) - } else { - if (is.null(df2)) { - colnames(table) <- colnames(df) - } else { - if (type == "semi") { - colnames(table) <- colnames(df) - } else { - colnames(table) <- colnames(df2) - } - } - table <- as.data.frame(table) - summary <- table - } - - - - - # Text - # ------------- - sentences <- c() - for (row in seq_len(nrow(r))) { - for (col in seq_len(ncol(r))) { - if (as.matrix(table)[row, col] == "") next # skip iteration and go to next iteration - - val_r <- as.matrix(r)[row, col] - val_t <- tryCatch({ - as.matrix(t)[row, col] - }, error = function(e) { - "NA" - }) - val_p <- tryCatch({ - as.matrix(p)[row, col] - }, error = function(e) { - "NA" - }) - var1 <- colnames(r)[col] - var2 <- row.names(r)[row] - - if (is.numeric(val_p) & val_p <= .05) { - significance <- "significant " - } else if (is.numeric(val_p) & val_p > .05) { - significance <- "non significant " - } else { - significance <- "" - } - - - sentence <- paste0( - " - ", - var1, - " / ", - var2, - ": ", - "Results of the ", - stringr::str_to_title(method), - " correlation showed a ", - significance, - interpret_r(val_r), - " association between ", - var1, - " and ", - var2, - " (r(", - n - 2, - ") = ", - psycho::format_digit(val_r), - ", p ", - psycho::format_p(val_p), - ")." - ) - - sentences <- c(sentences, sentence) - } - } - - sentences <- c(paste0( - stringr::str_to_title(method), - " ", - stringr::str_to_title(type), - " correlation (p value correction: ", - adjust, - "):\n" - ), sentences) - - text <- sentences - - - - - # Plot - # ------------- - if (is.null(df2) == FALSE & type == "full") { - corr <- psych::corr.test(cbind(df, df2), use = "pairwise", method = method, adjust = "none") - r <- corr$r - p <- corr$p - p[lower.tri(p)] <- p.adjust(p[lower.tri(p)], method = adjust, n = choose(nrow(p), 2)) - p[upper.tri(p)] <- p.adjust(p[upper.tri(p)], method = adjust, n = choose(nrow(p), 2)) - # warning("Due to the presence of two dataframes, the plot might be incorrect. Consider with caution.") - } - - if (type == "semi") { - plot <- ggcorrplot::ggcorrplot( - r, - title = paste("A ", type, "'s correlation matrix (correction: ", adjust, ")\n", sep = ""), - method = "circle", - type = "full", - colors = c("#E91E63", "white", "#03A9F4"), - hc.order = TRUE, - p.mat = p, - insig = "pch", - legend.title = "", - lab = FALSE - ) + - ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.7)) - } else { - plot <- ggcorrplot::ggcorrplot( - r, - title = paste("A ", type, "'s correlation matrix (correction: ", adjust, ")\n", sep = ""), - method = "circle", - type = "lower", - colors = c("#E91E63", "white", "#03A9F4"), - hc.order = TRUE, - p.mat = p, - insig = "pch", - legend.title = "", - lab = FALSE - ) + - ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.7)) - } - - - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "psychobject_correlation", "list") - return(output) -} diff --git a/R/crawford.test.R b/R/crawford.test.R deleted file mode 100644 index f7f6d16..0000000 --- a/R/crawford.test.R +++ /dev/null @@ -1,292 +0,0 @@ -#' Crawford-Garthwaite (2007) Bayesian test for single-case analysis. -#' -#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2007) demonstrate that the Bayesian test is a better approach than other commonly-used alternatives. -#' . -#' -#' @param patient Single value (patient's score). -#' @param controls Vector of values (control's scores). -#' @param mean Mean of the control sample. -#' @param sd SD of the control sample. -#' @param n Size of the control sample. -#' @param CI Credible interval bounds. -#' @param treshold Significance treshold. -#' @param iter Number of iterations. -#' @param color_controls Color of the controls distribution. -#' @param color_CI Color of CI distribution. -#' @param color_score Color of the line representing the patient's score. -#' @param color_size Size of the line representing the patient's score. -#' @param alpha_controls Alpha of the CI distribution. -#' @param alpha_CI lpha of the controls distribution. -#' -#' -#' @details The p value obtained when this test is used to test significance also simultaneously provides a point estimate of the abnormality of the patient’s score; for example if the one-tailed probability is .013 then we know that the patient’s score is significantly (p < .05) below the control mean and that it is estimated that 1.3% of the control population would obtain a score lower than the patient’s. As for the credible interval interpretation, we could say that there is a 95% probability that the true level of abnormality of the patient’s score lies within the stated limits, or that There is 95% confidence that the percentage of people who have a score lower than the patient’s is between 0.01% and 6.66%. -#' -#' @examples -#' library(psycho) -#' -#' crawford.test(patient = 125, mean = 100, sd = 15, n = 100) -#' plot(crawford.test(patient = 80, mean = 100, sd = 15, n = 100)) -#' -#' crawford.test(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' test <- crawford.test(patient = 7, controls = c(0, -2, 5, -6, 0, 3, -4, -2)) -#' plot(test) -#' @author Dominique Makowski -#' -#' @importFrom stats pnorm var approx rchisq -#' @importFrom scales rescale -#' @import ggplot2 -#' @export -crawford.test <- function(patient, - controls = NULL, - mean = NULL, - sd = NULL, - n = NULL, - CI = 95, - treshold = 0.1, - iter = 10000, - color_controls = "#2196F3", - color_CI = "#E91E63", - color_score = "black", - color_size = 2, - alpha_controls = 1, - alpha_CI = 0.8) { - if (is.null(controls)) { - # Check if a parameter is null - if (length(c(mean, sd, n)) != 3) { - stop("Please provide either controls or mean, sd and n.") - } - sample_mean <- mean - sample_sd <- sd - sample_var <- sd^2 - } else { - sample_mean <- mean(controls) - sample_var <- var(controls) - sample_sd <- sd(controls) - n <- length(controls) - } - degfree <- n - 1 - - - # Computation ------------------------------------------------------------- - - - pvalues <- c() - for (i in 1:iter) { - # step 1 - psi <- rchisq(1, df = degfree, ncp = 0) - o <- (n - 1) * sample_var / psi - - # step 2 - z <- rnorm(1, 0, 1) - u <- sample_mean + z * sqrt((o / n)) - - # step 3 - z_patient <- (patient - u) / sqrt(o) - p <- 2 * (1 - pnorm(abs(z_patient), lower.tail = TRUE)) # One-tailed p-value - pvalues <- c(pvalues, p) - } - - - # Point estimates --------------------------------------------------------- - - z_score <- (patient - sample_mean) / sample_sd - perc <- percentile(z_score) - - pvalues <- pvalues / 2 - p <- mean(pvalues) - CI <- HDI(pvalues, prob = CI / 100) - # CI_1 <- sort(pvalues)[iter * (100 - CI) / 100] - - - # Text -------------------------------------------------------------------- - - p_interpretation <- ifelse(p < treshold, " significantly ", " not significantly ") - direction <- ifelse(patient - sample_mean < 0, " lower than ", " higher than ") - - - text <- paste0( - "The Bayesian test for single case assessment (Crawford, Garthwaite, 2007) suggests that the patient's score (Raw = ", - format_digit(patient), - ", Z = ", - format_digit(z_score), - ", percentile = ", - format_digit(perc), - ") is", - p_interpretation, - "different from the controls (M = ", - format_digit(sample_mean), - ", SD = ", - format_digit(sample_sd), - ", p ", - format_p(p), - ").", - " The patient's score is", - direction, - format_digit((1 - p) * 100), - "% (95% CI [", - paste(format_digit(sort(c((1 - CI$values$HDImin) * 100, (1 - CI$values$HDImax) * 100))), collapse = ", "), - "]) of the control population." - ) - - - - # Store values ------------------------------------------------------------ - - values <- list( - patient_raw = patient, - patient_z = z_score, - patient_percentile = perc, - controls_mean = sample_mean, - controls_sd = sample_sd, - controls_var = sample_var, - controls_sd = sample_sd, - controls_n = n, - text = text, - p = p, - CI_lower = CI$values$HDImin, - CI_higher = CI$values$HDImax - ) - - summary <- data.frame( - controls_mean = sample_mean, - controls_sd = sample_sd, - controls_n = n, - p = p, - CI_lower = CI$values$HDImin, - CI_higher = CI$values$HDImax - ) - - if (is.null(controls)) { - controls <- rnorm_perfect(n, sample_mean, sample_sd) - } - - - # Plot -------------------------------------------------------------------- - if (patient - sample_mean < 0) { - uncertainty <- percentile_to_z(pvalues * 100) - } else { - uncertainty <- percentile_to_z((1 - pvalues) * 100) - } - - - - - plot <- rnorm_perfect(length(uncertainty), 0, 1) %>% - density() %>% - as.data.frame() %>% - mutate_(y = "y/max(y)") %>% - mutate(distribution = "Control") %>% - rbind(uncertainty %>% - density() %>% - as.data.frame() %>% - mutate_(y = "y/max(y)") %>% - mutate(distribution = "Uncertainty")) %>% - mutate_(x = "scales::rescale(x, from=c(0, 1), to = c(sample_mean, sample_mean+sample_sd))") %>% - ggplot(aes_string(x = "x", ymin = 0, ymax = "y")) + - geom_ribbon(aes_string(fill = "distribution", alpha = "distribution")) + - geom_vline(xintercept = patient, colour = color_score, size = color_size) + - scale_fill_manual(values = c(color_controls, color_CI)) + - scale_alpha_manual(values = c(alpha_controls, alpha_CI)) + - xlab("\nScore") + - ylab("") + - theme_minimal() + - theme( - legend.position = "none", - axis.ticks.y = element_blank(), - axis.text.y = element_blank() - ) - - - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - -#' Crawford-Howell (1998) frequentist t-test for single-case analysis. -#' -#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. -#' . -#' -#' @param patient Single value (patient's score). -#' @param controls Vector of values (control's scores). -#' -#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the patient is different from the control group. -#' -#' @examples -#' library(psycho) -#' -#' crawford.test.freq(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' crawford.test.freq(patient = 7, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' @author Dan Mirman, Dominique Makowski -#' -#' @importFrom stats pt sd -#' @export -crawford.test.freq <- function(patient, controls) { - tval <- (patient - mean(controls)) / (sd(controls) * sqrt((length(controls) + 1) / length(controls))) - - degfree <- length(controls) - 1 - - pval <- 2 * (1 - pt(abs(tval), df = degfree)) # One-tailed p-value - - # One-tailed p value - if (pval > .05 & pval / 2 < .05) { - one_tailed <- paste0( - " However, the null hypothesis of no difference can be rejected at a one-tailed 5% significance level (one-tailed p ", - format_p(pval / 2), - ")." - ) - } else { - one_tailed <- "" - } - - - p_interpretation <- ifelse(pval < 0.05, " significantly ", " not significantly ") - t_interpretation <- ifelse(tval < 0, " lower than ", " higher than ") - - text <- paste0( - "The Crawford-Howell (1998) t-test suggests that the patient's score (", - format_digit(patient), - ") is", - p_interpretation, - "different from the controls (M = ", - format_digit(mean(controls)), - ", SD = ", - format_digit(sd(controls)), - ", t(", - degfree, - ") = ", - format_digit(tval), - ", p ", - format_p(pval), - ").", - one_tailed, - " The patient's score is", - t_interpretation, - format_digit((1 - pval) * 100), - "% of the control population." - ) - - values <- list( - text = text, - p = pval, - df = degfree, - t = tval - ) - summary <- data.frame(t = tval, df = degfree, p = pval) - plot <- "Not available yet" - - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/crawford_dissociation.test.R b/R/crawford_dissociation.test.R deleted file mode 100644 index 715a7d1..0000000 --- a/R/crawford_dissociation.test.R +++ /dev/null @@ -1,86 +0,0 @@ -#' Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks. -#' -#' Assessing dissociation between processes is a fundamental part of clinical neuropsychology. However, while the detection of suspected impairments is a fundamental feature of single-case studies, evidence of an impairment on a given task usually becomes of theoretical interest only if it is observed in the context of less impaired or normal performance on other tasks. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test for dissociation is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. -#' . -#' -#' @param case_X Single value (patient's score on test X). -#' @param case_Y Single value (patient's score on test Y). -#' @param controls_X Vector of values (control's scores of X). -#' @param controls_Y Vector of values (control's scores of Y). -#' @param verbose True or False. Prints the interpretation text. -#' -#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the dissociation between test X and test Y is significant. -#' -#' @examples -#' library(psycho) -#' -#' case_X <- 142 -#' case_Y <- 7 -#' controls_X <- c(100, 125, 89, 105, 109, 99) -#' controls_Y <- c(7, 8, 9, 6, 7, 10) -#' -#' crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y) -#' @author Dominique Makowski -#' -#' @importFrom stats sd pt -#' @export -crawford_dissociation.test <- function(case_X, case_Y, controls_X, controls_Y, verbose = TRUE) { - X_mean <- mean(controls_X) - X_sd <- sd(controls_X) - Y_mean <- mean(controls_Y) - Y_sd <- sd(controls_Y) - r <- cor(controls_X, controls_Y) - n <- length(controls_X) - degfree <- n - 1 - - case_X_Z <- (case_X - X_mean) / X_sd - case_Y_Z <- (case_Y - Y_mean) / Y_sd - - tval <- (case_X_Z - case_Y_Z) / sqrt((2 - 2 * r) * ((n + 1) / n)) - - pval <- 2 * (1 - pt(abs(tval), df = degfree)) # two-tailed p-value - - - - - - p_interpretation <- ifelse(pval < 0.05, " a significant ", " no ") - p_interpretation2 <- ifelse(pval < 0.05, " ", " not ") - z_interpretation <- ifelse(tval < 0, " below ", " above ") - pop_interpretation <- ifelse(tval < 0, " above ", " below ") - - if (abs(case_X_Z) > abs(case_Y_Z)) { - var_interpretation1 <- "test X" - var_interpretation2 <- "test Y" - } else { - var_interpretation1 <- "test Y" - var_interpretation2 <- "test X" - } - - text <- paste0( - "The Crawford-Howell (1998) t-test suggests", - p_interpretation, - "dissociation between test X and test Y (t(", - degfree, - ") = ", - format_digit(tval), - ", p ", - format_p(pval), - "). The patient's score on ", - var_interpretation1, - " is", - p_interpretation2, - "significantly altered compared to its score on ", - var_interpretation2, - "." - ) - - - result <- data.frame(t = tval, df = degfree, p = pval) - - if (verbose == TRUE) { - cat(paste0(text, "\n\n")) - } - - return(result) -} diff --git a/R/create_intervals.R b/R/create_intervals.R deleted file mode 100644 index 0e15e30..0000000 --- a/R/create_intervals.R +++ /dev/null @@ -1,54 +0,0 @@ -#' Overlap of Two Empirical Distributions. -#' -#' A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). -#' -#' @param x A vector of numerics. -#' @param n Number of intervals to create, OR -#' @param length Length of each interval. -#' @param equal_range Makes n groups with with equal range (TRUE) or (approximately) equal numbers of observations (FALSE). -#' @param labels Can be a custom list, "NULL", "FALSE" or "median". -#' @param dig.lab Integer which is used when labels are not given. It determines the number of digits used in formatting the break numbers. -#' -#' @examples -#' library(psycho) -#' -#' x <- rnorm(100, 0, 1) -#' -#' create_intervals(x, n = 4) -#' create_intervals(x, n = 4, equal_range = FALSE) -#' create_intervals(x, length = 1) -#' -#' create_intervals(x, n = 4, labels = "median") -#' create_intervals(x, n = 4, labels = FALSE) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom ggplot2 cut_interval cut_number -#' @export -create_intervals <- function(x, n = NULL, length = NULL, equal_range = TRUE, labels = NULL, dig.lab = 3) { - if (equal_range) { - if (is.character(labels) && labels == "median") { - cuts <- ggplot2::cut_interval(x, n = n, length = length, labels = FALSE) - } else { - cuts <- ggplot2::cut_interval(x, n = n, length = length, labels = labels, dig.lab = dig.lab) - } - } else { - if (is.character(labels) && labels == "median") { - cuts <- ggplot2::cut_number(x, n = n, labels = FALSE) - } else { - cuts <- ggplot2::cut_number(x, n = n, labels = labels, dig.lab = dig.lab) - } - } - - - if (is.character(labels) && labels == "median") { - cuts <- cuts %>% - data.frame(x) %>% - group_by_(".") %>% - mutate_("cuts" = "median(x)") %>% - ungroup() %>% - select_("cuts") %>% - pull() - } - - return(cuts) -} diff --git a/R/affective.R b/R/data_affective.R similarity index 100% rename from R/affective.R rename to R/data_affective.R diff --git a/R/emotion.R b/R/data_emotion.R similarity index 100% rename from R/emotion.R rename to R/data_emotion.R diff --git a/R/deprecated.R b/R/deprecated.R new file mode 100644 index 0000000..67ac5ec --- /dev/null +++ b/R/deprecated.R @@ -0,0 +1,10118 @@ + +#' Analyze aov and anova objects +#' +#' Analyze aov and anova objects. +#' +#' @param x aov object. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_omega_sq]{interpret_omega_sq}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' df <- psycho::affective +#' +#' x <- aov(df$Tolerating ~ df$Salary) +#' x <- aov(df$Tolerating ~ df$Salary * df$Sex) +#' +#' x <- anova(lm(df$Tolerating ~ df$Salary * df$Sex)) +#' +#' +#' summary(analyze(x)) +#' print(analyze(x)) +#' +#' df <- psycho::emotion %>% +#' mutate(Recall = ifelse(Recall == TRUE, 1, 0)) %>% +#' group_by(Participant_ID, Emotion_Condition) %>% +#' summarise(Recall = sum(Recall) / n()) +#' +#' x <- aov(Recall ~ Emotion_Condition + Error(Participant_ID), data = df) +#' x <- anova(lmerTest::lmer(Recall ~ Emotion_Condition + (1 | Participant_ID), data = df)) +#' analyze(x) +#' summary(x) +#' } +#' +#' @references +#' \itemize{ +#' \item{Levine, T. R., & Hullett, C. R. (2002). Eta squared, partial eta squared, and misreporting of effect size in communication research. Human Communication Research, 28(4), 612-625.} +#' \item{Pierce, C. A., Block, R. A., & Aguinis, H. (2004). Cautionary note on reporting eta-squared values from multifactor ANOVA designs. Educational and psychological measurement, 64(6), 916-924.} +#' } +#' +#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/os2 +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import broom +#' +#' @export +analyze.aov <- function(x, effsize_rules = "field2013", ...) { + if (!"aov" %in% class(x)) { + if (!"Residuals" %in% row.names(x)) { + if (!is.null(x$Within)) { + x <- x$Within + message("(Repeated measures ANOVAs are bad, you should use mixed-models...)") + } else { + return(.analyze.anova_lmer(x)) + } + } + } else { + if (!is.null(x$Within)) { + x <- x$Within + message("(Repeated measures ANOVAs are bad, you should use mixed-models...)") + } + } + + + + + # Processing + # ------------- + + + # Effect Size + omega <- tryCatch({ + omega_sq(x, partial = TRUE) + }, warning = function(w) { + stop("I believe there are within and between subjects variables that caused the error. You should REALLY use mixed-models.") + }) + + + + + all_values <- x %>% + broom::tidy() %>% + dplyr::full_join(data.frame("Omega" = omega) %>% + tibble::rownames_to_column("term"), by = "term") %>% + mutate_("Effect_Size" = "interpret_omega_sq(Omega, rules = 'field2013')") %>% + rename_( + "Effect" = "term", + "Sum_Squares" = "sumsq", + "Mean_Square" = "meansq", + "F" = "statistic", + "p" = "p.value" + ) + + varnames <- all_values$Effect + df_residuals <- all_values[all_values$Effect == "Residuals", ]$df + + values <- list() + for (var in varnames) { + values[[var]] <- list() + current_values <- dplyr::filter_(all_values, "Effect == var") + values[[var]]$df <- current_values$df + values[[var]]$Sum_Squares <- current_values$Sum_Squares + values[[var]]$Mean_Square <- current_values$Mean_Square + values[[var]]$F <- current_values$F + values[[var]]$p <- current_values$p + values[[var]]$Omega <- current_values$Omega + values[[var]]$Effect_Size <- current_values$Effect_Size + + if (var != "Residuals") { + if (current_values$p < .05) { + significance <- "significant" + } else { + significance <- "not significant" + } + + if (grepl(":", var)) { + effect <- "interaction between" + varname <- stringr::str_replace_all(var, ":", " and ") + } else { + varname <- var + effect <- "effect of" + } + + values[[var]]$text <- paste0( + "The ", + effect, + " ", + varname, + " is ", + significance, + " (F(", + current_values$df, + ", ", + df_residuals, + ") = ", + format_digit(current_values$F), + ", p ", + format_p(current_values$p, stars = FALSE), + ") and can be considered as ", + current_values$Effect_Size, + " (Partial Omega-squared = ", + format_digit(current_values$Omega), + ")." + ) + } + } + + # Summary + # ------------- + summary <- all_values + + # Text + # ------------- + text <- c() + for (var in varnames[varnames != "Residuals"]) { + text <- c(text, paste(" -", values[[var]]$text)) + } + + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + +#' @export +analyze.anova <- analyze.aov + +#' @export +analyze.aovlist <- analyze.aov + + + +#' @keywords internal +.analyze.anova_lmer <- function(x) { + if (!"NumDF" %in% colnames(x)) { + stop("Cannot analyze the anova from lme4. Please refit the model using lmerTest.") + } + + summary <- x %>% + as.data.frame() %>% + tibble::rownames_to_column("term") %>% + rename_( + "Effect" = "term", + "df" = "NumDF", + "df_Residuals" = "DenDF", + "Sum_Squares" = "`Sum Sq`", + "Mean_Square" = "`Mean Sq`", + "F" = "`F value`", + "p" = "`Pr(>F)`" + ) %>% + select_("Effect", "df", "df_Residuals", "Sum_Squares", "Mean_Square", "F", "p") + + varnames <- summary$Effect + + values <- list() + for (var in varnames) { + values[[var]] <- list() + current_values <- dplyr::filter_(summary, "Effect == var") + values[[var]]$df <- current_values$df + values[[var]]$df_Residuals <- current_values$df_Residuals + values[[var]]$Sum_Squares <- current_values$Sum_Squares + values[[var]]$Mean_Square <- current_values$Mean_Square + values[[var]]$F <- current_values$F + values[[var]]$p <- current_values$p + # values[[var]]$Omega <- current_values$Omega + # values[[var]]$Effect_Size <- current_values$Effect_Size + + if (current_values$p < .05) { + significance <- "significant" + } else { + significance <- "not significant" + } + + if (grepl(":", var)) { + effect <- "interaction between" + varname <- stringr::str_replace_all(var, ":", " and ") + } else { + varname <- var + effect <- "effect of" + } + + values[[var]]$text <- paste0( + "The ", + effect, + " ", + varname, + " is ", + significance, + " (F(", + current_values$df, + ", ", + format_digit(current_values$df_Residuals, 0), + ") = ", + format_digit(current_values$F), + ", p ", + format_p(current_values$p, stars = FALSE), + ")." + ) + } + + + # Text + # ------------- + text <- c() + for (var in varnames[varnames != "Residuals"]) { + text <- c(text, paste(" -", values[[var]]$text)) + } + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + +#' Partial Omega Squared. +#' +#' Partial Omega Squared. +#' +#' @param x aov object. +#' @param partial Return partial omega squared. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' +#' df <- psycho::affective +#' +#' x <- aov(df$Tolerating ~ df$Salary) +#' x <- aov(df$Tolerating ~ df$Salary * df$Sex) +#' +#' omega_sq(x) +#' @seealso http://stats.stackexchange.com/a/126520 +#' +#' @author Arnoud Plantinga +#' @importFrom stringr str_trim +#' @export +omega_sq <- function(x, partial = TRUE) { + if ("aov" %in% class(x)) { + summary_aov <- summary(x)[[1]] + } else { + summary_aov <- x + } + residRow <- nrow(summary_aov) + dfError <- summary_aov[residRow, 1] + msError <- summary_aov[residRow, 3] + nTotal <- sum(summary_aov$Df) + dfEffects <- summary_aov[1:{ + residRow - 1 + }, 1] + ssEffects <- summary_aov[1:{ + residRow - 1 + }, 2] + msEffects <- summary_aov[1:{ + residRow - 1 + }, 3] + ssTotal <- rep(sum(summary_aov[1:residRow, 2]), 3) + Omegas <- abs((ssEffects - dfEffects * msError) / (ssTotal + msError)) + names(Omegas) <- stringr::str_trim(rownames(summary_aov)[1:{ + residRow - 1 + }]) + + partOmegas <- abs((dfEffects * (msEffects - msError)) / + (ssEffects + (nTotal - dfEffects) * msError)) + names(partOmegas) <- stringr::str_trim(rownames(summary_aov)[1:{ + residRow - 1 + }]) + + if (partial == TRUE) { + return(partOmegas) + } else { + return(Omegas) + } +} + + + + + + + + + +#' Remove empty columns. +#' +#' Removes all columns containing ony NaNs. +#' +#' @param df Dataframe. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +remove_empty_cols <- function(df) { + df <- df[, colSums(is.na(df)) < nrow(df)] + return(df) +} + + + + +#' Creates or tests for objects of mode "psychobject". +#' +#' @param x an arbitrary R object. +#' +#' @export +is.psychobject <- function(x) inherits(x, "psychobject") + + + + + + + + +#' Create a reference grid. +#' +#' Create a reference grid. +#' +#' @param df The dataframe. +#' @param target String or list of strings to indicate target columns. Can be "all". +#' @param length.out Length of numeric target variables. +#' @param factors Type of summary for factors. Can be "combination" or "reference". +#' @param numerics Type of summary for numerics Can be "combination", any function ("mean", "median", ...) or a value. +#' @param na.rm Remove NaNs. +#' +#' @examples +#' library(psycho) +#' +#' df <- psycho::affective +#' newdata <- refdata(df, target = "Sex") +#' newdata <- refdata(df, target = "Sex", factors = "combinations") +#' newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), length.out = 3) +#' newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), numerics = 0) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom purrr keep +#' @import tidyr +#' @export +refdata <- function(df, target = "all", length.out = 10, factors = "reference", numerics = "mean", na.rm = TRUE) { + + # Target + if (all(target == "all") | ncol(df) == 1) { + return(.refdata_target(target = df[c(names(df))], length.out = length.out)) + } + + target_df <- .refdata_target(target = df[c(target)], length.out = length.out) + + # Rest + df_rest <- df[!names(df) %in% c(target)] + var_order <- names(df_rest) + + facs <- purrr::discard(df_rest, is.numeric) + facs <- mutate_all(facs, as.factor) + nums <- purrr::keep(df_rest, is.numeric) + + + smart_summary <- function(x, numerics) { + if (na.rm == TRUE) x <- na.omit(x) + + if (is.numeric(x)) { + fun <- paste0(numerics, "(x)") + out <- eval(parse(text = fun)) + } else if (is.factor(x)) { + out <- levels(x)[1] + } else if (is.character(x)) { + out <- unique(x)[1] + } else if (is.logical(x)) { + out <- unique(x)[1] + } else { + warning("Argument is not numeric nor factor: returning NA.") + out <- NA + } + return(out) + } + + + if (factors == "reference") { + facs <- dplyr::summarise_all(facs, smart_summary) + } else { + facs <- tidyr::expand_(facs, names(facs)) + } + + if (is.numeric(numerics)) { + nums[1, ] <- numerics + nums <- nums[1, ] + } else if (numerics == "combination") { + nums <- tidyr::expand_(nums, names(nums)) + } else { + nums <- dplyr::summarise_all(nums, smart_summary, numerics) + } + + + if (nrow(facs) == 0 | ncol(facs) == 0) { + refrest <- nums + } else if (nrow(nums) == 0 | ncol(nums) == 0) { + refrest <- facs + } else { + refrest <- merge(facs, nums) + } + + refrest <- refrest[var_order] + refdata <- merge(target_df, refrest) + + return(refdata) +} + + + + + + + + + + +#' @keywords internal +.refdata_target <- function(target, length.out = 10) { + at_vars <- names(target) + at_df <- data.frame() + for (var in at_vars) { + ref_var <- .refdata_var(x = target[[var]], length.out = length.out, varname = var) + if (nrow(at_df) == 0) { + at_df <- ref_var + } else { + at_df <- merge(at_df, ref_var) + } + } + return(at_df) +} + + + + + + + + + + + + + + + + + + +#' @keywords internal +.refdata_var <- function(x, length.out = 10, varname = NULL) { + if (is.numeric(x)) { + out <- data.frame(seq(min(x, na.rm = TRUE), + max(x, na.rm = TRUE), + length.out = length.out + )) + } else if (is.factor(x)) { + out <- data.frame(levels(x)) + } else if (is.character(x)) { + x <- as.factor(x) + out <- data.frame(levels(x)) + } else { + warning("Argument is not numeric nor factor: returning NA.") + out <- NA + return() + } + + if (is.null(varname)) { + names(out) <- "x" + } else { + names(out) <- varname + } + return(out) +} + + + + + +#' Remove outliers. +#' +#' Removes outliers (with the z-score method only for now). +#' +#' @param df Dataframe. +#' @param target String or list of strings of variables +#' @param threshold The z-score value (deviation of SD) by which to consider outliers. +#' @param direction Can be "both", "upper" or "lower". +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +remove_outliers <- function(df, target, threshold = qnorm(0.95), direction = "both") { + for (var in c(target)) { + df <- .remove_outliers(df, var, threshold, direction) + } + return(df) +} + + + + + + +#' @keywords internal +.remove_outliers <- function(df, target, threshold = qnorm(0.95), direction = "both") { + df <- df %>% + mutate_("outlier_criterion" = target) %>% + standardize(subset = "outlier_criterion") + if (direction %in% c("both", "upper")) { + df <- df %>% + filter_("outlier_criterion <= threshold") + } + if (direction %in% c("both", "lower")) { + df <- df %>% + filter_("outlier_criterion >= -threshold") + } + + df <- df %>% + select_("-outlier_criterion") + + return(df) +} + + + + + +#' Perfect Normal Distribution. +#' +#' Generates a sample of size n with a near-perfect normal distribution. +#' +#' @param n number of observations. If length(n) > 1, the length is taken to be the number required. +#' @param mean vector of means. +#' @param sd vector of standard deviations. +#' @param method "qnorm" or "average". +#' @param iter number of iterations (precision). +#' +#' @examples +#' library(psycho) +#' x <- rnorm_perfect(10) +#' plot(density(x)) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats rnorm +#' @export +rnorm_perfect <- function(n, mean = 0, sd = 1, method = "qnorm", iter = 10000) { + if (method == "average") { + x <- rowMeans(replicate(iter, sort(rnorm(n, mean, sd)))) + } else { + x <- qnorm(seq(1 / n, 1 - 1 / n, length.out = n), mean, sd) + } + return(x) +} + + + + + + +#' Region of Practical Equivalence (ROPE) +#' +#' Compute the proportion of a posterior distribution that lies within a region of practical equivalence. +#' +#' @param posterior Posterior Distribution. +#' @param bounds Rope lower and higher bounds. +#' @param CI The credible interval to use. +#' @param overlap Compute rope overlap (EXPERIMENTAL). +#' +#' +#' @return list containing rope indices +#' +#' @examples +#' library(psycho) +#' +#' posterior <- rnorm(1000, 0, 0.01) +#' results <- rope(posterior) +#' results$decision +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +rope <- function(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = FALSE) { + + + # Basic rope -------------------------------------------------------------- + + + HDI_area <- HDI(posterior, CI / 100) + HDI_area <- posterior[dplyr::between( + posterior, + HDI_area$values$HDImin, + HDI_area$values$HDImax + )] + + area_within <- HDI_area[dplyr::between(HDI_area, bounds[1], bounds[2])] + area_outside <- HDI_area[!dplyr::between(HDI_area, bounds[1], bounds[2])] + + p_within <- length(area_within) / length(posterior) + p_outside <- length(area_outside) / length(posterior) + + rope_decision <- ifelse(p_within == 0, "Accept", + ifelse(p_outside == 0, "Reject", "Undecided") + ) + + + + # Rope Overlap ------------------------------------------------------------ + if (overlap == TRUE) { + sd <- abs(bounds[1] - bounds[2]) / 2 + sd <- sd / 3 + norm <- rnorm_perfect(length(posterior), 0, sd) + rope_overlap <- overlap(posterior, norm) * 100 + output <- list(rope_decision = rope_decision, rope_probability = p_within, rope_overlap = rope_overlap) + } else { + output <- list(rope_decision = rope_decision, rope_probability = p_within) + } + + + + return(output) +} + + + + + + + + + +#' Simulates data for single or multiple regression. +#' +#' Simulates data for single or multiple regression. +#' +#' @param coefs Desired theorethical coefs. Can be a single value or a list. +#' @param sample Desired sample size. +#' @param error The error (standard deviation of gaussian noise). +#' +#' @examples +#' library(psycho) +#' +#' data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) +#' fit <- lm(y ~ ., data = data) +#' coef(fit) +#' analyze(fit) +#' @details See https://stats.stackexchange.com/questions/59062/multiple-linear-regression-simulation +#' +#' @author TPArrow +#' +#' @export +simulate_data_regression <- function(coefs = 0.5, sample = 100, error = 0) { + + # Prevent error + coefs[coefs == 0] <- 0.01 + + y <- rnorm(sample, 0, 1) + + n_var <- length(coefs) + X <- scale(matrix(rnorm(sample * (n_var), 0, 1), ncol = n_var)) + X <- cbind(y, X) + + # find the current correlation matrix + cor_0 <- var(X) + + # cholesky decomposition to get independence + chol_0 <- solve(chol(cor_0)) + + X <- X %*% chol_0 + + # create new correlation structure (zeros can be replaced with other r vals) + coefs_structure <- diag(x = 1, nrow = n_var + 1, ncol = n_var + 1) + coefs_structure[-1, 1] <- coefs + coefs_structure[1, -1] <- coefs + + X <- X %*% chol(coefs_structure) * sd(y) + mean(y) + X <- X[, -1] + + # Add noise + y <- y + rnorm(sample, 0, error) + + data <- data.frame(X) + names(data) <- paste0("V", 1:n_var) + data$y <- as.vector(y) + + return(data) +} + + + + + + +#' Standardize. +#' +#' Standardize objects. See the documentation for your object's class: +#' \itemize{ +#' \item{\link[=standardize.numeric]{standardize.numeric}} +#' \item{\link[=standardize.data.frame]{standardize.data.frame}} +#' \item{\link[=standardize.stanreg]{standardize.stanreg}} +#' \item{\link[=standardize.lm]{standardize.lm}} +#' \item{\link[=standardize.glm]{standardize.glm}} +#' } +#' +#' @param x Object. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +standardize <- function(x, ...) { + UseMethod("standardize") +} + + + + + + + + + + + + + + + + + + + + + + + + +#' Standardize (scale and reduce) numeric variables. +#' +#' Standardize (Z-score, "normalize") a vector. +#' +#' @param x Numeric vector. +#' @param normalize Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1. +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' standardize(x = c(1, 4, 6, 2)) +#' standardize(x = c(1, 4, 6, 2), normalize = TRUE) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' +#' @export +standardize.numeric <- function(x, normalize = FALSE, ...) { + if (all(is.na(x)) | length(unique(x)) == 2) { + return(x) + } + + if (normalize == FALSE) { + return(as.vector(scale(x, ...))) + } else { + return(as.vector((x - min(x, na.rm = TRUE)) / diff(range(x, na.rm = TRUE), na.rm = TRUE))) + } +} + + + + + + + + + + + + + + + + + + +#' Standardize (scale and reduce) Dataframe. +#' +#' Selects numeric variables and standardize (Z-score, "normalize") them. +#' +#' @param x Dataframe. +#' @param subset Character or list of characters of column names to be +#' standardized. +#' @param except Character or list of characters of column names to be excluded +#' from standardization. +#' @param normalize Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1. +#' @param ... Arguments passed to or from other methods. +#' +#' @return Dataframe. +#' +#' @examples +#' \dontrun{ +#' df <- data.frame( +#' Participant = as.factor(rep(1:25, each = 4)), +#' Condition = base::rep_len(c("A", "B", "C", "D"), 100), +#' V1 = rnorm(100, 30, .2), +#' V2 = runif(100, 3, 5), +#' V3 = rnorm(100, 100, 10) +#' ) +#' +#' dfZ <- standardize(df) +#' dfZ <- standardize(df, except = "V3") +#' dfZ <- standardize(df, except = c("V1", "V2")) +#' dfZ <- standardize(df, subset = "V3") +#' dfZ <- standardize(df, subset = c("V1", "V2")) +#' dfZ <- standardize(df, normalize = TRUE) +#' +#' # Respects grouping +#' dfZ <- df %>% +#' dplyr::group_by(Participant) %>% +#' standardize(df) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' +#' @importFrom purrr keep discard +#' @import dplyr +#' @export +standardize.data.frame <- function(x, subset = NULL, except = NULL, normalize = FALSE, ...) { + if (inherits(x, "grouped_df")) { + dfZ <- x %>% dplyr::do_(".standardize_df(., subset=subset, except=except, normalize=normalize, ...)") + } else { + dfZ <- .standardize_df(x, subset = subset, except = except, normalize = normalize, ...) + } + + return(dfZ) +} + + + + + + + + + + + + + + + + + +#' @keywords internal +.standardize_df <- function(x, subset = NULL, except = NULL, normalize = FALSE, ...) { + df <- x + + # Variable order + var_order <- names(df) + + # Keep subset + if (!is.null(subset) && subset %in% names(df)) { + to_keep <- as.data.frame(df[!names(df) %in% c(subset)]) + df <- df[names(df) %in% c(subset)] + } else { + to_keep <- NULL + } + + # Remove exceptions + if (!is.null(except) && except %in% names(df)) { + if (is.null(to_keep)) { + to_keep <- as.data.frame(df[except]) + } else { + to_keep <- cbind(to_keep, as.data.frame(df[except])) + } + + df <- df[!names(df) %in% c(except)] + } + + # Remove non-numerics + dfother <- purrr::discard(df, is.numeric) + dfnum <- purrr::keep(df, is.numeric) + + # Scale + dfnum <- as.data.frame(sapply(dfnum, standardize, normalize = normalize)) + + # Add non-numerics + if (is.null(ncol(dfother))) { + df <- dfnum + } else { + df <- dplyr::bind_cols(dfother, dfnum) + } + + # Add exceptions + if (!is.null(subset) | !is.null(except) && exists("to_keep")) { + df <- dplyr::bind_cols(df, to_keep) + } + + # Reorder + df <- df[var_order] + + return(df) +} + + + + + + + + + + + + + +#' Standardize Posteriors. +#' +#' Compute standardized posteriors from which to get standardized coefficients. +#' +#' @param x A stanreg model. +#' @param method "refit" (default) will entirely refit the model based on standardized data. Can take a long time. Other post-hoc methods are "posterior" (based on estimated SD) or "sample" (based on the sample SD). +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(rstanarm) +#' +#' fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = iris) +#' fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = standardize(iris)) +#' posteriors <- standardize(fit) +#' posteriors <- standardize(fit, method = "posterior") +#' } +#' +#' @author \href{https://github.com/jgabry}{Jonah Gabry}, \href{https://github.com/bgoodri}{bgoodri} +#' +#' @seealso https://github.com/stan-dev/rstanarm/issues/298 +#' +#' @importFrom utils capture.output +#' @export +standardize.stanreg <- function(x, method = "refit", ...) { + fit <- x + + predictors <- get_info(fit)$predictors + predictors <- c("(Intercept)", predictors) + + if (method == "sample") { + # By jgabry + predictors <- all.vars(as.formula(fit$formula)) + outcome <- predictors[[1]] + X <- as.matrix(model.matrix(fit)[, -1]) # -1 to drop column of 1s for intercept + sd_X_over_sd_y <- apply(X, 2, sd) / sd(fit$data[[outcome]]) + beta <- as.matrix(fit, pars = colnames(X)) # posterior distribution of regression coefficients + posteriors_std <- sweep(beta, 2, sd_X_over_sd_y, "*") # multiply each row of b by sd_X_over_sd_y + } else if (method == "posterior") { + # By bgoordi + X <- model.matrix(fit) + # if(preserve_factors == TRUE){ + # X <- as.data.frame(X) + # X[!names(as.data.frame(X)) %in% predictors] <- scale(X[!names(as.data.frame(X)) %in% predictors]) + # X <- as.matrix(X) + # } + sd_X <- apply(X, MARGIN = 2, FUN = sd)[-1] + sd_Y <- apply(rstanarm::posterior_predict(fit), MARGIN = 1, FUN = sd) + beta <- as.matrix(fit)[, 2:ncol(X), drop = FALSE] + posteriors_std <- sweep( + sweep(beta, MARGIN = 2, STATS = sd_X, FUN = `*`), + MARGIN = 1, STATS = sd_Y, FUN = `/` + ) + } else { + useless_output <- capture.output(fit_std <- update(fit, data = standardize(fit$data))) + posteriors_std <- as.data.frame(fit_std) + } + + return(posteriors_std) +} + + + + + + + +#' Standardize Coefficients. +#' +#' Compute standardized coefficients. +#' +#' @param x A linear model. +#' @param method The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "agresti". +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") +#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Sex), data = psycho::affective, family = "binomial") +#' +#' standardize(fit) +#' } +#' +#' @author Kamil Barton +#' @importFrom stats model.frame model.response model.matrix +#' +#' @seealso https://think-lab.github.io/d/205/ +#' +#' @export +standardize.glm <- function(x, method = "refit", ...) { + fit <- x + + if (method == "agresti") { + coefs <- MuMIn::coefTable(fit)[, 1:2] + X <- as.matrix(model.matrix(fit)[, -1]) # -1 to drop column of 1s for intercept + sd_X <- sd(X, na.rm = TRUE) + coefs <- coefs * sd_X + } else { + # refit method + data <- get_data(fit) + fit_std <- update(fit, data = standardize(data)) + + + coefs <- MuMIn::coefTable(fit_std)[, 1:2] + } + + coefs <- as.data.frame(coefs) + names(coefs) <- c("Coef_std", "SE_std") + return(coefs) +} + +#' @export +standardize.glmerMod <- standardize.glm + + + +#' Standardize Coefficients. +#' +#' Compute standardized coefficients. +#' +#' @param x A linear model. +#' @param method The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "posthoc". +#' @param partial_sd Logical, if set to TRUE, model coefficients are multiplied by partial SD, otherwise they are multiplied by the ratio of the standard deviations of the independent variable and dependent variable. +#' @param preserve_factors Standardize factors-related coefs only by the dependent variable (i.e., do not standardize the dummies generated by factors). +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' df <- mtcars %>% +#' mutate(cyl = as.factor(cyl)) +#' +#' fit <- lm(wt ~ mpg * cyl, data = df) +#' fit <- lmerTest::lmer(wt ~ mpg * cyl + (1 | gear), data = df) +#' +#' summary(fit) +#' standardize(fit) +#' } +#' +#' @author Kamil Barton +#' @importFrom stats model.frame model.response model.matrix +#' +#' @export +standardize.lm <- function(x, method = "refit", partial_sd = FALSE, preserve_factors = TRUE, ...) { + fit <- x + + if (method == "posthoc") { + coefs <- .standardize_coefs(fit, partial_sd = partial_sd, preserve_factors = preserve_factors) + } else { + data <- get_data(fit) + fit_std <- update(fit, data = standardize(data)) + coefs <- MuMIn::coefTable(fit_std)[, 1:2] + } + + coefs <- as.data.frame(coefs) + names(coefs) <- c("Coef_std", "SE_std") + return(coefs) +} + + +#' @export +standardize.lmerMod <- standardize.lm + + + + + + + + + + + + + + + + + +#' @keywords internal +.partialsd <- + function(x, sd, vif, n, p = length(x) - 1) { + sd * sqrt(1 / vif) * sqrt((n - 1) / (n - p)) + } + + +#' @importFrom stats vcov +#' @keywords internal +.vif <- + function(x) { + v <- vcov(x) + nam <- dimnames(v)[[1L]] + if (dim(v)[1L] < 2L) { + return(structure(rep_len(1, dim(v)[1L]), + names = dimnames(v)[[1L]] + )) + } + if ((ndef <- sum(is.na(MuMIn::coeffs(x)))) > 0L) { + stop(sprintf(ngettext( + ndef, "one coefficient is not defined", + "%d coefficients are not defined" + ), ndef)) + } + o <- attr(model.matrix(x), "assign") + if (any(int <- (o == 0))) { + v <- v[!int, !int, drop = FALSE] + } else { + warning("no intercept: VIFs may not be sensible") + } + d <- sqrt(diag(v)) + rval <- numeric(length(nam)) + names(rval) <- nam + rval[!int] <- diag(solve(v / (d %o% d))) + rval[int] <- 1 + rval + } + + + +#' @importFrom stats nobs vcov +#' @keywords internal +.standardize_coefs <- function(fit, partial_sd = FALSE, preserve_factors = TRUE, ...) { + # coefs <- MuMIn::coefTable(fit, ...) + coefs <- as.data.frame(MuMIn::coefTable(fit)) + model_matrix <- model.matrix(fit) + + predictors <- get_info(fit)$predictors + predictors <- c("(Intercept)", predictors) + + if (preserve_factors == TRUE) { + response_sd <- sd(model.response(model.frame(fit))) + factors <- as.data.frame(model_matrix)[!names(as.data.frame(model_matrix)) %in% predictors] + bx_factors <- rep(1 / response_sd, length(names(factors))) + bx_factors <- data.frame(t(bx_factors)) + names(bx_factors) <- names(factors) + coefs_factors <- coefs[names(factors), ] + model_matrix_factors <- as.matrix(factors) + + coefs <- coefs[!rownames(coefs) %in% names(factors), ] + model_matrix <- as.matrix(as.data.frame(model_matrix)[names(as.data.frame(model_matrix)) %in% predictors]) + } + + if (partial_sd == TRUE) { + bx <- .partialsd( + coefs[, 1L], + apply(model_matrix, 2L, sd), + .vif(fit), + nobs(fit), + sum(attr(model_matrix, "assign") != 0) + ) + } else { + response_sd <- sd(model.response(model.frame(fit))) + bx <- apply(model_matrix, 2L, sd) / response_sd + } + bx <- as.data.frame(t(bx)) + names(bx) <- row.names(coefs) + + if (preserve_factors == TRUE) { + bx <- cbind(bx, bx_factors) + } + + + # coefs <- MuMIn::coefTable(fit, ...) + coefs <- as.data.frame(MuMIn::coefTable(fit)) + multiplier <- as.numeric(bx[row.names(coefs)]) + + coefs[, 1L:2L] <- coefs[, 1L:2L] * multiplier + colnames(coefs)[1L:2L] <- c("Coef.std", "SE.std") + return(coefs) +} + + + + + + + +#' Print the results. +#' +#' Print the results. +#' +#' @param object A psychobject class object. +#' @param round Round the ouput. +#' @param ... Further arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @method summary psychobject +#' @export +summary.psychobject <- function(object, round = NULL, ...) { + summary <- object$summary + + if (!is.null(round)) { + nums <- dplyr::select_if(summary, is.numeric) + nums <- round(nums, round) + fact <- dplyr::select_if(summary, is.character) + fact <- cbind(fact, dplyr::select_if(summary, is.factor)) + summary <- cbind(fact, nums) + } + + return(summary) +} + + + + + + + +#' Extract values as list. +#' +#' @param x A psychobject class object. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +values <- function(x) { + values <- x$values + return(values) +} + + + + +#' Analyze blavaan (SEM or CFA) objects. +#' +#' Analyze blavaan (SEM or CFA) objects. +#' +#' @param x lavaan object. +#' @param CI Credible interval level. +#' @param standardize Compute standardized coefs. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(lavaan) +#' +#' model <- " visual =~ x1 + x2 + x3\ntextual =~ x4 + x5 + x6\nspeed =~ x7 + x8 + x9 " +#' x <- lavaan::cfa(model, data = HolzingerSwineford1939) +#' +#' rez <- analyze(x) +#' print(rez) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso +#' https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM +#' +#' @importFrom lavaan parameterEstimates fitmeasures +#' @importFrom blavaan standardizedposterior +#' +#' @export +analyze.blavaan <- function(x, CI = 90, standardize = FALSE, ...) { + fit <- x + + + # Processing + # ------------- + values <- list() + values$CI <- CI + + # Fit measures + values$Fit_Measures <- interpret_lavaan(fit) + + + # Text + # ------------- + computations <- .get_info_computations(fit) + fitmeasures <- values$Fit_Measures$text + text <- paste0( + "A Bayesian model was fitted (", + computations, + "). The fit indices are as following: ", + fitmeasures + ) + + # Summary + # ------------- + summary <- .summary_blavaan(fit, CI = CI, standardize = standardize) + + # Plot + # ------------- + plot <- "Use `get_graph` in association with ggraph." + + output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + +#' @keywords internal +.get_info_computations <- function(fit) { + chains <- blavaan::blavInspect(fit, "n.chains") + sample <- fit@external$sample + warmup <- fit@external$burnin + text <- paste0( + chains, + " chains, each with iter = ", + sample, + "; warmup = ", + warmup + ) + return(text) +} + + + + +#' @keywords internal +.process_blavaan <- function(fit, standardize = FALSE, CI = 90) { + # Get relevant rows + PE <- parameterEstimates(fit, + se = FALSE, ci = FALSE, remove.eq = FALSE, remove.system.eq = TRUE, + remove.ineq = FALSE, remove.def = FALSE, + add.attributes = TRUE + ) + if (!("group" %in% names(PE))) PE$group <- 1 + newpt <- fit@ParTable + pte2 <- which(newpt$free > 0) + relevant_rows <- match( + with(newpt, paste(lhs[pte2], op[pte2], rhs[pte2], group[pte2], sep = "")), + paste(PE$lhs, PE$op, PE$rhs, PE$group, sep = "") + ) + + # Priors + priors <- rep(NA, nrow(PE)) + priors[relevant_rows] <- newpt$prior[pte2] + priors[is.na(PE$prior)] <- "" + + + + + # Posterior + if (standardize == FALSE) { + posteriors <- blavaan::blavInspect(fit, "draws") %>% + as.matrix() %>% + as.data.frame() + names(posteriors) <- names(lavaan::coef(fit)) + } else { + posteriors <- blavaan::standardizedposterior(fit) %>% + as.data.frame() + } + + + + # Effects + MPE <- c() + Median <- c() + MAD <- c() + Effect <- c() + CI_lower <- c() + CI_higher <- c() + for (effect in names(posteriors)) { + posterior <- posteriors[[effect]] + Effect <- c(Effect, effect) + MPE <- c(MPE, mpe(posterior)$MPE) + Median <- c(Median, median(posterior)) + MAD <- c(MAD, mad(posterior)) + + CI_values <- HDI(posterior, prob = CI / 100) + CI_lower <- c(CI_lower, CI_values$values$HDImin) + CI_higher <- c(CI_higher, CI_values$values$HDImax) + } + + if (standardize == FALSE) { + Effects <- rep(NA, nrow(PE)) + Effects[relevant_rows] <- Effect + MPEs <- rep(NA, nrow(PE)) + MPEs[relevant_rows] <- MPE + Medians <- rep(NA, nrow(PE)) + Medians[relevant_rows] <- Median + MADs <- rep(NA, nrow(PE)) + MADs[relevant_rows] <- MAD + CI_lowers <- rep(NA, nrow(PE)) + CI_lowers[relevant_rows] <- CI_lower + CI_highers <- rep(NA, nrow(PE)) + CI_highers[relevant_rows] <- CI_higher + } else { + Effects <- Effect + MPEs <- MPE + Medians <- Median + MADs <- MAD + CI_lowers <- CI_lower + CI_highers <- CI_higher + } + + data <- data.frame( + "Effect" = Effects, + "Median" = Medians, + "MAD" = MADs, + "MPE" = MPEs, + "CI_lower" = CI_lowers, + "CI_higher" = CI_highers, + "Prior" = priors + ) + + return(data) +} + + + +#' @keywords internal +.summary_blavaan <- function(fit, CI = 90, standardize = FALSE) { + solution <- lavaan::parameterEstimates(fit, se = TRUE, ci = TRUE, standardized = FALSE, level = CI / 100) + + solution <- solution %>% + rename( + "From" = "rhs", + "To" = "lhs", + "Operator" = "op", + "Coef" = "est", + "SE" = "se", + "CI_lower" = "ci.lower", + "CI_higher" = "ci.upper" + ) %>% + mutate(Type = dplyr::case_when( + Operator == "=~" ~ "Loading", + Operator == "~" ~ "Regression", + Operator == "~~" ~ "Correlation", + TRUE ~ NA_character_ + )) %>% + select(one_of(c("To", "Operator", "From", "Type"))) %>% + mutate_("Effect" = "as.character(paste0(To, Operator, From))") %>% + full_join(.process_blavaan(fit, CI = CI, standardize = standardize) %>% + mutate_("Effect" = "as.character(Effect)"), by = "Effect") %>% + select_("-Effect") %>% + mutate_( + "Median" = "replace_na(Median, 1)", + "MAD" = "replace_na(MAD, 0)", + "MPE" = "replace_na(MPE, 100)" + ) %>% + select(one_of(c("From", "Operator", "To", "Median", "MAD", "CI_lower", "CI_higher", "MPE", "Prior", "Type"))) %>% + dplyr::filter_("Operator != '~1'") + + + return(solution) +} + + + + + + + + + + +#' Analyze fa objects. +#' +#' Analyze fa objects. +#' +#' @param x An psych object. +#' @param labels Supply a additional column with e.g. item labels. +#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(psych) +#' +#' x <- psych::fa(psych::Thurstone.33, 2) +#' +#' results <- analyze(x) +#' print(results) +#' summary(results) +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +analyze.fa <- function(x, labels = NULL, treshold = "max", ...) { + loadings <- format_loadings(x, labels) + + values <- list() + values$variance <- x$Vaccounted + values$loadings <- loadings$loadings + values$loadings_max <- loadings$max + values$cfa_model <- get_cfa_model(loadings$loadings, treshold = treshold) + + text <- .fa_variance_text(values$variance) + text <- paste0(text, "\n\n", format(values$cfa_model)) + summary <- values$loadings + plot <- plot_loadings(values$loadings) + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + +#' @export +.fa_variance_text <- function(variance) { + variance <- as.data.frame(variance) + n_factors <- ncol(variance) + + if (ncol(variance) == 1) { + t <- as.data.frame(t(variance)) + tot_var <- t$`Proportion Var` + text <- paste0( + "The unique component accounted for ", + format_digit(tot_var * 100), + "% of the total variance." + ) + } else { + t <- as.data.frame(t(variance)) + tot_var <- max(t$`Cumulative Var`) + + factors <- names(variance) + var <- variance["Proportion Var", ] + text_var <- paste0(factors, + " = ", + format_digit(var * 100), + "%", + collapse = ", " + ) + + text <- paste0( + "The ", + n_factors, + " components accounted for ", + format_digit(tot_var * 100), + "% of the total variance (" + ) + text <- paste0(text, text_var, ").") + } + + return(text) +} + + + + + + + +#' Format the loadings of a factor analysis. +#' +#' Format the loadings of a factor analysis. +#' +#' @param x An psych object. +#' @param labels Supply a additional column with e.g. item labels. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' x <- psych::fa(psych::Thurstone.33, 2) +#' format_loadings(x) +#' } +#' +#' @import dplyr +#' @export +format_loadings <- function(x, labels = NULL) { + + + # Check loadings and remove those inferior to a treshold + loadings <- x$loadings %>% + unclass() %>% + as.data.frame() + + # Save n factors + n_factors <- length(loadings) + + # Add item labels + loadings$Item <- rownames(loadings) + if (length(labels) == nrow(loadings)) { + loadings$Label <- labels + } else { + loadings$Label <- 1:nrow(loadings) + } + + # Keep Order + loadings$N <- 1:nrow(loadings) + + + # Select the max loading for each item + max <- get_loadings_max(loadings) + + + # Reorder the loading matrix accordingly + loadings <- loadings[max$N, ] %>% + select_("N", "Item", "Label", "everything()") + + return(list(loadings = loadings, max = max)) +} + + + +#' Get loadings max. +#' +#' Get loadings max. +#' +#' @param loadings Formatted loadings. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' x <- psych::fa(psych::Thurstone.33, 2) +#' get_loadings_max(format_loadings(x)$loadings) +#' } +#' +#' @import dplyr +#' @export +get_loadings_max <- function(loadings) { + max <- loadings %>% + tidyr::gather_("Component", "Loading", names(loadings)[!names(loadings) %in% c("Item", "N", "Label")]) %>% + dplyr::group_by_("Item") %>% + dplyr::slice_("which.max(abs(Loading))") %>% + dplyr::arrange_("Component", "desc(Loading)") + return(max) +} + + + +#' Get CFA model. +#' +#' Get CFA model. +#' +#' @param loadings Formatted loadings. +#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' x <- psych::fa(psych::Thurstone.33, 2) +#' loadings <- format_loadings(x)$loadings +#' get_cfa_model(loadings, treshold = "max") +#' get_cfa_model(loadings, treshold = 0.1) +#' } +#' +#' @import dplyr +#' @export +get_cfa_model <- function(loadings, treshold = "max") { + if (treshold == "max") { + filtered_loadings <- get_loadings_max(loadings) + } else { + filtered_loadings <- loadings %>% + tidyr::gather_("Component", "Loading", names(loadings)[!names(loadings) %in% c("Item", "N", "Label")]) %>% + filter_("Loading > treshold") + } + + cfa_model <- filtered_loadings %>% + select_("Item", "Component") %>% + group_by_("Component") %>% + summarise_("Observed" = 'paste(Item, collapse=" + ")') %>% + transmute_("Latent_Variable" = 'paste(Component, Observed, sep=" =~ ")') %>% + pull() + + cfa_model <- c("#Latent variables", cfa_model) %>% + paste(collapse = "\n") + + return(cfa_model) +} + + + + +#' Plot loadings. +#' +#' Plot loadings. +#' +#' @param loadings Loadings by variable. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' x <- psych::fa(psych::Thurstone.33, 2) +#' plot_loadings(format_loadings(x)$loadings) +#' } +#' +#' @import dplyr +#' @export +plot_loadings <- function(loadings) { + if (all(loadings$Label != loadings$N)) { + loadings$Item <- paste0(loadings$Label, " (", loadings$Item, ")") + } + + p <- loadings %>% + gather("Component", "Loading", matches("\\d$")) %>% + mutate_("Loading" = "abs(Loading)") %>% + mutate_("Item" = "factor(Item, levels=rev(get_loadings_max(loadings)$Item))") %>% + ggplot(aes_string(y = "Loading", x = "Item", fill = "Component")) + + geom_bar(stat = "identity") + + coord_flip() + + ylab("\nLoading Strength") + + xlab("Item\n") + + return(p) +} + + + + + + + +#' Analyze glm objects. +#' +#' Analyze glm objects. +#' +#' @param x glm object. +#' @param CI Confidence interval bounds. Set to NULL turn off their computation. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") +#' +#' results <- analyze(fit) +#' summary(results) +#' print(results) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. +#' +#' @seealso \link[=get_R2.glm]{"get_R2.glm"} +#' +#' @import dplyr +#' @importFrom stats formula +#' @importFrom stringr str_squish +#' @export +analyze.glm <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { + + + # Processing + # ------------- + fit <- x + + if (fit$family$family != "binomial") { + stop(paste("Models of family", fit$family$family, "not supported yet.")) + } + + info <- get_info(fit) + outcome <- info$outcome + predictors <- info$predictors + + # R2 <- tjur_D(fit) + R2 <- get_R2(fit, method = "nakagawa") + + # Summary + # ------------- + summary <- data.frame(summary(fit)$coefficients) + + summary$Variable <- rownames(summary) + summary$Coef <- summary$Estimate + summary$SE <- summary$`Std..Error` + summary$z <- summary$`z.value` + summary$p <- summary$`Pr...z..` + + # standardized coefficients + standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") + summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) + summary$Effect_Size <- c(NA, interpret_odds(tail(summary$Coef_std, -1), log = TRUE, rules = effsize_rules)) + + summary <- dplyr::select_( + summary, "Variable", "Coef", "SE", "z", "Coef_std", "SE_std", + "p", "Effect_Size" + ) + + if (!is.null(CI)) { + CI_values <- suppressMessages(confint(fit, level = CI / 100)) + CI_values <- tail(CI_values, n = length(rownames(summary))) + summary$CI_lower <- CI_values[, 1] + summary$CI_higher <- CI_values[, 2] + } + + + # Varnames + varnames <- summary$Variable + row.names(summary) <- varnames + + + + # Values + # ------------- + # Initialize empty values + values <- list(model = list(), effects = list()) + + # Loop over all variables + for (varname in varnames) { + if (summary[varname, "p"] < .1) { + significance <- " " + } else { + significance <- " not " + } + + if (!is.null(CI)) { + CI_text <- paste0( + ", ", + CI, "% CI [", + format_digit(summary[varname, "CI_lower"]), + ", ", + format_digit(summary[varname, "CI_higher"]), + "]" + ) + } else { + CI_text <- "" + } + + + + text <- paste0( + "The effect of ", + varname, + " is", + significance, + "significant (beta = ", + format_digit(summary[varname, "Coef"], 2), ", SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + ", z = ", + format_digit(summary[varname, "z"], 2), ", p ", + format_p(summary[varname, "p"], stars = FALSE), + ") and can be considered as ", + tolower(summary[varname, "Effect_Size"]), + " (std. beta = ", + format_digit(summary[varname, "Coef_std"], 2), + ", std. SE = ", + format_digit(summary[varname, "SE_std"], 2), ")." + ) + + if (varname == "(Intercept)") { + text <- paste0( + "The model's intercept is at ", + format_digit(summary[varname, "Coef"], 2), + " (SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + "). Within this model:" + ) + } + + values$effects[[varname]] <- list( + Coef = summary[varname, "Coef"], + SE = summary[varname, "SE"], + CI_lower = summary[varname, "CI_lower"], + CI_higher = summary[varname, "CI_higher"], + z = summary[varname, "z"], + Coef_std = summary[varname, "Coef_std"], + SE_std = summary[varname, "SE_std"], + p = summary[varname, "p"], + Effect_Size = summary[varname, "Effect_Size"], + Text = text + ) + } + + + + # Text + # ------------- + text <- c(paste0( + "The overall model predicting ", + outcome, + " (formula = ", + stringr::str_squish(paste0(format(stats::formula(fit)), collapse = "")), + ") has an explanatory power of ", + format_digit(R2 * 100, 2), + "%. ", + values$effects[["(Intercept)"]]$Text + )) + + for (varname in varnames) { + if (varname != "(Intercept)") { + text <- c(text, paste(" -", values$effects[[varname]]$Text)) + } + } + + + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + +#' Analyze glmerMod objects. +#' +#' Analyze glmerMod objects. +#' +#' @param x merModLmerTest object. +#' @param CI Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(lme4) +#' +#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") +#' +#' results <- analyze(fit) +#' summary(results) +#' print(results) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. +#' +#' @importFrom MuMIn r.squaredGLMM +#' @importFrom MuMIn std.coef +#' @importFrom stringr str_squish +#' @import lmerTest +#' @import dplyr +#' @export +analyze.glmerMod <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { + + + # Processing + # ------------- + fit <- x + + info <- get_info(fit) + R2 <- tryCatch({ + get_R2(fit) + }, error = function(e) { + warning("Couldn't compute R2. Might be caused by the presence of missing data.") + R2 <- list(R2m = NA, R2c = NA) + return(R2) + }) + + + + + + + + # Summary + # ------------- + summary <- data.frame(summary(fit)$coefficients) + + summary$Variable <- rownames(summary) + summary$Coef <- summary$Estimate + summary$SE <- summary$`Std..Error` + summary$z <- summary$`z.value` + summary$p <- summary$`Pr...z..` + + # standardized coefficients + standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") + summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) + summary$Effect_Size <- c(NA, interpret_odds(tail(summary$Coef_std, -1), log = TRUE, rules = effsize_rules)) + + + # Summary + summary <- dplyr::select_(summary, "Variable", "Coef", "SE", "z", "p", "Coef_std", "SE_std", "Effect_Size") + + # CI computation + if (!is.null(CI)) { + CI_values <- tryCatch({ + suppressMessages(confint(fit, level = CI / 100)) + }, error = function(e) { + warning("Couldn't compute CI. Skipping.") + CI_values <- NA + return(CI_values) + }) + if (!all(is.na(CI_values))) { + CI_values <- tail(CI_values, n = length(rownames(summary))) + summary$CI_lower <- CI_values[, 1] + summary$CI_higher <- CI_values[, 2] + } else { + CI <- NULL + } + } + + + # Varnames + varnames <- summary$Variable + row.names(summary) <- varnames + + + # Values + # ------------- + # Initialize empty values + values <- list(model = list(), effects = list()) + values$model$R2m <- R2$R2m + values$model$R2c <- R2$R2c + + # Loop over all variables + for (varname in varnames) { + if (summary[varname, "p"] < .1) { + significance <- " " + } else { + significance <- " not " + } + + if (!is.null(CI)) { + CI_text <- paste0( + ", ", + CI, "% CI [", + format_digit(summary[varname, "CI_lower"]), + ", ", + format_digit(summary[varname, "CI_higher"]), + "]" + ) + } else { + CI_text <- "" + } + + + + if (varname == "(Intercept)") { + text <- paste0( + "The model's intercept is at ", + format_digit(summary[varname, "Coef"], 2), + " (SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + "). Within this model:" + ) + } else { + text <- paste0( + "The effect of ", + varname, + " is", + significance, + "significant (beta = ", + format_digit(summary[varname, "Coef"], 2), + ", SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + ", z = ", + format_digit(summary[varname, "z"], 2), + ", p ", + format_p(summary[varname, "p"], stars = FALSE), + ") and can be considered as ", + tolower(summary[varname, "Effect_Size"]), + " (std. beta = ", + format_digit(summary[varname, "Coef_std"], 2), + ", std. SE = ", + format_digit(summary[varname, "SE_std"], 2), + ")." + ) + } + + values$effects[[varname]] <- list( + Coef = summary[varname, "Coef"], + SE = summary[varname, "SE"], + z = summary[varname, "z"], + p = summary[varname, "p"], + Effect_Size = summary[varname, "Effect_Size"], + Text = text + ) + } + + + + # Text + # ------------- + text <- c(paste0( + "The overall model predicting ", + info$outcome, + " (formula = ", + format(info$formula), + ") has an explanatory power (conditional R2) of ", + format_digit(R2$R2c * 100, 2), + "%, in which the fixed effects' part is ", + format_digit(R2$R2m * 100, 2), "% (marginal R2). ", + values$effects[["(Intercept)"]]$Text + )) + + for (varname in varnames) { + if (varname != "(Intercept)") { + text <- c(text, paste(" -", values$effects[[varname]]$Text)) + } + } + + + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + +#' Analyze htest (correlation, t-test...) objects. +#' +#' Analyze htest (correlation, t-test...) objects. +#' +#' @param x htest object. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' +#' df <- psycho::affective +#' +#' x <- t.test(df$Tolerating, df$Adjusting) +#' x <- t.test(df$Tolerating ~ df$Sex) +#' x <- t.test(df$Tolerating, mu = 2) +#' x <- cor.test(df$Tolerating, df$Adjusting) +#' +#' results <- analyze(x) +#' summary(results) +#' print(results) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import dplyr +#' +#' @export +analyze.htest <- function(x, effsize_rules = "cohen1988", ...) { + + + # Processing + # ------------- + values <- list() + values$method <- x$method + values$names <- x$data.name + values$statistic <- x$statistic + values$effect <- x$estimate + values$p <- x$p.value + values$df <- x$parameter + values$CI <- x$conf.int + values$signif <- ifelse(values$p < .05, "significant", "not significant") + values$CI_level <- attr(values$CI, "conf.level") * 100 + values$CI_format <- paste0(values$CI_level, "% CI [", format_digit(values$CI[1]), ", ", format_digit(values$CI[2]), "]") + + + + # Text + # ------------- + + # CORRELATION + if (grepl("correlation", values$method)) { + text <- paste0( + "The ", + values$method, + " between ", + values$names, + " is ", + values$signif, + ", ", + interpret_r(values$effect, rules = effsize_rules), + " (r(", + format_digit(values$df), + ") = ", + format_digit(values$effect), + ", ", + values$CI_format, + ", p ", + format_p(values$p, stars = FALSE), + ")." + ) + + # T-TEST + } else if (grepl("t-test", values$method)) { + if (names(x$null.value) == "mean") { + means <- paste0( + " (mean = ", + format_digit(values$effect), + ")" + ) + vars <- paste0(values$names, means, " and mu = ", x$null.value) + } else { + means <- paste0( + c( + paste0( + names(values$effect), " = ", + format_digit(values$effect) + ), + paste0( + "difference = ", + format_digit(values$effect[1] - values$effect[2]) + ) + ), + collapse = ", " + ) + vars <- paste0(values$names, " (", means, ")") + } + + values$effect <- values$effect[1] - values$effect[2] + + text <- paste0( + "The ", + values$method, + " suggests that the difference ", + ifelse(grepl(" by ", values$names), "of ", "between "), + vars, + " is ", + values$signif, + " (t(", + format_digit(values$df), + ") = ", + format_digit(values$statistic), + ", ", + values$CI_format, + ", p ", + format_p(values$p, stars = FALSE), + ")." + ) + # OTHER + } else { + stop(paste0("The ", values$method, " is not implemented yet.")) + } + + + # Summary + # ------------- + summary <- data.frame( + effect = values$effect, + statistic = values$statistic, + df = values$df, + p = values$p, + CI_lower = values$CI[1], + CI_higher = values$CI[2] + ) + rownames(summary) <- NULL + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + +#' Analyze lavaan SEM or CFA) objects. +#' +#' Analyze lavaan (SEM or CFA) objects. +#' +#' @param x lavaan object. +#' @param CI Confidence interval level. +#' @param standardize Compute standardized coefs. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(lavaan) +#' +#' model <- " visual =~ x1 + x2 + x3\ntextual =~ x4 + x5 + x6\nspeed =~ x7 + x8 + x9 " +#' x <- lavaan::cfa(model, data = HolzingerSwineford1939) +#' +#' rez <- analyze(x) +#' print(rez) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso +#' https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM +#' +#' +#' @importFrom lavaan parameterEstimates fitmeasures +#' +#' @export +analyze.lavaan <- function(x, CI = 95, standardize = FALSE, ...) { + fit <- x + + + # Processing + # ------------- + values <- list() + values$CI <- CI + + # Fit measures + values$Fit_Measures <- interpret_lavaan(fit) + + + + + # Summary + # ------------- + summary <- .summary_lavaan(fit, CI = CI, standardize = standardize) + + # Plot + # ------------- + plot <- "Use `get_graph` in association with ggraph." + + output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + + + + + +#' @keywords internal +.summary_lavaan <- function(fit, CI = 95, standardize = FALSE) { + if (standardize == FALSE) { + solution <- lavaan::parameterEstimates(fit, se = TRUE, standardized = standardize, level = CI / 100) + } else { + solution <- lavaan::standardizedsolution(fit, se = TRUE, level = CI / 100) %>% + rename_("est" = "est.std") + } + + solution <- solution %>% + rename( + "From" = "rhs", + "To" = "lhs", + "Operator" = "op", + "Coef" = "est", + "SE" = "se", + "p" = "pvalue", + "CI_lower" = "ci.lower", + "CI_higher" = "ci.upper" + ) %>% + mutate(Type = dplyr::case_when( + Operator == "=~" ~ "Loading", + Operator == "~" ~ "Regression", + Operator == "~~" ~ "Correlation", + TRUE ~ NA_character_ + )) %>% + mutate_("p" = "replace_na(p, 0)") + + if ("group" %in% names(solution)) { + solution <- solution %>% + rename("Group" = "group") %>% + select(one_of(c("Group", "From", "Operator", "To", "Coef", "SE", "CI_lower", "CI_higher", "p", "Type"))) + } else { + solution <- select(solution, one_of(c("From", "Operator", "To", "Coef", "SE", "CI_lower", "CI_higher", "p", "Type"))) + } + + return(solution) +} + + + + + + +#' Analyze lm objects. +#' +#' Analyze lm objects. +#' +#' @param x lm object. +#' @param CI Confidence interval bounds. Set to NULL turn off their computation. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) +#' fit <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris) +#' +#' results <- analyze(fit) +#' summary(results) +#' print(results) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import dplyr +#' @importFrom stats formula +#' @importFrom stringr str_squish +#' @export +analyze.lm <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { + + + # Processing + # ------------- + fit <- x + + info <- get_info(fit) + outcome <- info$outcome + predictors <- info$predictors + + R2 <- get_R2(fit) + R2adj <- R2$R2.adj + R2 <- R2$R2 + + # Summary + # ------------- + summary <- data.frame(summary(fit)$coefficients) + + summary$Variable <- rownames(summary) + summary$Coef <- summary$Estimate + summary$SE <- summary$`Std..Error` + summary$t <- summary$`t.value` + summary$p <- summary$`Pr...t..` + + # standardized coefficients + standardized <- tibble::rownames_to_column(standardize(fit, method = "refit", data = data), "Variable") + summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) + summary$Effect_Size <- c(NA, interpret_d(tail(summary$Coef_std, -1), rules = effsize_rules)) + + summary <- dplyr::select_( + summary, "Variable", "Coef", "SE", "t", "Coef_std", "SE_std", + "p", "Effect_Size" + ) + + if (!is.null(CI)) { + CI_values <- confint(fit, level = CI / 100) + CI_values <- tail(CI_values, n = length(rownames(summary))) + summary$CI_lower <- CI_values[, 1] + summary$CI_higher <- CI_values[, 2] + } + + + # Varnames + varnames <- summary$Variable + row.names(summary) <- varnames + + + + # Values + # ------------- + # Initialize empty values + values <- list(model = list(), effects = list()) + values$model$R2 <- R2 + values$model$R2adj <- R2adj + + + # Loop over all variables + for (varname in varnames) { + if (summary[varname, "p"] < .1) { + significance <- " " + } else { + significance <- " not " + } + + if (!is.null(CI)) { + CI_text <- paste0( + ", ", + CI, "% CI [", + format_digit(summary[varname, "CI_lower"]), + ", ", + format_digit(summary[varname, "CI_higher"]), + "]" + ) + } else { + CI_text <- "" + } + + + + text <- paste0( + "The effect of ", + varname, + " is", + significance, + "significant (beta = ", + format_digit(summary[varname, "Coef"], 2), ", SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + ", t = ", + format_digit(summary[varname, "t"], 2), ", p ", + format_p(summary[varname, "p"], stars = FALSE), + ") and can be considered as ", + tolower(summary[varname, "Effect_Size"]), + " (std. beta = ", + format_digit(summary[varname, "Coef_std"], 2), + ", std. SE = ", + format_digit(summary[varname, "SE_std"], 2), ")." + ) + + if (varname == "(Intercept)") { + text <- paste0( + "The model's intercept is at ", + format_digit(summary[varname, "Coef"], 2), + " (SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + "). Within this model:" + ) + } + + values$effects[[varname]] <- list( + Coef = summary[varname, "Coef"], + SE = summary[varname, "SE"], + CI_lower = summary[varname, "CI_lower"], + CI_higher = summary[varname, "CI_higher"], + t = summary[varname, "t"], + Coef_std = summary[varname, "Coef_std"], + SE_std = summary[varname, "SE_std"], + p = summary[varname, "p"], + Effect_Size = summary[varname, "Effect_Size"], + Text = text + ) + } + + + + # Text + # ------------- + text <- c(paste0( + "The overall model predicting ", + outcome, + " (formula = ", + stringr::str_squish(paste0(format(stats::formula(fit)), collapse = "")), + ") explains ", + format_digit(R2 * 100, 2), + "% of the variance of the endogen (adj. R2 = ", + format_digit(R2adj * 100, 2), + "). ", + values$effects[["(Intercept)"]]$Text + )) + + for (varname in varnames) { + if (varname != "(Intercept)") { + text <- c(text, paste(" -", values$effects[[varname]]$Text)) + } + } + + + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + + + +#' Analyze lmerModLmerTest objects. +#' +#' Analyze lmerModLmerTest objects. +#' +#' @param x lmerModLmerTest object. +#' @param CI Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(lmerTest) +#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) +#' +#' results <- analyze(fit) +#' summary(results) +#' print(results) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. +#' +#' @importFrom MuMIn r.squaredGLMM +#' @importFrom MuMIn std.coef +#' @importFrom stringr str_squish +#' @import dplyr +#' @export +analyze.lmerModLmerTest <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { + + + # Processing + # ------------- + fit <- x + + info <- get_info(fit) + R2 <- get_R2(fit) + + + + # TODO: Bootstrapped p values + # nsim determines p-value decimal places + # boot.out = lme4::bootMer(fit, lme4::fixef, nsim=1000) + # p = rbind( + # (1-apply(boot.out$t<0, 2, mean))*2, + # (1-apply(boot.out$t>0, 2, mean))*2) + # p = apply(p, 2, min) + + + + # Summary + # ------------- + summary <- data.frame(summary(fit)$coefficients) + + summary$Variable <- rownames(summary) + summary$Coef <- summary$Estimate + summary$SE <- summary$`Std..Error` + summary$df <- as.numeric(summary$df) + summary$t <- summary$`t.value` + summary$p <- summary$`Pr...t..` + + # standardized coefficients + standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") + summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) + summary$Effect_Size <- c(NA, interpret_d(tail(summary$Coef_std, -1), rules = effsize_rules)) + + summary <- dplyr::select_( + summary, "Variable", "Coef", "SE", "t", "df", "p", "Coef_std", "SE_std", "Effect_Size" + ) + + # CI computation + if (!is.null(CI)) { + CI_values <- tryCatch({ + suppressMessages(confint(fit, level = CI / 100)) + }, error = function(e) { + warning("Couldn't compute CI. Skipping.") + CI_values <- NA + return(CI_values) + }) + if (!all(is.na(CI_values))) { + CI_values <- tail(CI_values, n = length(rownames(summary))) + summary$CI_lower <- CI_values[, 1] + summary$CI_higher <- CI_values[, 2] + } else { + CI <- NULL + } + } + + + # Varnames + varnames <- summary$Variable + row.names(summary) <- varnames + + + # Values + # ------------- + # Initialize empty values + values <- list(model = list(), effects = list()) + values$model$R2m <- R2$R2m + values$model$R2c <- R2$R2c + + + # Loop over all variables + for (varname in varnames) { + if (summary[varname, "p"] < .1) { + significance <- " " + } else { + significance <- " not " + } + + if (!is.null(CI)) { + CI_text <- paste0( + ", ", + CI, "% CI [", + format_digit(summary[varname, "CI_lower"]), + ", ", + format_digit(summary[varname, "CI_higher"]), + "]" + ) + } else { + CI_text <- "" + } + + + + + if (varname == "(Intercept)") { + text <- paste0( + "The model's intercept is at ", + format_digit(summary[varname, "Coef"], 2), + " (SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + "). Within this model:" + ) + } else { + text <- paste0( + "The effect of ", + varname, + " is", + significance, + "significant (beta = ", + format_digit(summary[varname, "Coef"], 2), + ", SE = ", + format_digit(summary[varname, "SE"], 2), + CI_text, + ", t(", + format_digit(summary[varname, "df"], 0), + ") = ", + format_digit(summary[varname, "t"], 2), + ", p ", + format_p(summary[varname, "p"], stars = FALSE), + ") and can be considered as ", + tolower(summary[varname, "Effect_Size"]), + " (std. beta = ", + format_digit(summary[varname, "Coef_std"], 2), + ", std. SE = ", + format_digit(summary[varname, "SE_std"], 2), + ")." + ) + } + + values$effects[[varname]] <- list( + Coef = summary[varname, "Coef"], + SE = summary[varname, "SE"], + CI_lower = summary[varname, "CI_lower"], + CI_higher = summary[varname, "CI_higher"], + t = summary[varname, "t"], + df = summary[varname, "df"], + Coef_std = summary[varname, "Coef_std"], + SE_std = summary[varname, "SE_std"], + p = summary[varname, "p"], + Effect_Size = summary[varname, "Effect_Size"], + Text = text + ) + } + + + + # Text + # ------------- + text <- c(paste0( + "The overall model predicting ", + info$outcome, + " (formula = ", + format(info$formula), + ") has an total explanatory power (conditional R2) of ", + format_digit(R2$R2c * 100, 2), + "%, in which the fixed effects explain ", + format_digit(R2$R2m * 100, 2), "% of the variance (marginal R2). ", + values$effects[["(Intercept)"]]$Text + )) + + for (varname in varnames) { + if (varname != "(Intercept)") { + text <- c(text, paste(" -", values$effects[[varname]]$Text)) + } + } + + + + # Plot + # ------------- + plot <- "Not available yet" + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + +#' Analyze fa objects. +#' +#' Analyze fa objects. +#' +#' @param x An psych object. +#' @param labels Supply a additional column with e.g. item labels. +#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(psych) +#' +#' x <- psych::pca(psych::Thurstone.33, 2) +#' +#' results <- analyze(x) +#' print(results) +#' summary(results) +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +analyze.principal <- function(x, labels = NULL, treshold = "max", ...) { + loadings <- format_loadings(x, labels) + + values <- list() + values$variance <- x$Vaccounted + values$loadings <- loadings$loadings + values$loadings_max <- loadings$max + values$cfa_model <- get_cfa_model(loadings$loadings, treshold = treshold) + + text <- .fa_variance_text(values$variance) + text <- paste0(text, "\n\n", format(values$cfa_model)) + summary <- values$loadings + plot <- plot_loadings(values$loadings) + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + +#' Analyze objects. +#' +#' Analyze objects. See the documentation for your object's class: +#' \itemize{ +#' \item{\link[=analyze.stanreg]{analyze.stanreg}} +#' \item{\link[=analyze.lmerModLmerTest]{analyze.merModLmerTest}} +#' \item{\link[=analyze.glmerMod]{analyze.glmerMod}} +#' \item{\link[=analyze.lm]{analyze.lm}} +#' \item{\link[=analyze.glm]{analyze.glm}} +#' } +#' \itemize{ +#' \item{\link[=analyze.htest]{analyze.htest}} +#' \item{\link[=analyze.aov]{analyze.aov}} +#' } +#' \itemize{ +#' \item{\link[=analyze.fa]{analyze.fa}} +#' \item{\link[=analyze.principal]{analyze.principal}} +#' \item{\link[=analyze.lavaan]{analyze.lavaan}} +#' \item{\link[=analyze.blavaan]{analyze.blavaan}} +#' } +#' +#' @param x object to analyze. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +analyze <- function(x, ...) { + UseMethod("analyze") +} + + + + +#' Analyze stanreg objects. +#' +#' Analyze stanreg objects. +#' +#' @param x A stanreg model. +#' @param CI Credible interval bounds. +#' @param index Index of effect existence to report. Can be 'overlap' or 'ROPE'. +#' @param ROPE_bounds Bounds of the ROPE. If NULL and effsize is TRUE, than the ROPE. +#' will have default values c(-0.1, 0.1) and computed on the standardized posteriors. +#' @param effsize Compute Effect Sizes according to Cohen (1988). For linear models only. +#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. +#' @param ... Arguments passed to or from other methods. +#' +#' @return Contains the following indices: +#' \itemize{ +#' \item{the Median of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models).} +#' \item{the Median Absolute Deviation (MAD), a robust measure of dispertion (could be seen as a robust version of SD).} +#' \item{the Credible Interval (CI) (by default, the 90\% CI; see Kruschke, 2018), representing a range of possible parameter.} +#' \item{the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).} +#' \item{the Overlap (O), the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution.} +#' \item{the ROPE, the proportion of the 95\% CI of the posterior distribution that lies within the region of practical equivalence.} +#' } +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(rstanarm) +#' +#' data <- attitude +#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) +#' +#' results <- analyze(fit, effsize = TRUE) +#' summary(results) +#' print(results) +#' plot(results) +#' +#' +#' fit <- rstanarm::stan_lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) +#' results <- analyze(fit) +#' summary(results) +#' +#' fit <- rstanarm::stan_glm(Sex ~ Adjusting, +#' data = psycho::affective, family = "binomial" +#' ) +#' results <- analyze(fit) +#' summary(results) +#' +#' fit <- rstanarm::stan_glmer(Sex ~ Adjusting + (1 | Salary), +#' data = psycho::affective, family = "binomial" +#' ) +#' results <- analyze(fit) +#' summary(results) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso +#' \link[=get_R2.stanreg]{"get_R2.stanreg"} +#' \link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} +#' +#' @import loo +#' @import tidyr +#' @import dplyr +#' @import ggplot2 +#' @importFrom stats quantile as.formula +#' @importFrom utils head tail capture.output +#' @importFrom broom tidy +#' @importFrom stringr str_squish str_replace +#' @export +analyze.stanreg <- function(x, CI = 90, index = "overlap", ROPE_bounds = NULL, effsize = FALSE, effsize_rules = "cohen1988", ...) { + fit <- x + + # Info -------------------------------------------------------------------- + + # Algorithm + if (fit$algorithm == "optimizing") { + stop("Can't analyze models fitted with 'optimizing' algorithm.") + } + computations <- capture.output(fit$stanfit) + computations <- paste0(computations[2], computations[3], collapse = "") + computations <- stringr::str_remove_all(computations, ", total post-warmup draws.*") + computations <- stringr::str_remove_all(computations, " draws per chain") + computations <- stringr::str_replace_all(computations, "=", " = ") + + # Extract posterior distributions + posteriors <- as.data.frame(fit) + + + # Varnames + info <- get_info(fit) + outcome <- info$outcome + predictors <- info$predictors + + varnames <- names(fit$coefficients) + varnames <- varnames[grepl("b\\[", varnames) == FALSE] + + # Initialize empty values + values <- list(model = list(), effects = list()) + + values$model$formula <- fit$formula + values$model$outcome <- outcome + values$model$predictors <- predictors + + # Priors + info_priors <- rstanarm::prior_summary(fit) + values$priors <- info_priors + + # R2 ---------------------------------------------------------------------- + + R2 <- get_R2(fit, silent = TRUE) + if (is.list(R2)) { + posteriors$R2 <- R2$R2_posterior + R2.adj <- R2$R2.adj + if (!"R2" %in% varnames) { + varnames <- c("R2", varnames) + } + R2 <- TRUE + } else { + R2 <- FALSE + } + + # Random effect info -------------------------------------------- + if (is.mixed(fit)) { + random_info <- broom::tidy(fit, parameters = "varying") %>% + dplyr::rename_( + "Median" = "estimate", + "MAD" = "std.error" + ) + values$random <- random_info + } + + # Standardized posteriors -------------------------------------------- + if (effsize == TRUE) { + posteriors_std <- standardize(fit, method = "refit") + # Avoir some problems + if (length(setdiff(names(posteriors_std), varnames[varnames != "R2"])) != 0) { + names(posteriors_std) <- varnames[varnames != "R2"] + } + } else { + posteriors_std <- as.data.frame(fit) + } + + # Get indices of each variable -------------------------------------------- + + # Loop over all variables + for (varname in varnames) { + if (varname == "R2") { + values$effects[[varname]] <- .process_R2(varname, + posteriors, + info_priors, + R2.adj = R2.adj, + CI = CI, + effsize = effsize + ) + } else if (varname == "(Intercept)") { + values$effects[[varname]] <- .process_intercept(varname, + posteriors, + info_priors, + predictors, + CI = CI, + effsize = effsize + ) + } else { + values$effects[[varname]] <- .process_effect(varname, + posteriors, + posteriors_std = posteriors_std, + info_priors, + predictors, + CI = CI, + effsize = effsize, + effsize_rules = effsize_rules, + fit = fit, + index = index, + ROPE_bounds = ROPE_bounds + ) + } + } + + + # Summary -------------------------------------------------------------------- + summary <- data.frame() + for (varname in varnames) { + summary <- rbind( + summary, + data.frame( + Variable = varname, + Median = values$effects[[varname]]$median, + MAD = values$effects[[varname]]$mad, + CI_lower = values$effects[[varname]]$CI_values[1], + CI_higher = values$effects[[varname]]$CI_values[2], + Median_std = values$effects[[varname]]$std_median, + MAD_std = values$effects[[varname]]$std_mad, + MPE = values$effects[[varname]]$MPE, + ROPE = values$effects[[varname]]$ROPE, + Overlap = values$effects[[varname]]$overlap + ) + ) + } + + if (effsize == FALSE) { + summary <- select_(summary, "-Median_std", "-MAD_std") + } + + if (index == "ROPE") { + summary <- select_(summary, "-Overlap") + } else { + summary <- select_(summary, "-ROPE") + } + + # Text -------------------------------------------------------------------- + # ------------------------------------------------------------------------- + # Model + info <- paste0( + "We fitted a ", + ifelse(fit$algorithm == "sampling", "Markov Chain Monte Carlo", fit$algorithm), + " ", + fit$family$family, + " (link = ", + fit$family$link, + ") model (", + computations, + ") to predict ", + outcome, + " (formula = ", stringr::str_squish(paste0(format(fit$formula), collapse = "")), + "). The model's priors were set as follows: " + ) + + # Priors + text_priors <- rstanarm::prior_summary(fit) + if ("adjusted_scale" %in% names(text_priors$prior) & !is.null(text_priors$prior$adjusted_scale)) { + scale <- paste0( + "), scale = (", + paste(sapply(text_priors$prior$adjusted_scale, format_digit), collapse = ", ") + ) + } else { + scale <- paste0( + "), scale = (", + paste(sapply(text_priors$prior$scale, format_digit), collapse = ", ") + ) + } + + info_priors_text <- paste0( + " ~ ", + text_priors$prior$dist, + " (location = (", + paste(text_priors$prior$location, collapse = ", "), + scale, + "))" + ) + + # Coefs + coefs_text <- c() + for (varname in varnames) { + effect_text <- values$effects[[varname]]$text + if (effsize == TRUE) { + if (!varname %in% c("(Intercept)", "R2")) { + effsize_text <- stringr::str_replace( + values$effects[[varname]]$EffSize_text, + "The effect's size", + "It" + )[1] + effect_text <- paste(effect_text, effsize_text) + } + } + coefs_text <- c(coefs_text, effect_text) + } + + # Text + if ("R2" %in% varnames) { + text <- c( + info, + "", + info_priors_text, + "", + "", + paste0( + coefs_text[1], + coefs_text[2] + ), + "", + tail(coefs_text, -2) + ) + } else { + text <- c( + info, + "", + info_priors_text, + "", + "", + coefs_text[1], + "", + tail(coefs_text, -1) + ) + } + + + + + # Plot -------------------------------------------------------------------- + # ------------------------------------------------------------------------- + + plot <- posteriors[varnames] %>% + # select(-`(Intercept)`) %>% + gather() %>% + rename_(Variable = "key", Coefficient = "value") %>% + ggplot(aes_string(x = "Variable", y = "Coefficient", fill = "Variable")) + + geom_violin() + + geom_boxplot(fill = "grey", alpha = 0.3, outlier.shape = NA) + + stat_summary( + fun.y = "mean", geom = "errorbar", + aes_string(ymax = "..y..", ymin = "..y.."), + width = .75, linetype = "dashed", colour = "red" + ) + + geom_hline(aes(yintercept = 0)) + + theme_classic() + + coord_flip() + + scale_fill_brewer(palette = "Set1") + + scale_colour_brewer(palette = "Set1") + + + + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + + + + + + + + + + + +#' @keywords internal +.get_info_priors <- function(varname, info_priors, predictors = NULL) { + # Prior + # TBD: this doesn't work with categorical predictors :( + values <- list() + + if (varname == "(Intercept)") { + values["prior_distribution"] <- info_priors$prior_intercept$dist + values["prior_location"] <- info_priors$prior_intercept$location + values["prior_scale"] <- info_priors$prior_intercept$scale + values["prior_adjusted_scale"] <- info_priors$prior_intercept$adjusted_scale + } else { + if (varname %in% predictors) { + predictor_index <- which(predictors == varname) + if (length(info_priors$prior$dist) == 1) { + info_priors$prior$dist <- rep( + info_priors$prior$dist, + length(info_priors$prior$location) + ) + } + values["prior_distribution"] <- info_priors$prior$dist[predictor_index] + values["prior_location"] <- info_priors$prior$location[predictor_index] + values["prior_scale"] <- info_priors$prior$scale[predictor_index] + values["prior_adjusted_scale"] <- info_priors$prior$adjusted_scale[predictor_index] + } + } + return(values) +} + + + + + + + + +#' @keywords internal +.process_R2 <- function(varname, posteriors, info_priors, R2.adj = NULL, CI = 90, effsize = FALSE) { + values <- .get_info_priors(varname, info_priors) + posterior <- posteriors[, varname] + + # Find basic posterior indices + values$posterior <- posterior + values$median <- median(posterior) + values$mad <- mad(posterior) + values$mean <- mean(posterior) + values$sd <- sd(posterior) + values$CI_values <- HDI(posterior, prob = CI / 100) + values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) + values$MPE <- NA + values$MPE_values <- NA + values$overlap <- NA + values$ROPE <- NA + values$adjusted_r_squared <- R2.adj + + # Text + values$text <- paste0( + "The model has an explanatory power (R2) of about ", + format_digit(values$median * 100), + "% (MAD = ", + format_digit(values$mad), + ", ", + CI, + "% CI [", + format_digit(values$CI_values[1]), + ", ", + format_digit(values$CI_values[2]), + "]" + ) + + if (is.null(R2.adj) | is.na(R2.adj)) { + values$text <- paste0( + values$text, + ")." + ) + } else { + values$text <- paste0( + values$text, + ", adj. R2 = ", + format_digit(R2.adj), + ")." + ) + } + + + # Effize + if (effsize == TRUE) { + values$std_posterior <- NA + values$std_median <- NA + values$std_mad <- NA + values$std_mean <- NA + values$std_sd <- NA + values$std_CI_values <- NA + values$std_CI_values <- NA + + values$EffSize <- NA + values$EffSize_text <- NA + values$EffSize_VeryLarge <- NA + values$EffSize_Large <- NA + values$EffSize_Moderate <- NA + values$EffSize_Small <- NA + values$EffSize_VerySmall <- NA + values$EffSize_Opposite <- NA + } else { + values$std_median <- NA + values$std_mad <- NA + } + + return(values) +} + + + + +#' @keywords internal +.process_intercept <- function(varname, posteriors, info_priors, predictors, CI = 90, effsize = FALSE) { + values <- .get_info_priors(varname, info_priors, predictors) + posterior <- posteriors[, varname] + + # Find basic posterior indices + values$posterior <- posterior + values$median <- median(posterior) + values$mad <- mad(posterior) + values$mean <- mean(posterior) + values$sd <- sd(posterior) + values$CI_values <- HDI(posterior, prob = CI / 100) + values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) + values$MPE <- NA + values$MPE_values <- NA + values$overlap <- NA + values$ROPE <- NA + + + + # Text + values$text <- paste0( + " The intercept is at ", + format_digit(values$median), + " (MAD = ", + format_digit(values$mad), + ", ", + CI, + "% CI [", + format_digit(values$CI_values[1]), + ", ", + format_digit(values$CI_values[2]), + "]). Within this model:" + ) + + # Effize + if (effsize == TRUE) { + values$std_posterior <- NA + values$std_median <- NA + values$std_mad <- NA + values$std_mean <- NA + values$std_sd <- NA + values$std_CI_values <- NA + values$std_CI_values <- NA + + values$EffSize <- NA + values$EffSize_text <- NA + values$EffSize_VeryLarge <- NA + values$EffSize_Large <- NA + values$EffSize_Moderate <- NA + values$EffSize_Small <- NA + values$EffSize_VerySmall <- NA + values$EffSize_Opposite <- NA + } else { + values$std_median <- NA + values$std_mad <- NA + } + + return(values) +} + + + + +#' @keywords internal +.process_effect <- function(varname, + posteriors, + posteriors_std, + info_priors, + predictors, + CI = 90, + effsize = FALSE, + effsize_rules = FALSE, + fit, + index = "overlap", + ROPE_bounds = NULL) { + values <- .get_info_priors(varname, info_priors, predictors) + posterior <- posteriors[, varname] + + + # Find basic posterior indices + values$posterior <- posterior + values$median <- median(posterior) + values$mad <- mad(posterior) + values$mean <- mean(posterior) + values$sd <- sd(posterior) + values$CI_values <- HDI(posterior, prob = CI / 100) + values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) + values$MPE <- mpe(posterior)$MPE + values$MPE_values <- mpe(posterior)$values + + # Index + values$overlap <- 100 * overlap( + posterior, + rnorm_perfect( + length(posterior), + 0, + sd(posterior) + ) + ) + + if (!is.null(ROPE_bounds)) { + rope <- rope(posterior, bounds = ROPE_bounds) + values$ROPE_decision <- rope$rope_decision + values$ROPE <- rope$rope_probability + } else { + values$ROPE <- NA + values$ROPE_decision <- NA + } + + if (index == "overlap") { + index <- paste0( + "Overlap = ", + format_digit(values$overlap), + "%)." + ) + } else if (index == "ROPE") { + if (!is.null(ROPE_bounds)) { + index <- paste0( + "ROPE = ", + format_digit(values$ROPE), + ")." + ) + } else { + if (effsize == TRUE) { + rope <- rope(posteriors_std[, varname], bounds = c(-0.1, 0.1)) + values$ROPE_decision <- rope$rope_decision + values$ROPE <- rope$rope_probability + index <- paste0( + "ROPE = ", + format_digit(values$ROPE), + ")." + ) + } else { + warning("you need to specify ROPE_bounds (e.g. 'c(-0.1, 0.1)'). Computing overlap instead.") + index <- paste0( + "Overlap = ", + format_digit(values$overlap), + "%)." + ) + } + } + } else { + warning("Parameter 'index' should be 'overlap' or 'ROPE'. Computing overlap.") + index <- paste0( + "Overlap = ", + format_digit(values$overlap), + "%)." + ) + } + + + + + + # Text + if (grepl(":", varname)) { + splitted <- strsplit(varname, ":")[[1]] + if (length(splitted) == 2) { + name <- paste0( + "interaction between ", + splitted[1], " and ", splitted[2] + ) + } else { + name <- varname + } + } else { + name <- paste0("effect of ", varname) + } + + direction <- ifelse(values$median > 0, "positive", "negative") + + values$text <- paste0( + " - The ", + name, + " has a probability of ", + format_digit(values$MPE), + "% of being ", + direction, + " (Median = ", + format_digit(values$median), + ", MAD = ", + format_digit(values$mad), + ", ", + CI, + "% CI [", + format_digit(values$CI_values[1]), ", ", + format_digit(values$CI_values[2]), "], ", + index + ) + + + + # Effize + if (effsize == TRUE) { + posterior_std <- posteriors_std[, varname] + values$std_posterior <- posterior_std + values$std_median <- median(posterior_std) + values$std_mad <- mad(posterior_std) + values$std_mean <- mean(posterior_std) + values$std_sd <- sd(posterior_std) + values$std_CI_values <- HDI(posterior_std, prob = CI / 100) + values$std_CI_values <- c(values$std_CI_values$values$HDImin, values$std_CI_values$values$HDImax) + + if (fit$family$family == "binomial" & fit$family$link == "logit") { + EffSize <- interpret_odds_posterior(posterior_std, log = TRUE, rules = effsize_rules) + } else { + EffSize <- interpret_d_posterior(posterior_std, rules = effsize_rules) + } + + values$EffSize <- EffSize$summary + values$EffSize$Variable <- varname + values$EffSize_text <- EffSize$text + } else { + values$std_median <- NA + values$std_mad <- NA + } + + return(values) +} + + + + + + +#' Coerce to a Data Frame. +#' +#' Functions to check if an object is a data frame, or coerce it if possible. +#' +#' @param x any R object. +#' @param ... additional arguments to be passed to or from methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @method as.data.frame density +#' @export +as.data.frame.density <- function(x, ...) { + df <- data.frame(x = x$x, y = x$y) + + return(df) +} + + + +#' Compare a patient's score to a control group +#' +#' Compare a patient's score to a control group. +#' +#' @param patient Single value (patient's score). +#' @param controls Vector of values (control's scores). +#' @param mean Mean of the control sample. +#' @param sd SD of the control sample. +#' @param n Size of the control sample. +#' @param CI Credible interval bounds. +#' @param treshold Significance treshold. +#' @param iter Number of iterations. +#' @param color_controls Color of the controls distribution. +#' @param color_CI Color of CI distribution. +#' @param color_score Color of the line representing the patient's score. +#' @param color_size Size of the line representing the patient's score. +#' @param alpha_controls Alpha of the CI distribution. +#' @param alpha_CI lpha of the controls distribution. +#' @param verbose Print possible warnings. +#' +#' @return output +#' +#' @examples +#' result <- assess(patient = 124, mean = 100, sd = 15, n = 100) +#' print(result) +#' plot(result) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @details Until relatively recently the standard way of testing for a difference between a case and controls was to convert the case’s score to a z score using the control sample mean and standard deviation (SD). If z was less than -1.645 (i.e., below 95% of the controls) then it was concluded that the case was significantly lower than controls. However, this method has serious disadvantages (Crawford and Garthwaite, 2012). +#' +#' @importFrom stats ecdf +#' @import ggplot2 +#' @import dplyr +#' @export +assess <- function(patient, + mean = 0, + sd = 1, + n = NULL, + controls = NULL, + CI = 95, + treshold = 0.05, + iter = 10000, + color_controls = "#2196F3", + color_CI = "#E91E63", + color_score = "black", + color_size = 2, + alpha_controls = 1, + alpha_CI = 0.8, + verbose = TRUE) { + if (is.null(controls)) { + if (is.null(n)) { + if (verbose == TRUE) { + warning("Sample size (n) not provided, thus set to 1000.") + } + n <- 1000 + } + } + + + + + # If score is list + if (length(patient) > 1) { + if (verbose == TRUE) { + warning("Multiple scores were provided. Returning a list of results.") + } + results <- list() + for (i in seq_len(length(patient))) { + results[[i]] <- crawford.test( + patient[i], + controls, + mean, + sd, + n, + CI, + treshold, + iter, + color_controls, + color_CI, + color_score, + color_size, + alpha_controls, + alpha_CI + ) + return(results) + } + } else { + result <- crawford.test( + patient, + controls, + mean, + sd, + n, + CI, + treshold, + iter, + color_controls, + color_CI, + color_score, + color_size, + alpha_controls, + alpha_CI + ) + return(result) + } +} + + + + + + + + +#' Performs a Bayesian correlation. +#' +#' Performs a Bayesian correlation. +#' +#' @param x First continuous variable. +#' @param y Second continuous variable. +#' @param CI Credible interval bounds. +#' @param iterations The number of iterations to sample. +#' @param effsize_rules_r Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}. +#' @param effsize_rules_bf Grid for effect size interpretation. See \link[=interpret_bf]{interpret_bf}. +#' +#' @return A psychobject. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' x <- psycho::affective$Concealing +#' y <- psycho::affective$Tolerating +#' +#' bayes_cor.test(x, y) +#' summary(bayes_cor.test(x, y)) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom BayesFactor correlationBF posterior +#' @importFrom stats complete.cases cor.test +#' @import dplyr +#' @export +bayes_cor.test <- function(x, y, CI = 90, iterations = 10000, effsize_rules_r = "cohen1988", effsize_rules_bf = "jeffreys1961") { + + + # Varnames ---------------------------------------------------------------- + + + if (is.null(names(x))) { + var1 <- deparse(substitute(x)) + } else { + var1 <- names(x) + x <- pull(x) + } + + if (is.null(names(y))) { + var2 <- deparse(substitute(y)) + } else { + var2 <- names(y) + y <- pull(y) + } + + # Remove missing + var_x <- x[complete.cases(x, y)] + var_y <- y[complete.cases(x, y)] + + # Correlation ------------------------------------------------------------- + + # Stop if same variable + if (cor.test(var_x, var_y)$estimate > 0.999) { + return(1) + } + + + cor <- BayesFactor::correlationBF(var_x, var_y) + posterior <- as.vector(suppressMessages(BayesFactor::posterior(cor, iterations = iterations, progress = FALSE))) + + values <- list() + values$posterior <- posterior + values$bf <- as.vector(cor)[1] + values$median <- median(posterior) + values$mad <- mad(posterior) + values$mean <- mean(posterior) + values$sd <- sd(posterior) + values$CI <- HDI(posterior, prob = CI / 100)$text + values$CI_values <- HDI(posterior, prob = CI / 100) + values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) + values$MPE <- mpe(posterior)$MPE + values$MPE_values <- mpe(posterior)$values + + norm <- rnorm_perfect(length(posterior), 0, sd(posterior)) + values$overlap <- overlap(posterior, norm) * 100 + + rope_indices <- rope(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = TRUE) + values$rope_decision <- rope_indices$rope_decision + values$rope_probability <- rope_indices$rope_probability + values$rope_overlap <- rope_indices$rope_overlap + + + summary <- data.frame( + Median = values$median, + MAD = values$mad, + CI_lower = values$CI_values[1], + CI_higher = values$CI_values[2], + MPE = values$MPE, + BF = values$bf, + Overlap = values$overlap, + Rope = values$rope_decision + ) + rownames(summary) <- paste0(var1, " / ", var2) + + values$effect_size <- interpret_r_posterior(posterior, rules = effsize_rules_r) + interpretation_r <- interpret_r(values$median, strength = FALSE, rules = effsize_rules_r) + interpretation_bf <- interpret_bf(values$bf, direction = FALSE, rules = effsize_rules_bf) + if (values$bf < 1) { + interpretation_bf <- paste(interpretation_bf, "in favour of an absence of a ") + } else { + interpretation_bf <- paste(interpretation_bf, "in favour of the existence of a ") + } + + text <- paste0( + "Results of the Bayesian correlation indicate ", + interpretation_bf, + interpretation_r, + " association between ", + var1, + " and ", + var2, + " (r = ", + format_digit(values$median), + ", MAD = ", + format_digit(values$mad), + ", ", + CI, + "% CI [", + format_digit(values$CI_values[1]), + ", ", + format_digit(values$CI_values[2]), + "]). ", + values$effect_size$text + ) + + plot <- "Not available." + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + + return(output) +} + + + + + +#' Bayesian Correlation Matrix. +#' +#' Bayesian Correlation Matrix. +#' +#' @param df The dataframe. +#' @param df2 Optional dataframe to correlate with the first one. +#' @param reorder Reorder matrix by correlation strength. Only for square matrices. +#' +#' @return A list of dataframes +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' df <- psycho::affective +#' cor <- bayes_cor(df) +#' summary(cor) +#' print(cor) +#' plot(cor) +#' +#' df <- select(psycho::affective, Adjusting, Tolerating) +#' df2 <- select(psycho::affective, -Adjusting, -Tolerating) +#' cor <- bayes_cor(df, df2) +#' summary(cor) +#' print(cor) +#' plot(cor) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' @export +bayes_cor <- function(df, df2 = NULL, reorder = TRUE) { + df <- purrr::keep(df, is.numeric) + + if (!is.null(df2)) { + df2 <- purrr::keep(df2, is.numeric) + combinations <- expand.grid(names(df), names(df2)) + df <- cbind(df, df2) + } else { + combinations <- expand.grid(names(df), names(df)) + } + + size_row <- length(unique(combinations$Var1)) + size_col <- length(unique(combinations$Var2)) + dimnames <- list( + unique(combinations$Var1), + unique(combinations$Var2) + ) + + r <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) + mpe <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) + bf <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) + ci <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) + text <- matrix("", nrow = size_row, ncol = size_col, dimnames = dimnames) + + counter <- 0 + for (j in seq_len(size_col)) { + for (i in seq_len(size_row)) { + counter <- counter + 1 + + x <- df[[as.character(combinations$Var1[counter])]] + y <- df[[as.character(combinations$Var2[counter])]] + result <- bayes_cor.test(x, y) + + if (!is.psychobject(result)) { + text[i, j] <- "" + r[i, j] <- 1 + mpe[i, j] <- 100 + bf[i, j] <- Inf + ci[i, j] <- "100% CI [1, 1]" + } else { + text[i, j] <- paste0( + " - ", + names(df)[j], + " / ", + names(df)[i], + ": ", + result$text + ) + text[i, j] <- stringr::str_remove(text[i, j], "between x and y ") + r[i, j] <- result$values$median + mpe[i, j] <- result$values$MPE + bf[i, j] <- result$values$bf + ci[i, j] <- result$values$CI + } + } + } + + + # Reorder + if (is.null(df2) & reorder == TRUE) { + r <- reorder_matrix(r, r) + mpe <- reorder_matrix(mpe, r) + bf <- reorder_matrix(bf, r) + ci <- reorder_matrix(ci, r) + text <- reorder_matrix(text, r) + } + + + stars <- ifelse(bf > 30, "***", + ifelse(bf > 10, "**", + ifelse(bf > 3, "*", "") + ) + ) + + + + summary <- round(r, 2) + summary <- matrix(paste(summary, stars, sep = ""), ncol = ncol(r), dimnames = dimnames(r)) + + if (is.null(df2)) { + summary[upper.tri(summary, diag = TRUE)] <- "" # remove upper triangle + summary <- summary[-1, -ncol(summary)] # Remove first row and last column + + text[upper.tri(text, diag = TRUE)] <- "" # remove upper triangle + text <- text[-1, -ncol(text)] # Remove first row and last column + } + + summary <- as.data.frame(summary) + text <- as.vector(text) + text <- text[!text == ""] + + + # Values + values <- list( + r = r, + mpe = mpe, + bf = bf, + ci = ci, + stars = stars + ) + + # Plot + plot <- round(r, 2) %>% + as.data.frame() %>% + tibble::rownames_to_column("Var1") %>% + gather_("Var2", "Correlation", as.character(unique(combinations$Var2))) %>% + ggplot(aes_string(x = "Var2", y = "Var1", fill = "Correlation", label = "Correlation")) + + geom_tile(color = "white") + + scale_fill_gradient2( + low = "#2196F3", high = "#E91E63", mid = "white", + midpoint = 0, limit = c(-1, 1) + ) + + theme_minimal() + + theme( + axis.title = element_blank(), + axis.text.x = element_text( + angle = 45, + vjust = 1, + hjust = 1 + ), + legend.position = "none" + ) + + coord_fixed() + + geom_text(color = "black") + + + # Output + # ------------- + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + +#' Reorder square matrix. +#' +#' Reorder square matrix. +#' +#' @param mat A square matrix. +#' @param dmat A square matrix with values to use as distance. +#' +#' @examples +#' library(psycho) +#' +#' r <- correlation(iris) +#' r <- r$values$r +#' r <- reorder_matrix(r) +#' @importFrom stats as.dist hclust +#' @export +reorder_matrix <- function(mat, dmat = NULL) { + if (is.null(dmat)) { + dmat <- mat + } + + if (ncol(mat) != nrow(mat) | ncol(dmat) != nrow(dmat)) { + warning("Matrix must be squared.") + return(mat) + } + + dmat <- as.dist((1 - dmat) / 2, diag = TRUE, upper = TRUE) + hc <- hclust(dmat) + mat <- mat[hc$order, hc$order] + return(mat) +} + + + + + + + + +#' Citations of loaded packages. +#' +#' Get the citations of loaded packages. +#' +#' @param session A `devtools::sessionInfo()` object. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' cite_packages(sessionInfo()) +#' } +#' +#' @author \href{https://github.com/DominiqueMakowski}{Dominique Makowski} +#' +#' @export +cite_packages <- function(session) { + pkgs <- session$otherPkgs + citations <- c() + for (pkg_name in names(pkgs)) { + pkg <- pkgs[[pkg_name]] + + citation <- format(citation(pkg_name))[[2]] %>% + stringr::str_split("\n") %>% + flatten() %>% + paste(collapse = "SPLIT") %>% + stringr::str_split("SPLITSPLIT") + + i <- 1 + while (stringr::str_detect(citation[[1]][i], "To cite ")) { + i <- i + 1 + } + + + citation <- citation[[1]][i] %>% + stringr::str_remove_all("SPLIT") %>% + stringr::str_trim() %>% + stringr::str_squish() + + citations <- c(citations, citation) + } + return(data.frame("Packages" = citations)) +} + + + + + + + + +#' Multiple Correlations. +#' +#' Compute different kinds of correlation matrices. +#' +#' @param df The dataframe. +#' @param df2 Optional dataframe to correlate with the first one. +#' @param type A character string indicating which correlation type is to be +#' computed. One of "full" (default), "partial" (partial correlations), +#' "semi" (semi-partial correlations), "glasso" +#' (Graphical lasso- estimation of Gaussian graphical models) or "cor_auto" +#' (will use the qgraph::cor_auto function to return pychoric or polyserial +#' correlations if needed). +#' @param method A character string indicating which correlation coefficient is +#' to be computed. One of "pearson" (default), "kendall", or "spearman" can be +#' abbreviated. +#' @param adjust What adjustment for multiple tests should be used? ("holm", +#' "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"). See +#' \link[stats]{p.adjust} for details about why to use "holm" rather than +#' "bonferroni"). +#' @param i_am_cheating Set to TRUE to run many uncorrected correlations. +#' +#' @return output +#' +#' @examples +#' df <- attitude +#' +#' # Normal correlations +#' results <- psycho::correlation(df) +#' print(results) +#' plot(results) +#' +#' # Partial correlations with correction +#' results <- psycho::correlation(df, +#' type = "partial", +#' method = "spearman", +#' adjust = "holm" +#' ) +#' print(results) +#' plot(results) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats na.omit p.adjust cor runif +#' @importFrom psych corr.test +#' @importFrom ggplot2 theme element_text +#' @importFrom stringr str_to_title +#' @import ggcorrplot +#' @import ppcor +#' @import dplyr +#' @export +correlation <- function(df, + df2 = NULL, + type = "full", + method = "pearson", + adjust = "holm", + i_am_cheating = FALSE) { + + # Processing + # ------------------- + if (method == "bayes" | method == "bayesian") { + return(bayes_cor(df, df2, reorder = TRUE)) + } + + + # N samples + n <- nrow(df) + + # Remove non numeric + df <- purrr::keep(df, is.numeric) + if (is.null(df2) == FALSE) { + df2 <- purrr::keep(df2, is.numeric) + } + + # P-fishing prevention + if (ncol(df) > 10 && adjust == "none" && i_am_cheating == FALSE) { + warning("We've detected that you are running a lot (> 10) of correlation tests without adjusting the p values. To help you in your p-fishing, we've added some interesting variables: You never know, you might find something significant!\nTo deactivate this, change the 'i_am_cheating' argument to TRUE.") + df_complete <- dplyr::mutate_all(df, dplyr::funs_("replace(., is.na(.), 0)")) + df$Local_Air_Density <- svd(df_complete)$u[, 1] + df$Reincarnation_Cycle <- runif(nrow(df), max = 100) + df$Communism_Level <- -1 * svd(df_complete)$u[, 2] + df$Alien_Mothership_Distance <- rnorm(nrow(df), mean = 50000, sd = 5000) + df$Schopenhauers_Optimism <- svd(df_complete)$u[, 3] + df$Hulks_Power <- runif(nrow(df), max = 10) + } + + + + # Compute r coefficients + if (type == "full") { + corr <- psych::corr.test(df, y = df2, use = "pairwise", method = method, adjust = "none") + r <- corr$r + p <- corr$p + t <- corr$t + ci <- corr$ci + ci.adj <- corr$ci.adj + } else { + if (is.null(df2) == FALSE) { + df <- cbind(df, df2) + } + + df <- stats::na.omit(df) # enable imputation + if (type == "semi") { + corr <- ppcor::spcor(df, method = method) + r <- corr$estimate + p <- corr$p.value + t <- corr$statistic + ci <- "Not available for partial and semipartial correlations." + ci.adj <- "Not available for partial and semipartial correlations." + } + else if (type == "partial") { + corr <- ppcor::pcor(df, method = method) + r <- corr$estimate + p <- corr$p.value + t <- corr$statistic + ci <- "Not available for partial and semipartial correlations." + ci.adj <- "Not available for partial and semipartial correlations." + } + else if (type == "glasso") { + corr <- qgraph::EBICglasso(cor(df), n, gamma = 0.5) + r <- corr + p <- NULL + t <- NULL + ci <- "Not available for glasso estimation." + ci.adj <- "Not available for glasso estimation." + } + else if (type == "cor_auto") { + corr <- qgraph::cor_auto(df, forcePD = FALSE) + r <- corr + p <- NULL + t <- NULL + ci <- "Not available for cor_auto estimation." + ci.adj <- "Not available for cor_auto estimation." + } + else { + warning("type parameter must be 'full', 'semi', 'partial', 'glasso' or 'cor_auto'") + return() + } + } + + + + # Adjust P values + if (is.null(p) == FALSE) { + if (adjust != "none") { + if ((type == "full" & is.null(df2) == FALSE) | (type == "semi")) { + p[, ] <- p.adjust(p, method = adjust) + } else { + p[lower.tri(p)] <- p.adjust(p[lower.tri(p)], method = adjust, n = choose(nrow(p), 2)) + p[upper.tri(p)] <- p.adjust(p[upper.tri(p)], method = adjust, n = choose(nrow(p), 2)) + } + } + } + + + + + # Values + # ------------- + values <- list(r = r, p = p, t = t, ci = ci, ci.adj = ci.adj, n = n) + + + + + + # Summary + # ------------- + + # Define notions for significance levels; spacing is important. + if (is.null(p) == FALSE) { + stars <- ifelse(p < .001, "***", + ifelse(p < .01, "** ", + ifelse(p < .05, "* ", " ") + ) + ) + } else { + stars <- "" + } + + + # build a new correlation matrix with significance stars + table <- matrix(paste0(round(r, 2), stars), ncol = ncol(r)) + + + # Format + rownames(table) <- colnames(df) + if (isSymmetric(r)) { + diag(table) <- paste0(diag(round(r, 2)), " ") + colnames(table) <- colnames(df) + table[upper.tri(table, diag = TRUE)] <- "" # remove upper triangle + table <- as.data.frame(table) + # remove last column and return the matrix (which is now a data frame) + summary <- cbind(table[seq_len(length(table) - 1)]) + } else { + if (is.null(df2)) { + colnames(table) <- colnames(df) + } else { + if (type == "semi") { + colnames(table) <- colnames(df) + } else { + colnames(table) <- colnames(df2) + } + } + table <- as.data.frame(table) + summary <- table + } + + + + + # Text + # ------------- + sentences <- c() + for (row in seq_len(nrow(r))) { + for (col in seq_len(ncol(r))) { + if (as.matrix(table)[row, col] == "") next # skip iteration and go to next iteration + + val_r <- as.matrix(r)[row, col] + val_t <- tryCatch({ + as.matrix(t)[row, col] + }, error = function(e) { + "NA" + }) + val_p <- tryCatch({ + as.matrix(p)[row, col] + }, error = function(e) { + "NA" + }) + var1 <- colnames(r)[col] + var2 <- row.names(r)[row] + + if (is.numeric(val_p) & val_p <= .05) { + significance <- "significant " + } else if (is.numeric(val_p) & val_p > .05) { + significance <- "non significant " + } else { + significance <- "" + } + + + sentence <- paste0( + " - ", + var1, + " / ", + var2, + ": ", + "Results of the ", + stringr::str_to_title(method), + " correlation showed a ", + significance, + interpret_r(val_r), + " association between ", + var1, + " and ", + var2, + " (r(", + n - 2, + ") = ", + psycho::format_digit(val_r), + ", p ", + psycho::format_p(val_p), + ")." + ) + + sentences <- c(sentences, sentence) + } + } + + sentences <- c(paste0( + stringr::str_to_title(method), + " ", + stringr::str_to_title(type), + " correlation (p value correction: ", + adjust, + "):\n" + ), sentences) + + text <- sentences + + + + + # Plot + # ------------- + if (is.null(df2) == FALSE & type == "full") { + corr <- psych::corr.test(cbind(df, df2), use = "pairwise", method = method, adjust = "none") + r <- corr$r + p <- corr$p + p[lower.tri(p)] <- p.adjust(p[lower.tri(p)], method = adjust, n = choose(nrow(p), 2)) + p[upper.tri(p)] <- p.adjust(p[upper.tri(p)], method = adjust, n = choose(nrow(p), 2)) + # warning("Due to the presence of two dataframes, the plot might be incorrect. Consider with caution.") + } + + if (type == "semi") { + plot <- ggcorrplot::ggcorrplot( + r, + title = paste("A ", type, "'s correlation matrix (correction: ", adjust, ")\n", sep = ""), + method = "circle", + type = "full", + colors = c("#E91E63", "white", "#03A9F4"), + hc.order = TRUE, + p.mat = p, + insig = "pch", + legend.title = "", + lab = FALSE + ) + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.7)) + } else { + plot <- ggcorrplot::ggcorrplot( + r, + title = paste("A ", type, "'s correlation matrix (correction: ", adjust, ")\n", sep = ""), + method = "circle", + type = "lower", + colors = c("#E91E63", "white", "#03A9F4"), + hc.order = TRUE, + p.mat = p, + insig = "pch", + legend.title = "", + lab = FALSE + ) + + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.7)) + } + + + + # Output + # ------------- + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "psychobject_correlation", "list") + return(output) +} + + + + + + + + + + + +#' Crawford-Garthwaite (2007) Bayesian test for single-case analysis. +#' +#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2007) demonstrate that the Bayesian test is a better approach than other commonly-used alternatives. +#' . +#' +#' @param patient Single value (patient's score). +#' @param controls Vector of values (control's scores). +#' @param mean Mean of the control sample. +#' @param sd SD of the control sample. +#' @param n Size of the control sample. +#' @param CI Credible interval bounds. +#' @param treshold Significance treshold. +#' @param iter Number of iterations. +#' @param color_controls Color of the controls distribution. +#' @param color_CI Color of CI distribution. +#' @param color_score Color of the line representing the patient's score. +#' @param color_size Size of the line representing the patient's score. +#' @param alpha_controls Alpha of the CI distribution. +#' @param alpha_CI lpha of the controls distribution. +#' +#' +#' @details The p value obtained when this test is used to test significance also simultaneously provides a point estimate of the abnormality of the patient’s score; for example if the one-tailed probability is .013 then we know that the patient’s score is significantly (p < .05) below the control mean and that it is estimated that 1.3% of the control population would obtain a score lower than the patient’s. As for the credible interval interpretation, we could say that there is a 95% probability that the true level of abnormality of the patient’s score lies within the stated limits, or that There is 95% confidence that the percentage of people who have a score lower than the patient’s is between 0.01% and 6.66%. +#' +#' @examples +#' library(psycho) +#' +#' crawford.test(patient = 125, mean = 100, sd = 15, n = 100) +#' plot(crawford.test(patient = 80, mean = 100, sd = 15, n = 100)) +#' +#' crawford.test(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' test <- crawford.test(patient = 7, controls = c(0, -2, 5, -6, 0, 3, -4, -2)) +#' plot(test) +#' @author Dominique Makowski +#' +#' @importFrom stats pnorm var approx rchisq +#' @importFrom scales rescale +#' @import ggplot2 +#' @export +crawford.test <- function(patient, + controls = NULL, + mean = NULL, + sd = NULL, + n = NULL, + CI = 95, + treshold = 0.1, + iter = 10000, + color_controls = "#2196F3", + color_CI = "#E91E63", + color_score = "black", + color_size = 2, + alpha_controls = 1, + alpha_CI = 0.8) { + if (is.null(controls)) { + # Check if a parameter is null + if (length(c(mean, sd, n)) != 3) { + stop("Please provide either controls or mean, sd and n.") + } + sample_mean <- mean + sample_sd <- sd + sample_var <- sd^2 + } else { + sample_mean <- mean(controls) + sample_var <- var(controls) + sample_sd <- sd(controls) + n <- length(controls) + } + degfree <- n - 1 + + + # Computation ------------------------------------------------------------- + + + pvalues <- c() + for (i in 1:iter) { + # step 1 + psi <- rchisq(1, df = degfree, ncp = 0) + o <- (n - 1) * sample_var / psi + + # step 2 + z <- rnorm(1, 0, 1) + u <- sample_mean + z * sqrt((o / n)) + + # step 3 + z_patient <- (patient - u) / sqrt(o) + p <- 2 * (1 - pnorm(abs(z_patient), lower.tail = TRUE)) # One-tailed p-value + pvalues <- c(pvalues, p) + } + + + # Point estimates --------------------------------------------------------- + + z_score <- (patient - sample_mean) / sample_sd + perc <- percentile(z_score) + + pvalues <- pvalues / 2 + p <- mean(pvalues) + CI <- HDI(pvalues, prob = CI / 100) + # CI_1 <- sort(pvalues)[iter * (100 - CI) / 100] + + + # Text -------------------------------------------------------------------- + + p_interpretation <- ifelse(p < treshold, " significantly ", " not significantly ") + direction <- ifelse(patient - sample_mean < 0, " lower than ", " higher than ") + + + text <- paste0( + "The Bayesian test for single case assessment (Crawford, Garthwaite, 2007) suggests that the patient's score (Raw = ", + format_digit(patient), + ", Z = ", + format_digit(z_score), + ", percentile = ", + format_digit(perc), + ") is", + p_interpretation, + "different from the controls (M = ", + format_digit(sample_mean), + ", SD = ", + format_digit(sample_sd), + ", p ", + format_p(p), + ").", + " The patient's score is", + direction, + format_digit((1 - p) * 100), + "% (95% CI [", + paste(format_digit(sort(c((1 - CI$values$HDImin) * 100, (1 - CI$values$HDImax) * 100))), collapse = ", "), + "]) of the control population." + ) + + + + # Store values ------------------------------------------------------------ + + values <- list( + patient_raw = patient, + patient_z = z_score, + patient_percentile = perc, + controls_mean = sample_mean, + controls_sd = sample_sd, + controls_var = sample_var, + controls_sd = sample_sd, + controls_n = n, + text = text, + p = p, + CI_lower = CI$values$HDImin, + CI_higher = CI$values$HDImax + ) + + summary <- data.frame( + controls_mean = sample_mean, + controls_sd = sample_sd, + controls_n = n, + p = p, + CI_lower = CI$values$HDImin, + CI_higher = CI$values$HDImax + ) + + if (is.null(controls)) { + controls <- rnorm_perfect(n, sample_mean, sample_sd) + } + + + # Plot -------------------------------------------------------------------- + if (patient - sample_mean < 0) { + uncertainty <- percentile_to_z(pvalues * 100) + } else { + uncertainty <- percentile_to_z((1 - pvalues) * 100) + } + + + + + plot <- rnorm_perfect(length(uncertainty), 0, 1) %>% + density() %>% + as.data.frame() %>% + mutate_(y = "y/max(y)") %>% + mutate(distribution = "Control") %>% + rbind(uncertainty %>% + density() %>% + as.data.frame() %>% + mutate_(y = "y/max(y)") %>% + mutate(distribution = "Uncertainty")) %>% + mutate_(x = "scales::rescale(x, from=c(0, 1), to = c(sample_mean, sample_mean+sample_sd))") %>% + ggplot(aes_string(x = "x", ymin = 0, ymax = "y")) + + geom_ribbon(aes_string(fill = "distribution", alpha = "distribution")) + + geom_vline(xintercept = patient, colour = color_score, size = color_size) + + scale_fill_manual(values = c(color_controls, color_CI)) + + scale_alpha_manual(values = c(alpha_controls, alpha_CI)) + + xlab("\nScore") + + ylab("") + + theme_minimal() + + theme( + legend.position = "none", + axis.ticks.y = element_blank(), + axis.text.y = element_blank() + ) + + + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + +#' Crawford-Howell (1998) frequentist t-test for single-case analysis. +#' +#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. +#' . +#' +#' @param patient Single value (patient's score). +#' @param controls Vector of values (control's scores). +#' +#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the patient is different from the control group. +#' +#' @examples +#' library(psycho) +#' +#' crawford.test.freq(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' crawford.test.freq(patient = 7, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' @author Dan Mirman, Dominique Makowski +#' +#' @importFrom stats pt sd +#' @export +crawford.test.freq <- function(patient, controls) { + tval <- (patient - mean(controls)) / (sd(controls) * sqrt((length(controls) + 1) / length(controls))) + + degfree <- length(controls) - 1 + + pval <- 2 * (1 - pt(abs(tval), df = degfree)) # One-tailed p-value + + # One-tailed p value + if (pval > .05 & pval / 2 < .05) { + one_tailed <- paste0( + " However, the null hypothesis of no difference can be rejected at a one-tailed 5% significance level (one-tailed p ", + format_p(pval / 2), + ")." + ) + } else { + one_tailed <- "" + } + + + p_interpretation <- ifelse(pval < 0.05, " significantly ", " not significantly ") + t_interpretation <- ifelse(tval < 0, " lower than ", " higher than ") + + text <- paste0( + "The Crawford-Howell (1998) t-test suggests that the patient's score (", + format_digit(patient), + ") is", + p_interpretation, + "different from the controls (M = ", + format_digit(mean(controls)), + ", SD = ", + format_digit(sd(controls)), + ", t(", + degfree, + ") = ", + format_digit(tval), + ", p ", + format_p(pval), + ").", + one_tailed, + " The patient's score is", + t_interpretation, + format_digit((1 - pval) * 100), + "% of the control population." + ) + + values <- list( + text = text, + p = pval, + df = degfree, + t = tval + ) + summary <- data.frame(t = tval, df = degfree, p = pval) + plot <- "Not available yet" + + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + +#' Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks. +#' +#' Assessing dissociation between processes is a fundamental part of clinical neuropsychology. However, while the detection of suspected impairments is a fundamental feature of single-case studies, evidence of an impairment on a given task usually becomes of theoretical interest only if it is observed in the context of less impaired or normal performance on other tasks. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test for dissociation is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. +#' . +#' +#' @param case_X Single value (patient's score on test X). +#' @param case_Y Single value (patient's score on test Y). +#' @param controls_X Vector of values (control's scores of X). +#' @param controls_Y Vector of values (control's scores of Y). +#' @param verbose True or False. Prints the interpretation text. +#' +#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the dissociation between test X and test Y is significant. +#' +#' @examples +#' library(psycho) +#' +#' case_X <- 142 +#' case_Y <- 7 +#' controls_X <- c(100, 125, 89, 105, 109, 99) +#' controls_Y <- c(7, 8, 9, 6, 7, 10) +#' +#' crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y) +#' @author Dominique Makowski +#' +#' @importFrom stats sd pt +#' @export +crawford_dissociation.test <- function(case_X, case_Y, controls_X, controls_Y, verbose = TRUE) { + X_mean <- mean(controls_X) + X_sd <- sd(controls_X) + Y_mean <- mean(controls_Y) + Y_sd <- sd(controls_Y) + r <- cor(controls_X, controls_Y) + n <- length(controls_X) + degfree <- n - 1 + + case_X_Z <- (case_X - X_mean) / X_sd + case_Y_Z <- (case_Y - Y_mean) / Y_sd + + tval <- (case_X_Z - case_Y_Z) / sqrt((2 - 2 * r) * ((n + 1) / n)) + + pval <- 2 * (1 - pt(abs(tval), df = degfree)) # two-tailed p-value + + + + + + p_interpretation <- ifelse(pval < 0.05, " a significant ", " no ") + p_interpretation2 <- ifelse(pval < 0.05, " ", " not ") + z_interpretation <- ifelse(tval < 0, " below ", " above ") + pop_interpretation <- ifelse(tval < 0, " above ", " below ") + + if (abs(case_X_Z) > abs(case_Y_Z)) { + var_interpretation1 <- "test X" + var_interpretation2 <- "test Y" + } else { + var_interpretation1 <- "test Y" + var_interpretation2 <- "test X" + } + + text <- paste0( + "The Crawford-Howell (1998) t-test suggests", + p_interpretation, + "dissociation between test X and test Y (t(", + degfree, + ") = ", + format_digit(tval), + ", p ", + format_p(pval), + "). The patient's score on ", + var_interpretation1, + " is", + p_interpretation2, + "significantly altered compared to its score on ", + var_interpretation2, + "." + ) + + + result <- data.frame(t = tval, df = degfree, p = pval) + + if (verbose == TRUE) { + cat(paste0(text, "\n\n")) + } + + return(result) +} + + + + + + + +#' Overlap of Two Empirical Distributions. +#' +#' A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). +#' +#' @param x A vector of numerics. +#' @param n Number of intervals to create, OR +#' @param length Length of each interval. +#' @param equal_range Makes n groups with with equal range (TRUE) or (approximately) equal numbers of observations (FALSE). +#' @param labels Can be a custom list, "NULL", "FALSE" or "median". +#' @param dig.lab Integer which is used when labels are not given. It determines the number of digits used in formatting the break numbers. +#' +#' @examples +#' library(psycho) +#' +#' x <- rnorm(100, 0, 1) +#' +#' create_intervals(x, n = 4) +#' create_intervals(x, n = 4, equal_range = FALSE) +#' create_intervals(x, length = 1) +#' +#' create_intervals(x, n = 4, labels = "median") +#' create_intervals(x, n = 4, labels = FALSE) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom ggplot2 cut_interval cut_number +#' @export +create_intervals <- function(x, n = NULL, length = NULL, equal_range = TRUE, labels = NULL, dig.lab = 3) { + if (equal_range) { + if (is.character(labels) && labels == "median") { + cuts <- ggplot2::cut_interval(x, n = n, length = length, labels = FALSE) + } else { + cuts <- ggplot2::cut_interval(x, n = n, length = length, labels = labels, dig.lab = dig.lab) + } + } else { + if (is.character(labels) && labels == "median") { + cuts <- ggplot2::cut_number(x, n = n, labels = FALSE) + } else { + cuts <- ggplot2::cut_number(x, n = n, labels = labels, dig.lab = dig.lab) + } + } + + + if (is.character(labels) && labels == "median") { + cuts <- cuts %>% + data.frame(x) %>% + group_by_(".") %>% + mutate_("cuts" = "median(x)") %>% + ungroup() %>% + select_("cuts") %>% + pull() + } + + return(cuts) +} + + + + + + + + + + + +#' Dprime and Other Signal Detection Theory indices. +#' +#' Computes Signal Detection Theory indices (d', beta, A', B''D, c). +#' +#' @param n_hit Number of hits. +#' @param n_fa Number of false alarms. +#' @param n_miss Number of misses. +#' @param n_cr Number of correct rejections. +#' @param n_targets Number of targets (n_hit + n_miss). +#' @param n_distractors Number of distractors (n_fa + n_cr). +#' @param adjusted Should it use the Hautus (1995) adjustments for extreme values. +#' +#' @return Calculates the d', the beta, the A' and the B''D based on the signal detection theory (SRT). See Pallier (2002) for the algorithms. +#' +#' Returns a list containing the following indices: +#' \itemize{ +#' \item{\strong{dprime (d')}: }{The sensitivity. Reflects the distance between the two distributions: signal, and signal+noise and corresponds to the Z value of the hit-rate minus that of the false-alarm rate.} +#' \item{\strong{beta}: }{The bias (criterion). The value for beta is the ratio of the normal density functions at the criterion of the Z values used in the computation of d'. This reflects an observer's bias to say 'yes' or 'no' with the unbiased observer having a value around 1.0. As the bias to say 'yes' increases (liberal), resulting in a higher hit-rate and false-alarm-rate, beta approaches 0.0. As the bias to say 'no' increases (conservative), resulting in a lower hit-rate and false-alarm rate, beta increases over 1.0 on an open-ended scale.} +#' \item{\strong{c}: }{Another index of bias. the number of standard deviations from the midpoint between these two distributions, i.e., a measure on a continuum from "conservative" to "liberal".} +#' \item{\strong{aprime (A')}: }{Non-parametric estimate of discriminability. An A' near 1.0 indicates good discriminability, while a value near 0.5 means chance performance.} +#' \item{\strong{bppd (B''D)}: }{Non-parametric estimate of bias. A B''D equal to 0.0 indicates no bias, positive numbers represent conservative bias (i.e., a tendency to answer 'no'), negative numbers represent liberal bias (i.e. a tendency to answer 'yes'). The maximum absolute value is 1.0.} +#' } +#' +#' +#' Note that for d' and beta, adjustement for extreme values are made following the recommandations of Hautus (1995). + + +#' @examples +#' library(psycho) +#' +#' n_hit <- 9 +#' n_fa <- 2 +#' n_miss <- 1 +#' n_cr <- 7 +#' +#' indices <- psycho::dprime(n_hit, n_fa, n_miss, n_cr) +#' +#' +#' df <- data.frame( +#' Participant = c("A", "B", "C"), +#' n_hit = c(1, 2, 5), +#' n_fa = c(6, 8, 1) +#' ) +#' +#' indices <- psycho::dprime( +#' n_hit = df$n_hit, +#' n_fa = df$n_fa, +#' n_targets = 10, +#' n_distractors = 10, +#' adjusted = FALSE +#' ) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats qnorm +#' @export +dprime <- function(n_hit, n_fa, n_miss = NULL, n_cr = NULL, n_targets = NULL, n_distractors = NULL, adjusted = TRUE) { + if (is.null(n_targets)) { + n_targets <- n_hit + n_miss + } + + if (is.null(n_distractors)) { + n_distractors <- n_fa + n_cr + } + + + # Parametric Indices ------------------------------------------------------ + + + if (adjusted == TRUE) { + if (is.null(n_miss) | is.null(n_cr)) { + warning("Please provide n_miss and n_cr in order to compute adjusted ratios. Computing indices anyway with non-adjusted ratios...") + + # Non-Adjusted ratios + hit_rate_adjusted <- n_hit / n_targets + fa_rate_adjusted <- n_fa / n_distractors + } else { + # Adjusted ratios + hit_rate_adjusted <- (n_hit + 0.5) / ((n_hit + 0.5) + n_miss + 1) + fa_rate_adjusted <- (n_fa + 0.5) / ((n_fa + 0.5) + n_cr + 1) + } + + # dprime + dprime <- qnorm(hit_rate_adjusted) - qnorm(fa_rate_adjusted) + + # beta + zhr <- qnorm(hit_rate_adjusted) + zfar <- qnorm(fa_rate_adjusted) + beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) + + # c + c <- -(qnorm(hit_rate_adjusted) + qnorm(fa_rate_adjusted)) / 2 + } else { + # Ratios + hit_rate <- n_hit / n_targets + fa_rate <- n_fa / n_distractors + + # dprime + dprime <- qnorm(hit_rate) - qnorm(fa_rate) + + # beta + zhr <- qnorm(hit_rate) + zfar <- qnorm(fa_rate) + beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) + + # c + c <- -(qnorm(hit_rate) + qnorm(fa_rate)) / 2 + } + + # Non-Parametric Indices ------------------------------------------------------ + + # Ratios + hit_rate <- n_hit / n_targets + fa_rate <- n_fa / n_distractors + + # aprime + a <- 1 / 2 + ((hit_rate - fa_rate) * (1 + hit_rate - fa_rate) / (4 * hit_rate * (1 - fa_rate))) + b <- 1 / 2 - ((fa_rate - hit_rate) * (1 + fa_rate - hit_rate) / (4 * fa_rate * (1 - hit_rate))) + + a[fa_rate > hit_rate] <- b[fa_rate > hit_rate] + a[fa_rate == hit_rate] <- .5 + aprime <- a + + # bppd + bppd <- (hit_rate * (1 - hit_rate) - fa_rate * (1 - fa_rate)) / (hit_rate * (1 - hit_rate) + fa_rate * (1 - fa_rate)) + bppd_b <- (fa_rate * (1 - fa_rate) - hit_rate * (1 - hit_rate)) / (fa_rate * (1 - fa_rate) + hit_rate * (1 - hit_rate)) + bppd[fa_rate > hit_rate] <- bppd_b[fa_rate > hit_rate] + + + + return(list(dprime = dprime, beta = beta, aprime = aprime, bppd = bppd, c = c)) +} + + + + + + + + +#' Returns all combinations of lavaan models with their indices of fit. +#' +#' Returns all combinations of lavaan models with their indices of fit. +#' +#' @param fit A lavaan object. +#' @param latent Copy/paste the part related to latent variables loadings. +#' @param samples Number of random draws. +#' @param verbose Show progress. +#' @param ... Arguments passed to or from other methods. +#' +#' @return list containing all combinations. +#' +#' @examples +#' library(psycho) +#' library(lavaan) +#' +#' model <- " visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 +#' visual ~ textual +#' textual ~ speed" +#' fit <- lavaan::sem(model, data = HolzingerSwineford1939) +#' +#' models <- find_best_model(fit, latent = "visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9") +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import dplyr +#' +#' @method find_best_model lavaan +#' @export +find_best_model.lavaan <- function(fit, latent = "", samples = 1000, verbose = FALSE, ...) { + update_model <- function(fit, latent, model) { + newfit <- update(fit, paste0(latent, "\n", model)) + + indices <- data.frame(Value = lavaan::fitMeasures(newfit)) %>% + tibble::rownames_to_column("Index") %>% + tidyr::spread_("Index", "Value") %>% + cbind(data.frame( + model = model, + n_links = nrow(lavaan::lavInspect(fit, "est")$beta) + )) + return(indices) + } + + vars <- row.names(lavaan::lavInspect(fit, "est")$beta) + # info <- fit@Model + + data <- data.frame() + for (outcome in vars) { + remaning_vars <- vars[!stringr::str_detect(vars, outcome)] + combinations <- c() + for (y in 1:length(remaning_vars)) { + combinations <- c(combinations, combn(remaning_vars, y, simplify = FALSE)) + } + combinations <- sapply(combinations, paste0, collapse = "+") + combinations <- paste0(outcome, "~", combinations) + x <- data.frame(A = combinations) + names(x) <- c(outcome) + if (nrow(data) == 0) { + data <- x + } else { + data <- cbind(data, x) + } + } + + data <- rbind(data, head(data[NA, ], 1)) + data[] <- lapply(data, as.character) + data[is.na(data)] <- "" + rownames(data) <- NULL + + out <- data.frame() + for (i in 1:samples) { + if (verbose == TRUE) { + cat(".") + } + model <- "" + for (var in names(data)) { + model <- paste0(model, sample(data[[var]], 1), "\n") + } + + if (!model %in% out$model) { + out <- tryCatch( + rbind(out, update_model(fit, latent, model)), + error = function(e) out, + warning = function(w) out + ) + } + } + return(out) +} + + + + + + + + +#' Returns the best combination of predictors for lmerTest objects. +#' +#' Returns the best combination of predictors for lmerTest objects. +#' +#' @param fit A merModLmerTest object. +#' @param interaction Include interaction term. +#' @param fixed Additional formula part to add at the beginning of +#' each formula +#' @param ... Arguments passed to or from other methods. +#' +#' @return list containing all combinations. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(lmerTest) +#' +#' data <- standardize(iris) +#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = data) +#' +#' best <- find_best_model(fit) +#' best_formula <- best$formula +#' best$table +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats update +#' @import dplyr +#' +#' @method find_best_model lmerModLmerTest +#' @export +find_best_model.lmerModLmerTest <- function(fit, interaction = TRUE, fixed = NULL, ...) { + + # Extract infos + combinations <- find_combinations(as.formula(get_formula(fit)), interaction = interaction, fixed = fixed) + + + # Recreating the dataset without NA + dataComplete <- fit@frame[complete.cases(fit@frame), ] + + + # fit models + models <- c() + for (formula in combinations) { + newfit <- update(fit, formula, data = dataComplete) + models <- c(models, newfit) + } + + + # No warning messages for this part + options(warn = -1) + + # Model comparison + comparison <- as.data.frame(do.call("anova", models)) + + # Re-displaying warning messages + options(warn = 0) + + # Creating row names to the combinations array equivalent to the comparison data frame + combinations <- as.data.frame(combinations, row.names = paste0("MODEL", seq(1, length(combinations)))) + + # Reordering the rows in the same way for both combinations and comparison before implementing the formulas + comparison <- comparison[ order(row.names(comparison)), ] + comparison$formula <- combinations[order(row.names(combinations)), ] + + # Sorting the data frame by the AIC then BIC + comparison <- comparison[order(comparison$AIC, comparison$BIC), ] + + + + # Best model by criterion + best_aic <- dplyr::arrange_(comparison, "AIC") %>% + dplyr::select_("formula") %>% + head(1) + best_aic <- as.character(best_aic[[1]]) + + best_bic <- dplyr::arrange_(comparison, "BIC") %>% + dplyr::select_("formula") %>% + head(1) + best_bic <- as.character(best_bic[[1]]) + + by_criterion <- data.frame(formula = c(best_aic, best_bic), criterion = c("AIC", "BIC")) + + # Best formula + best <- table(by_criterion$formula) + best <- names(best[which.max(best)]) + + best <- list(formula = best, by_criterion = by_criterion, table = comparison) + return(best) +} + + + + + + + + +#' Returns the best model. +#' +#' Returns the best model. See the +#' documentation for your model's class: +#' \itemize{ +#' \item{\link[=find_best_model.stanreg]{find_best_model.stanreg}} +#' \item{\link[=find_best_model.lmerModLmerTest]{find_best_model.lmerModLmerTest}} +#' } +#' +#' @param fit Model +#' @param ... Arguments passed to or from other methods. +#' +#' @seealso \code{\link{find_best_model.stanreg}} +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +find_best_model <- function(fit, ...) { + UseMethod("find_best_model") +} + + + + + + + + + +#' Returns the best combination of predictors based on LOO cross-validation indices. +#' +#' Returns the best combination of predictors based on LOO cross-validation indices. +#' +#' @param fit A stanreg object. +#' @param interaction Include interaction term. +#' @param fixed Additional formula part to add at the beginning of +#' each formula +#' @param K For kfold, the number of subsets of equal (if possible) size into +#' which the data will be randomly partitioned for performing K-fold +#' cross-validation. The model is refit K times, each time leaving out one of +#' the K subsets. If K is equal to the total number of observations in the data +#' then K-fold cross-validation is equivalent to exact leave-one-out +#' cross-validation. +#' @param k_treshold Threshold for flagging estimates of the Pareto shape +#' parameters k estimated by loo. +#' @param ... Arguments passed to or from other methods. +#' +#' @return list containing all combinations. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(rstanarm) +#' +#' data <- standardize(attitude) +#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) +#' +#' best <- find_best_model(fit) +#' best_formula <- best$formula +#' best$table +#' +#' # To deactivate Kfold evaluation +#' best <- find_best_model(fit, K = 0) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom rstanarm bayes_R2 +#' @importFrom loo loo kfold +#' @importFrom stats update median +#' @import dplyr +#' +#' @method find_best_model stanreg +#' @export +find_best_model.stanreg <- function(fit, interaction = TRUE, fixed = NULL, K = 10, k_treshold = NULL, ...) { + + # Extract infos + combinations <- find_combinations(fit$formula, interaction = interaction, fixed = fixed) + + # Compute fitting indices + loos <- list() + kfolds <- list() + complexities <- list() + R2s <- list() + for (i in seq_len(length(combinations))) { + print(paste0(i, "/", length(combinations))) + + formula <- combinations[i] + newfit <- update(fit, formula = formula, verbose = FALSE) + R2s[[formula]] <- median(rstanarm::bayes_R2(newfit)) + + + if (!is.null(k_treshold)) { + loo <- loo::loo(newfit, k_treshold = k_treshold) + } else { + loo <- loo::loo(newfit) + } + + + complexities[[formula]] <- length(newfit$coefficients) + loos[[formula]] <- loo + if (K > 1) { + kfold <- loo::kfold(newfit, K = K) + } else { + kfold <- list(elpd_kfold = 0, se_elpd_kfold = 0) + } + kfolds[[formula]] <- kfold + } + + # Model comparison + comparison <- data.frame() + for (formula in names(loos)) { + loo <- loos[[formula]] + kfold <- kfolds[[formula]] + complexity <- complexities[[formula]] + Estimates <- loo[["estimates"]] + model <- data.frame( + formula = formula, + complexity = complexity - 1, + R2 = R2s[[formula]], + looic = Estimates["looic", "Estimate"], + looic_se = Estimates["looic", "SE"], + elpd_loo = Estimates["elpd_loo", "Estimate"], + elpd_loo_se = Estimates["elpd_loo", "SE"], + p_loo = Estimates["p_loo", "Estimate"], + p_loo_se = Estimates["p_loo", "SE"], + elpd_kfold = Estimates["p_loo", "Estimate"], + elpd_kfold_se = Estimates["p_loo", "SE"] + ) + comparison <- rbind(comparison, model) + } + + # Format + comparison <- comparison %>% + dplyr::mutate_( + "looic_d" = "looic - min(looic)", + "elpd_loo_d" = "elpd_loo - max(elpd_loo)", + "elpd_kfold_d" = "elpd_kfold - max(elpd_kfold)" + ) + + # Best model by criterion + best_looic <- dplyr::arrange_(comparison, "looic") %>% + dplyr::select_("formula") %>% + head(1) + best_looic <- as.character(best_looic[[1]]) + + best_elpd_loo <- dplyr::arrange_(comparison, "desc(elpd_loo)") %>% + dplyr::select_("formula") %>% + head(1) + best_elpd_loo <- as.character(best_elpd_loo[[1]]) + + if (K > 1) { + best_elpd_kfold <- dplyr::arrange_(comparison, "desc(elpd_kfold)") %>% + dplyr::select_("formula") %>% + head(1) + best_elpd_kfold <- as.character(best_elpd_kfold[[1]]) + } else { + best_elpd_kfold <- NA + } + + by_criterion <- data.frame(formula = c(best_looic, best_elpd_loo, best_elpd_kfold), criterion = c("looic", "elpd_loo", "elpd_kfold")) + + # Best formula + best <- table(by_criterion$formula) + best <- names(best[which.max(best)]) + + best <- list(formula = best, by_criterion = by_criterion, table = comparison) + return(best) +} + + + + + + + +#' Generate all combinations. +#' +#' Generate all combinations. +#' +#' @param object Object +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +find_combinations <- function(object, ...) { + UseMethod("find_combinations") +} + + + + + + + + + + + + + + +#' Generate all combinations of predictors of a formula. +#' +#' Generate all combinations of predictors of a formula. +#' +#' @param object Formula. +#' @param interaction Include interaction term. +#' @param fixed Additional formula part to add at the beginning of +#' each combination. +#' @param ... Arguments passed to or from other methods. +#' +#' @return list containing all combinations. +#' +#' @examples +#' library(psycho) +#' +#' f <- as.formula("Y ~ A + B + C + D") +#' f <- as.formula("Y ~ A + B + C + D + (1|E)") +#' f <- as.formula("Y ~ A + B + C + D + (1|E) + (1|F)") +#' +#' find_combinations(f) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @method find_combinations formula +#' @importFrom utils combn +#' @importFrom stats terms +#' @export +find_combinations.formula <- function(object, interaction = TRUE, fixed = NULL, ...) { + + # Extract infos + formula <- object + vars <- attributes(terms(formula))$term.labels + outcome <- all.vars(formula)[1] + pred <- vars[!grepl("\\|", vars)] + if (length(vars[grepl("\\|", vars)]) > 0) { + random <- paste0(" + (", vars[grepl("\\|", vars)], ")") + } else { + random <- "" + } + + if (is.null(fixed)) { + fixed <- "" + } else { + fixed <- fixed + } + + # Generate combinations + n <- length(pred) + + id <- unlist( + lapply( + 1:n, + function(i) combn(1:n, i, simplify = FALSE) + ), + recursive = FALSE + ) + + combinations <- sapply(id, function(i) + paste(paste(pred[i], collapse = " + "))) + + + # Generate interactions + if (interaction == TRUE) { + for (comb in combinations) { + n_signs <- stringr::str_count(comb, "\\+") + if (n_signs > 0) { + new_formula <- comb + for (i in 1:n_signs) { + new_formula <- stringr::str_replace(new_formula, "\\+", "*") + combinations <- c(combinations, new_formula) + } + } + } + } + + combinations <- paste0(outcome, " ~ ", fixed, combinations, paste0(random, collapse = "")) + return(combinations) +} + + + + + + + + +#' Find the distance of a point with its kmean cluster. +#' +#' Find the distance of a point with its kmean cluster. +#' +#' @param df Data +#' @param km kmean object. +#' +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +find_distance_cluster <- function(df, km) { + myDist <- function(p1, p2) sqrt((p1[, 1] - p2[, 1])^2 + (p1[, 2] - p2[, 2])^2) + + data <- df %>% + as.data.frame() %>% + select(one_of(colnames(km$centers))) + + n_clusters <- nrow(km$centers) + + data$Distance <- NA + for (clust in 1:n_clusters) { + data$Distance[km$cluster == clust] <- myDist(data[km$cluster == clust, ], km$centers[clust, , drop = FALSE]) + } + + return(data$Distance) +} + + + + + + + +#' Find the Highest Density Point. +#' +#' Returns the Highest Density Point. +#' +#' @param x Vector. +#' @param precision Number of points in density. +#' +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +find_highest_density_point <- function(x, precision = 1e+03) { + d <- x %>% + density(n = precision) %>% + as.data.frame() + y <- d$x[which.max(d$y)] + return(y) +} + + + + + + +#' Fuzzy string matching. +#' +#' @param x Strings. +#' @param y List of strings to be matched. +#' @param value Return value or the index of the closest string. +#' @param step Step by which decrease the distance. +#' @param ignore.case if FALSE, the pattern matching is case sensitive and if TRUE, case is ignored during matching. +#' +#' @examples +#' library(psycho) +#' find_matching_string("Hwo rea ouy", c("How are you", "Not this word", "Nice to meet you")) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +find_matching_string <- function(x, y, value = TRUE, step = 0.1, ignore.case = TRUE) { + z <- c() + for (i in seq_len(length(x))) { + s <- x[i] + distance <- 0.99 + closest <- agrep(s, y, max.distance = distance, value = value, ignore.case = ignore.case) + + while (length(closest) != 1) { + closest <- agrep(s, closest, max.distance = distance, value = value, ignore.case = ignore.case) + distance <- distance - step + if (distance < 0) { + warning(paste0("Couldn't find matching string for '", s, "'. Try lowering the step parameter.")) + closest <- s + } + } + z <- c(z, closest) + } + return(z) +} + + + + + + + + + + +#' Find random effects in formula. +#' +#' @param formula Formula + +#' @examples +#' library(psycho) +#' find_random_effects("Y ~ X + (1|Group)") +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stringr str_remove_all +#' @importFrom lme4 findbars +#' @export +find_random_effects <- function(formula) { + random <- lme4::findbars(as.formula(formula)) + random <- paste0("(", random, ")") + random <- stringr::str_remove_all(random, " ") + random <- paste(random, collapse = " + ") + return(random) +} + + + + + + +#' Find season of dates. +#' +#' Returns the season of an array of dates. +#' +#' @param dates Array of dates. +#' @param winter month-day of winter solstice. +#' @param spring month-day of spring equinox. +#' @param summer month-day of summer solstice. +#' @param fall month-day of fall equinox. +#' +#' @return season +#' +#' @examples +#' library(psycho) +#' +#' dates <- c("2012-02-15", "2017-05-15", "2009-08-15", "1912-11-15") +#' find_season(dates) +#' @author Josh O'Brien +#' +#' @seealso +#' https://stackoverflow.com/questions/9500114/find-which-season-a-particular-date-belongs-to +#' +#' @export +find_season <- function(dates, winter = "12-21", spring = "3-20", summer = "6-21", fall = "9-22") { + WS <- as.Date(paste0("2012-", winter), format = "%Y-%m-%d") # Winter Solstice + SE <- as.Date(paste0("2012-", spring), format = "%Y-%m-%d") # Spring Equinox + SS <- as.Date(paste0("2012-", summer), format = "%Y-%m-%d") # Summer Solstice + FE <- as.Date(paste0("2012-", fall), format = "%Y-%m-%d") # Fall Equinox + + # Convert dates from any year to 2012 dates + d <- as.Date(strftime(as.character(dates), format = "2012-%m-%d")) + + season <- ifelse(d >= WS | d < SE, "Winter", + ifelse(d >= SE & d < SS, "Spring", + ifelse(d >= SS & d < FE, "Summer", "Fall") + ) + ) + return(season) +} + + + + + + + + + + +#' Tidyverse-friendly sprintf. +#' +#' @param x Values. +#' @param fmt A character vector of format strings, each of up to 8192 bytes. +#' @param ... values to be passed into fmt. Only logical, integer, real and +#' character vectors are supported, but some coercion will be done: see the ‘Details’ section. Up to 100. +#' +#' @export +format_string <- function(x, fmt, ...) { + x <- sprintf(fmt, x, ...) + return(x) +} + + + + + + +#' Format p values. +#' +#' @param pvalues p values (scalar or vector). +#' @param stars Add significance stars. +#' @param stars_only Return only significance stars. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stringr str_remove_all +#' @export +format_p <- function(pvalues, stars = TRUE, stars_only=FALSE) { + p <- ifelse(pvalues < 0.001, "< .001***", + ifelse(pvalues < 0.01, "< .01**", + ifelse(pvalues < 0.05, "< .05*", + ifelse(pvalues < 0.1, paste0("= ", round(pvalues, 2), "\xB0"), + "> .1" + ) + ) + ) + ) + + if (stars_only == TRUE) { + p <- stringr::str_remove_all(p, "[^\\*]") + } else { + if (stars == FALSE) { + p <- stringr::str_remove_all(p, "\\*") + } + } + + return(p) +} + + + + + + + + +#' Clean and format formula. +#' +#' Clean and format formula. +#' +#' @param formula formula +#' @param ... Arguments passed to or from other methods. +#' +#' +#' @examples +#' library(psycho) +#' library(lme4) +#' +#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") +#' fit <- lm(hp ~ wt, data = mtcars) +#' +#' format_formula(get_formula(fit)) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +format_formula <- function(formula) { + formula <- tryCatch({ + stringr::str_squish(paste(format(eval(formula)), collapse = "")) + }, error = function(e) { + formula <- stringr::str_squish(paste(format(formula), collapse = "")) + }) + + return(formula) +} + + + + + + + + + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts between factor levels based on a fitted model. +#' See the documentation for your model's class: +#' \itemize{ +#' \item{\link[=get_contrasts.glm]{get_contrasts.glm}} +#' \item{\link[=get_contrasts.lmerModLmerTest]{get_contrasts.merModLmerTest}} +#' \item{\link[=get_contrasts.glmerMod]{get_contrasts.glmerMod}} +#' \item{\link[=get_contrasts.stanreg]{get_contrasts.stanreg}} +#' } +#' +#' +#' @param fit A model. +#' @param ... Arguments passed to or from other methods. +#' +#' @return Estimated contrasts. +#' +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' require(lmerTest) +#' require(rstanarm) +#' +#' fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) +#' get_contrasts(fit) +#' +#' fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) +#' get_contrasts(fit, adjust = "bonf") +#' +#' fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) +#' get_contrasts(fit, formula = "Birth_Season") +#' +#' fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) +#' get_contrasts(fit, formula = "Birth_Season", ROPE_bounds = c(-0.1, 0.1)) +#' } +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' +#' @export +get_contrasts <- function(fit, ...) { + UseMethod("get_contrasts") +} + + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts from models. +#' +#' @param fit A Bayesian model. +#' @param formula A character vector (formula like format, i.e., including +#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. +#' @param CI Determine the confidence or credible interval bounds. +#' @param ROPE_bounds Optional bounds of the ROPE for Bayesian models. +#' @param overlap Set to TRUE to add Overlap index (for Bayesian models). +#' @param ... Arguments passed to or from other methods. +#' @method get_contrasts stanreg +#' @export +get_contrasts.stanreg <- function(fit, formula = NULL, CI = 90, ROPE_bounds = NULL, overlap = FALSE, ...) { + .get_contrasts_bayes(fit, formula, CI, ROPE_bounds, overlap, ...) +} + + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts from models. +#' +#' @param fit A frequentist model. +#' @param formula A character vector (formula like format, i.e., including +#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. +#' @param CI Determine the confidence or credible interval bounds. +#' @param adjust P value adjustment method for frequentist models. Default is "tukey". Can be "holm", +#' "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none". +#' @param ... Arguments passed to or from other methods. +#' @method get_contrasts lm +#' @export +get_contrasts.lm <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { + .get_contrasts_freq(fit, formula, CI, adjust, ...) +} + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts from models. +#' +#' @inheritParams get_contrasts.lm +#' @method get_contrasts glm +#' @export +get_contrasts.glm <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { + .get_contrasts_freq(fit, formula, CI, adjust, ...) +} + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts from models. +#' +#' @inheritParams get_contrasts.lm +#' @method get_contrasts lmerModLmerTest +#' @export +get_contrasts.lmerModLmerTest <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { + .get_contrasts_freq(fit, formula, CI, adjust, ...) +} + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts from models. +#' +#' @inheritParams get_contrasts.lm +#' @method get_contrasts glmerMod +#' @export +get_contrasts.glmerMod <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { + .get_contrasts_freq(fit, formula, CI, adjust, ...) +} + +#' Compute estimated contrasts from models. +#' +#' Compute estimated contrasts from models. +#' +#' @inheritParams get_contrasts.lm +#' @method get_contrasts lmerMod +#' @export +get_contrasts.lmerMod <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { + .get_contrasts_freq(fit, formula, CI, adjust, ...) +} + + + + +#' @import dplyr +#' @importFrom emmeans emmeans +#' @importFrom graphics pairs +#' @importFrom stats confint mad +#' @keywords internal +.get_contrasts_bayes <- function(fit, formula = NULL, CI = 90, ROPE_bounds = NULL, overlap = FALSE, ...) { + if (is.null(formula)) { + formula <- paste(get_info(fit)$predictors, collapse = " * ") + } + + if (is.character(formula)) { + formula <- as.formula(paste0("~ ", formula)) + } + + # Contrasts --------------------------------------------------------------- + contrasts_posterior <- fit %>% + emmeans::emmeans(formula) %>% + graphics::pairs() %>% + emmeans::as.mcmc.emmGrid() %>% + as.matrix() %>% + as.data.frame() + + contrasts <- data.frame() + + + for (name in names(contrasts_posterior)) { + posterior <- contrasts_posterior[[name]] + + CI_values <- HDI(posterior, prob = CI / 100) + CI_values <- c(CI_values$values$HDImin, CI_values$values$HDImax) + + var <- data.frame( + Contrast = stringr::str_remove(name, "contrast "), + Median = median(posterior), + MAD = mad(posterior), + CI_lower = CI_values[seq(1, length(CI_values), 2)], + CI_higher = CI_values[seq(2, length(CI_values), 2)], + MPE = mpe(posterior)$MPE + ) + + if (overlap == TRUE) { + var$Overlap <- 100 * overlap( + posterior, + rnorm_perfect( + length(posterior), + 0, + sd(posterior) + ) + ) + } + + if (!is.null(ROPE_bounds)) { + var$ROPE <- rope(posterior, ROPE_bounds, CI = 95)$rope_probability + } + + contrasts <- rbind(contrasts, var) + } + + + return(contrasts) +} + + + + +#' @import dplyr +#' @importFrom emmeans emmeans +#' @importFrom graphics pairs +#' @importFrom stats confint +#' @keywords internal +.get_contrasts_freq <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { + if (is.null(formula)) { + formula <- paste(get_info(fit)$predictors, collapse = " * ") + } + + if (is.character(formula)) { + formula <- as.formula(paste0("~ ", formula)) + } + + # Contrasts --------------------------------------------------------------- + contrasts <- fit %>% + emmeans::emmeans(formula) %>% + graphics::pairs(adjust = adjust) + + # Confint + CI <- contrasts %>% + confint(CI / 100) %>% + select(contains("CL")) + + + contrasts <- contrasts %>% + as.data.frame() %>% + cbind(CI) %>% + dplyr::rename_( + "Contrast" = "contrast", + "Difference" = "estimate", + "p" = "p.value" + ) + names(contrasts) <- stringr::str_replace(names(contrasts), "lower.CL", "CI_lower") + names(contrasts) <- stringr::str_replace(names(contrasts), "upper.CL", "CI_higher") + names(contrasts) <- stringr::str_replace(names(contrasts), "asymp.LCL", "CI_lower") + names(contrasts) <- stringr::str_replace(names(contrasts), "asymp.UCL", "CI_higher") + names(contrasts) <- stringr::str_replace(names(contrasts), "t.ratio", "t") + names(contrasts) <- stringr::str_replace(names(contrasts), "z.ratio", "z") + + return(contrasts) +} + + + + + + + + +#' Extract the dataframe used in a model. +#' +#' Extract the dataframe used in a model. +#' +#' @param fit A model. +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(tidyverse) +#' library(psycho) +#' +#' df <- mtcars %>% +#' mutate( +#' cyl = as.factor(cyl), +#' gear = as.factor(gear) +#' ) +#' +#' fit <- lm(wt ~ mpg, data = df) +#' fit <- lm(wt ~ cyl, data = df) +#' fit <- lm(wt ~ mpg * cyl, data = df) +#' fit <- lm(wt ~ cyl * gear, data = df) +#' fit <- lmerTest::lmer(wt ~ mpg * gear + (1 | cyl), data = df) +#' fit <- rstanarm::stan_lmer(wt ~ mpg * gear + (1 | cyl), data = df) +#' +#' get_data(fit) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' @export +get_data <- function(fit, ...) { + UseMethod("get_data") +} + + +#' @importFrom stats getCall +#' @importFrom utils data +#' @export +get_data.lm <- function(fit, ...) { + tryCatch({ + data <- eval(getCall(fit)$data, environment(formula(fit))) + return(data) + }) + + info <- get_info(fit) + + outcome <- info$outcome + predictors <- info$predictors + + data <- as.data.frame(model.frame(fit)) + + + effects <- names(MuMIn::coeffs(fit)) + effects <- unique(unlist(stringr::str_split(effects, ":"))) + numerics <- predictors[predictors %in% effects] + + numerics <- numerics[!is.na(numerics)] + if (length(unique(model.response(model.frame(fit)))) > 2) { + numerics <- c(outcome, numerics) + } + + + data[!names(data) %in% numerics] <- lapply(data[!names(data) %in% numerics], as.factor) + data[names(data) %in% numerics] <- lapply(data[names(data) %in% numerics], as.numeric) + + return(as.data.frame(data)) +} + +#' @export +get_data.merMod <- get_data.lm + + + + + +#' @export +get_data.stanreg <- function(fit, ...) { + data <- fit$data + return(data) +} + + + + + + + + + + +#' Get formula of models. +#' +#' Get formula of models. Implemented for: +#' \itemize{ +#' \item{analyze.merModLmerTest} +#' \item{analyze.glmerMod} +#' \item{analyze.lm} +#' \item{analyze.glm} +#' \item{analyze.stanreg} +#' } +#' +#' @param x Object. +#' @param ... Arguments passed to or from other methods. +#' +#' +#' @examples +#' library(psycho) +#' library(lme4) +#' +#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") +#' fit <- lm(hp ~ wt, data = mtcars) +#' +#' get_formula(fit) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_formula <- function(x, ...) { + UseMethod("get_formula") +} + + +#' @export +get_formula.lmerModLmerTest <- function(x, ...) { + return(x@call$formula) +} +#' @export +get_formula.glmerMod <- get_formula.lmerModLmerTest +#' @export +get_formula.lmerMod <- get_formula.lmerModLmerTest + + +#' @export +get_formula.lm <- function(x, ...) { + return(stats::formula(x)) +} +#' @export +get_formula.glm <- get_formula.lm + + + +#' @export +get_formula.stanreg <- function(x, ...) { + return(x$formula) +} + + + + + + + + + + +#' Get graph data. +#' +#' To be used with tidygraph::tbl_graph. See the documentation for your object's class: +#' \itemize{ +#' \item{\link[=get_graph.lavaan]{get_graph.lavaan}} +#' \item{\link[=get_graph.fa]{get_graph.fa}} +#' \item{\link[=get_graph.psychobject_correlation]{get_graph.psychobject_correlation}} +#' } +#' +#' @param fit Object from which to extract the graph data. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_graph <- function(fit, ...) { + UseMethod("get_graph") +} + + + + + + + + + + + + + + + + + + +#' Get graph data from lavaan or blavaan objects. +#' +#' Get graph data from lavaan or blavaan objects. +#' +#' @param fit lavaan object. +#' @param links Which links to include? A list including at least one of "Regression", "Loading" or "Correlation". +#' @param standardize Use standardized coefs. +#' @param threshold_Coef Omit all links with a Coefs below this value. +#' @param threshold_p Omit all links with a p value above this value. +#' @param threshold_MPE In case of a blavaan model, omit all links with a MPE value below this value. +#' @param digits Edges' labels rounding. +#' @param CI CI level. +#' @param labels_CI Add the CI in the edge label. +#' @param ... Arguments passed to or from other methods. +#' +#' @return A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. +#' +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' +#' @export +get_graph.lavaan <- function(fit, links = c("Regression", "Correlation", "Loading"), standardize = FALSE, threshold_Coef = NULL, threshold_p = NULL, threshold_MPE = NULL, digits = 2, CI = "default", labels_CI = TRUE, ...) { + # https://www.r-bloggers.com/ggplot2-sem-models-with-tidygraph-and-ggraph/ + + + if (labels_CI == TRUE) { + if (CI != "default") { + results <- analyze(fit, CI = CI, standardize = standardize) + } else { + results <- analyze(fit, standardize = standardize) + } + } else { + results <- analyze(fit, standardize = standardize) + } + + summary <- summary(results) + CI <- results$values$CI + + # Check what type of model + if (class(fit) %in% c("blavaan")) { + summary$Coef <- summary$Median + if (is.null(threshold_MPE)) { + threshold_MPE <- -1 + } + summary <- summary %>% + filter_("MPE >= threshold_MPE") + } else if (class(fit) %in% c("lavaan")) { + if (is.null(threshold_p)) { + threshold_p <- 1.1 + } + summary <- summary %>% + filter_("p <= threshold_p") + } else { + stop(paste("Error in UseMethod('plot_lavaan') : no applicable method for 'plot_lavaan' applied to an object of class", class(fit))) + } + + # Deal with thresholds + if (is.null(threshold_Coef)) { + threshold_Coef <- min(abs(summary$Coef)) - 1 + } + + # Edge properties + edges <- summary %>% + mutate_("abs_coef" = "abs(Coef)") %>% + filter_( + "Type %in% c(links)", + "From != To", + "abs_coef >= threshold_Coef" + ) %>% + select(-one_of("abs_coef")) %>% + rename_( + "to" = "To", + "from" = "From" + ) + + # Labels + if (labels_CI == TRUE) { + edges <- edges %>% + mutate_("Label" = 'paste0(format_digit(Coef, digits), + ", ", CI, "% CI [", format_digit(CI_lower, digits), + ", ", format_digit(CI_higher, digits), "]")') + } else { + edges <- edges %>% + mutate_("Label" = "format_digit(Coef, digits)") + } + edges <- edges %>% + mutate_( + "Label_Regression" = "ifelse(Type=='Regression', Label, '')", + "Label_Correlation" = "ifelse(Type=='Correlation', Label, '')", + "Label_Loading" = "ifelse(Type=='Loading', Label, '')" + ) + edges <- edges[colSums(!is.na(edges)) > 0] + + # Identify latent variables for nodes + latent_nodes <- edges %>% + filter_('Type == "Loading"') %>% + distinct_("to") %>% + transmute_("Name" = "to", "Latent" = TRUE) + + nodes_list <- unique(c(edges$from, edges$to)) + + # Node properties + nodes <- summary %>% + filter_( + "From == To", + "From %in% nodes_list" + ) %>% + mutate_("Name" = "From") %>% + left_join(latent_nodes, by = "Name") %>% + mutate_("Latent" = "if_else(is.na(Latent), FALSE, Latent)") %>% + select(one_of(c("Name", "Latent"))) + + return(list(nodes = nodes, edges = edges)) +} + + + + + +#' Get graph data from factor analysis. +#' +#' Get graph data from fa objects. +#' +#' @param fit psych::fa object. +#' @param threshold_Coef Omit all links with a Coefs below this value. +#' @param digits Edges' labels rounding. +#' @param ... Arguments passed to or from other methods. +#' +#' @return A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. +#' +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' +#' @export +get_graph.fa <- function(fit, threshold_Coef = NULL, digits = 2, ...) { + edges <- summary(analyze(fit)) %>% + gather("To", "Coef", -one_of("N", "Item", "Label")) %>% + rename_("From" = "Item") %>% + mutate_("Label" = "format_digit(Coef, digits)") %>% + select(one_of("From", "To", "Coef", "Label"), everything()) %>% + filter() + + # Deal with thresholds + if (is.null(threshold_Coef)) { + threshold_Coef <- min(abs(edges$Coef)) - 1 + } + + edges <- edges %>% + filter_("Coef > threshold_Coef") + + nodes <- data.frame("Name" = c(edges$From, edges$To)) %>% + distinct_("Name") + + return(list(nodes = nodes, edges = edges)) +} + + + + +#' Get graph data from correlation. +#' +#' Get graph data from correlation. +#' +#' @param fit Object from psycho::correlation. +#' @param ... Arguments passed to or from other methods. +#' +#' @return A list containing nodes and edges data to be used by `igraph::graph_from_data_frame()`. +#' +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' +#' @export +get_graph.psychobject_correlation <- function(fit, ...) { + vars <- row.names(fit$values$r) + + r <- fit$values$r %>% + as.data.frame() %>% + tibble::rownames_to_column("from") %>% + tidyr::gather("to", "r", vars) + + if ("p" %in% names(fit$values)) { + r <- r %>% + full_join( + fit$values$p %>% + as.data.frame() %>% + tibble::rownames_to_column("from") %>% + tidyr::gather("to", "p", vars), + by = c("from", "to") + ) + } + + r <- filter_(r, "!from == to") + return(r) +} + + + + + + + + + + + + + +#' Get information about objects. +#' +#' Get information about models. +#' +#' +#' @param x object. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(lme4) +#' +#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") +#' +#' info <- get_info(fit) +#' info +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_info <- function(x, ...) { + UseMethod("get_info") +} + + + + + + + + + + +#' Get information about models. +#' +#' Get information about models. +#' +#' @param x object. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(lme4) +#' +#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") +#' +#' info <- get_info(fit) +#' info +#' +#' # +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_info.lmerModLmerTest <- function(x, ...) { + fit <- x + + info <- tryCatch({ + + # Get formula + formula <- get_formula(fit) + # Get variables + predictors <- all.vars(formula) + outcome <- predictors[[1]] + predictors <- tail(predictors, -1) + random <- names(lme4::ranef(fit))[names(lme4::ranef(fit)) %in% predictors] + predictors <- predictors[!predictors %in% random] + + return(list( + formula = formula, + predictors = predictors, + outcome = outcome, + random = random + )) + }, error = function(e) { + + # Get formula + formula <- get_formula(fit) + # Get variables + predictors <- NA + outcome <- "Y" + random <- NA + + return(list( + formula = formula, + predictors = predictors, + outcome = outcome, + random = random + )) + }) + + return(info) +} +#' @export +get_info.glmerMod <- get_info.lmerModLmerTest +#' @export +get_info.lmerMod <- get_info.lmerModLmerTest + + + +#' Get information about models. +#' +#' Get information about models. +#' +#' @param x object. +#' @param ... Arguments passed to or from other methods. +#' +#' @return output +#' +#' @examples +#' library(psycho) +#' library(lme4) +#' +#' fit <- lm(vs ~ wt, data = mtcars, family = "binomial") +#' +#' info <- get_info(fit) +#' info +#' +#' # +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_info.lm <- function(x, ...) { + fit <- x + + info <- tryCatch({ + + # Get formula + formula <- get_formula(fit) + # Get variables + predictors <- all.vars(formula) + outcome <- predictors[[1]] + predictors <- tail(predictors, -1) + + return(list( + formula = formula, + predictors = predictors, + outcome = outcome + )) + }, error = function(e) { + + # Get formula + formula <- get_formula(fit) + # Get variables + predictors <- NA + outcome <- "Y" + random <- NA + + return(list( + formula = formula, + predictors = predictors, + outcome = outcome + )) + }) + + return(info) +} + +#' @export +get_info.stanreg <- get_info.lm +#' @export +get_info.lm <- get_info.lm +#' @export +get_info.glm <- get_info.lm + + + + + + + + + + + + +#' Compute estimated means from models. +#' +#' Compute estimated means of factor levels based on a fitted model. +#' +#' @param fit A model (lm, lme4 or rstanarm). +#' @param formula A character vector (formula like format, i.e., including +#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. +#' @param CI Determine the confidence or credible interval bounds. +#' @param ... Arguments passed to or from other methods. For instance, transform="response". +#' +#' +#' @return Estimated means (or median of means for Bayesian models) +#' +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' require(lmerTest) +#' require(rstanarm) +#' +#' +#' fit <- glm(Sex ~ Birth_Season, data = affective, family = "binomial") +#' get_means(fit) +#' +#' fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) +#' get_means(fit, formula = "Birth_Season") +#' +#' fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) +#' get_means(fit, formula = "Birth_Season") +#' } +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_means <- function(fit, formula = NULL, CI = 90, ...) { + UseMethod("get_means") +} + + +#' @method get_means stanreg +#' @export +get_means.stanreg <- function(fit, formula = NULL, CI = 90, ...) { + .get_means_bayes(fit, formula, CI, ...) +} + +#' @method get_means lm +#' @export +get_means.lm <- function(fit, formula = NULL, CI = 95, ...) { + .get_means_freq(fit, formula, CI, ...) +} + +#' @method get_means glm +#' @export +get_means.glm <- function(fit, formula = NULL, CI = 95, ...) { + .get_means_freq(fit, formula, CI, ...) +} + +#' @method get_means lmerModLmerTest +#' @export +get_means.lmerModLmerTest <- function(fit, formula = NULL, CI = 95, ...) { + .get_means_freq(fit, formula, CI, ...) +} + +#' @method get_means glmerMod +#' @export +get_means.glmerMod <- function(fit, formula = NULL, CI = 95, ...) { + .get_means_freq(fit, formula, CI, ...) +} + +#' @method get_means lmerMod +#' @export +get_means.lmerMod <- function(fit, formula = NULL, CI = 95, ...) { + .get_means_freq(fit, formula, CI, ...) +} + + + + +#' @import dplyr +#' @importFrom emmeans emmeans +#' @importFrom stats confint mad +#' @keywords internal +.get_means_bayes <- function(fit, formula = NULL, CI = 90, ...) { + if (is.null(formula)) { + formula <- paste(get_info(fit)$predictors, collapse = " * ") + } + + if (is.character(formula)) { + formula <- as.formula(paste0("~ ", formula)) + } + + # Means --------------------------------------------------------------- + means_posterior <- fit %>% + emmeans::emmeans(formula) %>% + emmeans::as.mcmc.emmGrid() %>% + as.matrix() %>% + as.data.frame() + + means <- data.frame() + + for (name in names(means_posterior)) { + var <- means_posterior[[name]] + + CI_values <- HDI(var, prob = CI / 100) + CI_values <- c(CI_values$values$HDImin, CI_values$values$HDImax) + + var <- data.frame( + Level = name, + Median = median(var), + MAD = mad(var), + CI_lower = CI_values[seq(1, length(CI_values), 2)], + CI_higher = CI_values[seq(2, length(CI_values), 2)] + ) + + means <- rbind(means, var) + } + + return(means) +} + + + + +#' @import dplyr +#' @importFrom emmeans emmeans +#' @importFrom stats confint +#' @keywords internal +.get_means_freq <- function(fit, formula = NULL, CI = 95, ...) { + if (is.null(formula)) { + formula <- paste(get_info(fit)$predictors, collapse = " * ") + } + + if (is.character(formula)) { + formula <- as.formula(paste0("~ ", formula)) + } + + # Means --------------------------------------------------------------- + means <- fit %>% + emmeans::emmeans(formula, ...) %>% + confint(CI / 100) %>% + as.data.frame() + + names(means) <- stringr::str_replace(names(means), "emmean", "Mean") + names(means) <- stringr::str_replace(names(means), "lower.CL", "CI_lower") + names(means) <- stringr::str_replace(names(means), "upper.CL", "CI_higher") + names(means) <- stringr::str_replace(names(means), "asymp.LCL", "CI_lower") + names(means) <- stringr::str_replace(names(means), "asymp.UCL", "CI_higher") + + return(means) +} + + + + + + + + + +#' Compute predicted values of lm models. +#' +#' Compute predicted from a lm model. +#' +#' @param fit An lm model. +#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. +#' @param prob Probability of confidence intervals (0.9 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). +#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. +#' @param ... Arguments passed to or from other methods. +#' +#' +#' @return dataframe with predicted values. +#' +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(ggplot2) +#' +#' fit <- glm(Sex ~ Adjusting, data = affective, family = "binomial") +#' +#' refgrid <- psycho::refdata(affective, "Adjusting") +#' predicted <- get_predicted(fit, newdata = refgrid) +#' +#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + +#' geom_line() + +#' geom_ribbon(aes( +#' ymin = Sex_CI_2.5, +#' ymax = Sex_CI_97.5 +#' ), +#' alpha = 0.1 +#' ) +#' } +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom dplyr bind_cols +#' @importFrom tibble rownames_to_column +#' @export +get_predicted.glm <- function(fit, newdata = "model", prob = 0.95, odds_to_probs = TRUE, ...) { + + + # Extract names + info <- get_info(fit) + outcome <- info$outcome + predictors <- info$predictors + + # Set newdata if refgrid + if ("emmGrid" %in% class(newdata)) { + newdata <- newdata@grid + newdata[".wgt."] <- NULL + } + + # Set newdata to actual data + original_data <- FALSE + if (!is.null(newdata)) { + if (is.character(newdata)) { + if (newdata == "model") { + original_data <- TRUE + newdata <- fit$data[predictors] + newdata <- na.omit(fit$data[predictors]) + } + } + } + + + # Compute ---------------------------------------------------------- + + # Predicted Y + prediction <- as.data.frame(predict(fit, newdata = newdata, type = "link", se.fit = TRUE)) + SE <- as.data.frame(prediction$se.fit) + pred_y <- as.data.frame(prediction$fit) + names(pred_y) <- paste0(outcome, "_Predicted") + + # Credible Interval + for (CI in c(prob)) { + pred_y_interval <- data.frame( + lwr = prediction$fit - (qnorm(CI) * SE), + upr = prediction$fit + (qnorm(CI) * SE) + ) + names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") + pred_y <- cbind(pred_y, pred_y_interval) + } + + + # Transform odds to probs ---------------------------------------------------------- + + if (family(fit)$family == "binomial" & family(fit)$link == "logit") { + if (odds_to_probs == TRUE) { + pred_y <- odds_to_probs(pred_y) + } + } + + + # Add predictors ---------------------------------------------------------- + + + if (!is.null(newdata)) { + if (original_data) { + predicted <- newdata %>% + tibble::rownames_to_column() %>% + dplyr::bind_cols(pred_y) %>% + dplyr::right_join(fit$data[!names(fit$data) %in% predictors] %>% + tibble::rownames_to_column(), + by = "rowname" + ) %>% + select_("-rowname") + } else { + predicted <- dplyr::bind_cols(newdata, pred_y) + } + } else { + predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) + } + + + return(predicted) +} + + + + + + + + + +#' Compute predicted values of lm models. +#' +#' Compute predicted from a lm model. +#' +#' @param fit An lm model. +#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. +#' @param prob Probability of confidence intervals (0.95 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). +#' @param ... Arguments passed to or from other methods. +#' +#' +#' @return dataframe with predicted values. +#' +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(ggplot2) +#' +#' fit <- lm(Tolerating ~ Adjusting, data = affective) +#' +#' refgrid <- psycho::refdata(affective, "Adjusting") +#' predicted <- get_predicted(fit, newdata = refgrid) +#' +#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + +#' geom_line() + +#' geom_ribbon(aes( +#' ymin = Tolerating_CI_2.5, +#' ymax = Tolerating_CI_97.5 +#' ), +#' alpha = 0.1 +#' ) +#' } +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom dplyr bind_cols +#' @importFrom tibble rownames_to_column +#' @export +get_predicted.lm <- function(fit, newdata = "model", prob = 0.95, ...) { + + + # Extract names + info <- get_info(fit) + outcome <- info$outcome + predictors <- info$predictors + + # Set newdata if refgrid + if ("emmGrid" %in% class(newdata)) { + newdata <- newdata@grid + newdata[".wgt."] <- NULL + } + + # Set newdata to actual data + original_data <- FALSE + if (!is.null(newdata)) { + if (is.character(newdata)) { + if (newdata == "model") { + original_data <- TRUE + newdata <- as.data.frame(fit$model[predictors]) + newdata <- na.omit(fit$model[predictors]) + } + } + } + + + # Compute ---------------------------------------------------------- + + # Predicted Y + pred_y <- as.data.frame(predict(fit, newdata)) + names(pred_y) <- paste0(outcome, "_Predicted") + + # Credible Interval + for (CI in c(prob)) { + pred_y_interval <- as.data.frame(predict(fit, newdata, interval = "confidence", level = CI)[, -1]) + names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") + pred_y <- cbind(pred_y, pred_y_interval) + } + + + + # Add predictors ---------------------------------------------------------- + if (!is.null(newdata)) { + if (original_data) { + predicted <- newdata %>% + tibble::rownames_to_column() %>% + dplyr::bind_cols(pred_y) %>% + dplyr::right_join(fit$model[!names(fit$model) %in% predictors] %>% + tibble::rownames_to_column(), + by = "rowname" + ) %>% + select_("-rowname") + } else { + predicted <- dplyr::bind_cols(newdata, pred_y) + } + } else { + predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) + } + + + return(predicted) +} + + + + + + + + + +#' Compute predicted values of lm models. +#' +#' Compute predicted from a lm model. +#' +#' @param fit An lm model. +#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. +#' @param prob Probability of confidence intervals (0.95 will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). Default to NULL as it takes a very long time to compute (see \link[lme4]{bootMer}). +#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. +#' @param iter An integer indicating the number of iterations for bootstrapping (when prob is not null). +#' @param seed An optional seed to use. +#' @param re.form Formula for random effects to condition on. If NULL, include all random effects; if NA or ~0, include no random effects (see \link[lme4]{predict.merMod}). If "default", then will ne NULL if the random are present in the data, and NA if not. +#' @param use.u logical, indicating whether the spherical random effects should be simulated / bootstrapped as well. If TRUE, they are not changed, and all inference is conditional on these values. If FALSE, new normal deviates are drawn (see\link[lme4]{bootMer}). +#' @param ... Arguments passed to or from other methods. +#' +#' +#' @return dataframe with predicted values. +#' +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(ggplot2) +#' +#' fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) +#' +#' refgrid <- psycho::refdata(affective, "Adjusting") +#' predicted <- get_predicted(fit, newdata = refgrid) +#' +#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + +#' geom_line() +#' +#' predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time +#' +#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + +#' geom_line() + +#' geom_ribbon(aes( +#' ymin = Tolerating_CI_2.5, +#' ymax = Tolerating_CI_97.5 +#' ), +#' alpha = 0.1 +#' ) +#' +#' +#' +#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = affective, family = "binomial") +#' +#' refgrid <- psycho::refdata(affective, "Adjusting") +#' predicted <- get_predicted(fit, newdata = refgrid) +#' +#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + +#' geom_line() +#' +#' predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time +#' +#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + +#' geom_line() + +#' geom_ribbon(aes( +#' ymin = Sex_CI_2.5, +#' ymax = Sex_CI_97.5 +#' ), +#' alpha = 0.1 +#' ) +#' } +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom dplyr bind_cols +#' @importFrom tibble rownames_to_column +#' @export +get_predicted.merMod <- function(fit, newdata = "model", prob = NULL, odds_to_probs = TRUE, iter = 100, seed = NULL, re.form = "default", use.u = FALSE, ...) { + + + # Extract names + info <- get_info(fit) + outcome <- info$outcome + predictors <- info$predictors + + # Set newdata if refgrid + if ("emmGrid" %in% class(newdata)) { + newdata <- newdata@grid + newdata[".wgt."] <- NULL + } + + # Set newdata to actual data + original_data <- FALSE + if (!is.null(newdata)) { + if (is.character(newdata)) { + if (newdata == "model") { + original_data <- TRUE + newdata <- na.omit(fit@frame) + } + } + } + + + # Deal with random + if (!is.na(re.form)) { + if (re.form == "default") { + # Check if all predictors are in variables + if (all(get_info(fit)$predictors %in% names(newdata))) { + re.form <- NULL + } else { + re.form <- NA + } + } + } + + + + # Compute ---------------------------------------------------------- + + pred_y <- as.data.frame(predict(fit, newdata = newdata, re.form = re.form)) + names(pred_y) <- paste0(outcome, "_Predicted") + + if (!is.null(prob)) { + predFun <- function(fit) { + predict(fit, newdata, newdata = newdata, re.form = re.form) + } + predMat <- lme4::bootMer(fit, nsim = iter, FUN = predFun, use.u = use.u, seed = seed)$t + + for (CI in c(prob)) { + pred_y_interval <- as.data.frame(t(apply(predMat, 2, quantile, c((1 - CI) / 2, CI + (1 - CI) / 2), na.rm = TRUE))) + names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") + pred_y <- cbind(pred_y, pred_y_interval) + } + } + + + # Transform odds to probs ---------------------------------------------------------- + + if (family(fit)$family == "binomial" & family(fit)$link == "logit") { + if (odds_to_probs == TRUE) { + pred_y <- odds_to_probs(pred_y) + } + } + + + # Add predictors ---------------------------------------------------------- + + + if (!is.null(newdata)) { + if (original_data) { + predicted <- newdata %>% + tibble::rownames_to_column() %>% + dplyr::bind_cols(pred_y) %>% + dplyr::right_join(fit@frame[!names(fit@frame) %in% names(newdata)] %>% + tibble::rownames_to_column(), + by = "rowname" + ) %>% + select_("-rowname") + } else { + predicted <- dplyr::bind_cols(newdata, pred_y) + } + } else { + predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) + } + + + return(predicted) +} + + + + + + +#' Compute predicted values from models. +#' +#' Compute predicted values from models. See the +#' documentation for your model's class: +#' \itemize{ +#' \item{\link[=get_predicted.stanreg]{get_predicted.stanreg}} +#' \item{\link[=get_predicted.merMod]{get_predicted.merMod}} +#' \item{\link[=get_predicted.lm]{get_predicted.lm}} +#' \item{\link[=get_predicted.glm]{get_predicted.glm}} +#' } +#' +#' @param fit Model. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_predicted <- function(fit, ...) { + UseMethod("get_predicted") +} + + + + + + + + +#' Compute predicted values of stanreg models. +#' +#' Compute predicted from a stanreg model. +#' +#' @param fit A stanreg model. +#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. +#' @param prob Probability of credible intervals (0.9 (default) will compute 5-95\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). +#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. +#' @param keep_iterations Keep all prediction iterations. +#' @param draws An integer indicating the number of draws to return. The default and maximum number of draws is the size of the posterior sample. +#' @param posterior_predict Posterior draws of the outcome instead of the link function (i.e., the regression "line"). +#' @param seed An optional seed to use. +#' @param transform If posterior_predict is False, should the linear predictor be transformed using the inverse-link function? The default is FALSE, in which case the untransformed linear predictor is returned. +#' @param re.form If object contains group-level parameters, a formula indicating which group-level parameters to condition on when making predictions. re.form is specified in the same form as for predict.merMod. NULL indicates that all estimated group-level parameters are conditioned on. To refrain from conditioning on any group-level parameters, specify NA or ~0. The newdata argument may include new levels of the grouping factors that were specified when the model was estimated, in which case the resulting posterior predictions marginalize over the relevant variables (see \link[rstanarm]{posterior_predict.stanreg}). If "default", then will ne NULL if the random are present in the data, and NA if not. +#' @param ... Arguments passed to or from other methods. +#' +#' +#' @return dataframe with predicted values. +#' +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(ggplot2) +#' require(rstanarm) +#' +#' fit <- rstanarm::stan_glm(Tolerating ~ Adjusting, data = affective) +#' +#' refgrid <- psycho::refdata(affective, "Adjusting") +#' predicted <- get_predicted(fit, newdata = refgrid) +#' +#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Median)) + +#' geom_line() + +#' geom_ribbon(aes( +#' ymin = Tolerating_CI_5, +#' ymax = Tolerating_CI_95 +#' ), +#' alpha = 0.1 +#' ) +#' +#' fit <- rstanarm::stan_glm(Sex ~ Adjusting, data = affective, family = "binomial") +#' +#' refgrid <- psycho::refdata(affective, "Adjusting") +#' predicted <- get_predicted(fit, newdata = refgrid) +#' +#' ggplot(predicted, aes(x = Adjusting, y = Sex_Median)) + +#' geom_line() + +#' geom_ribbon(aes( +#' ymin = Sex_CI_5, +#' ymax = Sex_CI_95 +#' ), +#' alpha = 0.1 +#' ) +#' } +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats median family model.matrix +#' @importFrom dplyr bind_cols +#' @importFrom tibble rownames_to_column +#' @export +get_predicted.stanreg <- function(fit, newdata = "model", prob = 0.9, odds_to_probs = TRUE, keep_iterations = FALSE, draws = NULL, posterior_predict = FALSE, seed = NULL, transform = FALSE, re.form = "default", ...) { + + # Extract names + predictors <- all.vars(as.formula(fit$formula)) + outcome <- predictors[[1]] + predictors <- tail(predictors, -1) + + # Set newdata if refgrid + if ("emmGrid" %in% class(newdata)) { + newdata <- newdata@grid + newdata[".wgt."] <- NULL + } + + # Set newdata to actual data + original_data <- FALSE + if (!is.null(newdata)) { + if (is.character(newdata)) { + if (newdata == "model") { + original_data <- TRUE + newdata <- fit$data[predictors] + newdata <- na.omit(fit$data[predictors]) + } + } + } + + # Deal with potential random + if (!is.na(re.form)) { + if (re.form == "default") { + if (is.mixed(fit)) { + # Check if all predictors are in variables + if (all(get_info(fit)$predictors %in% names(newdata))) { + re.form <- NULL + } else { + re.form <- NA + } + } + } + } + + # Generate draws ------------------------------------------------------- + if (posterior_predict == FALSE) { + posterior <- rstanarm::posterior_linpred(fit, newdata = newdata, re.form = re.form, seed = seed, draws = draws, transform = transform) + } else { + posterior <- rstanarm::posterior_predict(fit, newdata = newdata, re.form = re.form, seed = seed, draws = draws) + } + + # Format ------------------------------------------------------- + + # Predicted Y + pred_y <- as.data.frame(apply(posterior, 2, median)) + names(pred_y) <- paste0(outcome, "_Median") + + # Credible Interval + for (CI in c(prob)) { + pred_y_interval <- HDI(posterior, prob = CI) + names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") + pred_y <- cbind(pred_y, pred_y_interval) + } + + + # Keep iterations --------------------------------------------------------- + + if (keep_iterations == TRUE) { + iterations <- as.data.frame(t(posterior)) + names(iterations) <- paste0("iter_", seq_len(length(names(iterations)))) + pred_y <- cbind(pred_y, iterations) + } + + # Transform odds to probs ---------------------------------------------------------- + + if (family(fit)$family == "binomial" & family(fit)$link == "logit") { + if (odds_to_probs == TRUE) { + pred_y <- odds_to_probs(pred_y) + } + } + + + # Add predictors ---------------------------------------------------------- + + + if (!is.null(newdata)) { + if (original_data) { + predicted <- newdata %>% + tibble::rownames_to_column() %>% + dplyr::bind_cols(pred_y) %>% + dplyr::right_join(fit$data[!names(fit$data) %in% predictors] %>% + tibble::rownames_to_column(), + by = "rowname" + ) %>% + select_("-rowname") + } else { + predicted <- dplyr::bind_cols(newdata, pred_y) + } + } else { + predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) + } + + + return(predicted) +} + + + + + + + + +#' Get Indices of Explanatory Power. +#' +#' See the documentation for your object's class: +#' \itemize{ +#' \item{\link[=get_R2.lm]{get_R2.lm}} +#' \item{\link[=get_R2.glm]{get_R2.glm}} +#' \item{\link[=get_R2.stanreg]{get_R2.stanreg}} +#' } +#' +#' @param fit Object. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_R2 <- function(fit, ...) { + UseMethod("get_R2") +} + + +#' R2 and adjusted R2 for Linear Models. +#' +#' R2 and adjusted R2 for Linear Models. +#' +#' @param fit A linear model. +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) +#' +#' get_R2(fit) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' @export +get_R2.lm <- function(fit, ...) { + R2 <- summary(fit)$r.squared + R2.adj <- summary(fit)$adj.r.squared + + out <- list(R2 = R2, R2.adj = R2.adj) + return(out) +} + + + +#' Pseudo-R-squared for Logistic Models. +#' +#' Pseudo-R-squared for Logistic Models. +#' +#' @param fit A logistic model. +#' @param method Can be \link[=R2_nakagawa]{"nakagawa"} or \link[=R2_tjur]{"tjur"}. +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' fit <- glm(vs ~ wt, data = mtcars, family = "binomial") +#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") +#' +#' get_R2(fit) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +get_R2.glm <- function(fit, method = "nakagawa", ...) { + if (method == "nakagawa") { + R2 <- as.numeric(R2_nakagawa(fit)$R2m) + } else if (method == "tjur") { + R2 <- R2_tjur(fit) + } else { + stop("Method must be 'nakagawa' or 'tjur'.") + } + return(R2) +} + + + + +#' R2 or Bayesian Models. +#' +#' Computes R2 and \link[=R2_LOO_Adjusted]{LOO-adjusted R2}. +#' +#' @param fit A stanreg model. +#' @param silent If R2 not available, throw warning. +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(rstanarm) +#' +#' fit <- rstanarm::stan_glm(Adjusting ~ Tolerating, data = psycho::affective) +#' +#' get_R2(fit) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso \link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} +#' +#' @export +get_R2.stanreg <- function(fit, silent = FALSE, ...) { + tryCatch({ + R2 <- rstanarm::bayes_R2(fit) + }, error = function(e) { + R2 <- "NA" + }) + + if (!is.numeric(R2)) { + if (silent) { + return(R2) + } else { + stop("Couldn't compute R2 for this model.") + } + } + + out <- list( + R2_median = median(R2), + R2_MAD = mad(R2), + R2_posterior = R2 + ) + + if (fit$family$family == "gaussian") { + out$R2.adj <- R2_LOO_Adjusted(fit) + } else { + out$R2.adj <- NA + } + + return(out) +} + + + +#' R2 and adjusted R2 for GLMMs. +#' +#' R2 and adjusted R2 for GLMMs. +#' +#' @param fit A GLMM. +#' @param ... Arguments passed to or from other methods. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), +#' data = psycho::affective +#' ) +#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), +#' data = na.omit(psycho::affective), family = "binomial" +#' ) +#' +#' get_R2(fit) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' @export +get_R2.merMod <- function(fit, ...) { + out <- suppressMessages(R2_nakagawa(fit)) + return(out) +} + + + + + +#' Pseudo-R-squared for Generalized Mixed-Effect models. +#' +#' For mixed-effects models, R² can be categorized into two types. Marginal R_GLMM² represents the variance explained by fixed factors, and Conditional R_GLMM² is interpreted as variance explained by both fixed and random factors (i.e. the entire model). IMPORTANT: Looking for help to reimplement this method. +#' +#' @param fit A mixed model. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' +#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) +#' +#' R2_nakagawa(fit) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @references +#' Nakagawa, S., Johnson, P. C., & Schielzeth, H. (2017). The coefficient of determination R2 and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. Journal of the Royal Society Interface, 14(134), 20170213. +#' Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. +#' +#' @export +R2_nakagawa <- function(fit) { + out <- MuMIn::r.squaredGLMM(fit) + out <- list( + R2m = as.numeric(out[1]), + R2c = as.numeric(out[2]) + ) + return(out) +} + + + +#' Compute LOO-adjusted R2. +#' +#' Compute LOO-adjusted R2. +#' +#' @param fit A stanreg model. +#' +#' @examples +#' \dontrun{ +#' library(psycho) +#' library(rstanarm) +#' +#' data <- attitude +#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) +#' +#' R2_LOO_Adjusted(fit) +#' } +#' +#' @author \href{https://github.com/strengejacke}{Daniel Luedecke} +#' +#' @import rstantools +#' +#' @export +R2_LOO_Adjusted <- function(fit) { + predictors <- all.vars(as.formula(fit$formula)) + y <- fit$data[[predictors[[1]]]] + ypred <- rstantools::posterior_linpred(fit) + ll <- rstantools::log_lik(fit) + + nsamples <- 0 + nchains <- length(fit$stanfit@stan_args) + for (chain in fit$stanfit@stan_args) { + nsamples <- nsamples + (chain$iter - chain$warmup) + } + + + r_eff <- loo::relative_eff(exp(ll), + chain_id = rep(1:nchains, each = nsamples / nchains) + ) + + psis_object <- loo::psis(log_ratios = -ll, r_eff = r_eff) + ypredloo <- loo::E_loo(ypred, psis_object, log_ratios = -ll)$value + if (length(ypredloo) != length(y)) { + warning("Something went wrong in the Loo-adjusted R2 computation.") + return(NA) + } + eloo <- ypredloo - y + + adj_r_squared <- 1 - stats::var(eloo) / stats::var(y) + return(adj_r_squared) +} + + + + +#' Tjur's (2009) coefficient of determination. +#' +#' Computes Tjur's (2009) coefficient of determination. +#' +#' @param fit Logistic Model. +#' +#' @examples +#' library(psycho) +#' library(lme4) +#' +#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") +#' R2_tjur(fit) +#' @author \href{https://github.com/strengejacke}{Daniel Lüdecke} +#' +#' @import dplyr +#' @importFrom stats predict residuals +#' @importFrom lme4 getME +#' +#' @references Tjur, T. (2009). Coefficients of determination in logistic regression models—A new proposal: The coefficient of discrimination. The American Statistician, 63(4), 366-372. +#' +#' @export +R2_tjur <- function(fit) { + # check for valid object class + if (!inherits(fit, c("glmerMod", "glm"))) { + stop("`x` must be an object of class `glm` or `glmerMod`.", call. = F) + } + + # mixed models (lme4) + if (inherits(fit, "glmerMod")) { + # check for package availability + y <- lme4::getME(fit, "y") + pred <- stats::predict(fit, type = "response", re.form = NULL) + } else { + y <- fit$y + pred <- stats::predict.glm(fit, type = "response") + } + + # delete pred for cases with missing residuals + if (anyNA(stats::residuals(fit))) pred <- pred[!is.na(stats::residuals(fit))] + + categories <- unique(y) + m1 <- mean(pred[which(y == categories[1])], na.rm = T) + m2 <- mean(pred[which(y == categories[2])], na.rm = T) + + D <- abs(m2 - m1) + names(D) <- "Tjur's D" + + return(D) +} + + + + + + + + +#' Golden Ratio. +#' +#' Returns the golden ratio (1.618034...). +#' +#' @param x A number to be multiplied by the golden ratio. The default (x=1) returns the value of the golden ratio. +#' +#' @examples +#' library(psycho) +#' +#' golden() +#' golden(8) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +golden <- function(x = 1) { + return(x * (1 + sqrt(5)) / 2) +} + + + + + + + + + +#' Highest Density Intervals (HDI). +#' +#' Compute the Highest Density Intervals (HDI) of a distribution. +#' +#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). +#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. +#' +#' @examples +#' library(psycho) +#' +#' distribution <- rnorm(1000, 0, 1) +#' HDI_values <- HDI(distribution) +#' print(HDI_values) +#' plot(HDI_values) +#' summary(HDI_values) +#' +#' x <- matrix(rexp(200), 100) +#' HDI_values <- HDI(x) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +HDI <- function(x, prob = .95) { + + # From CI to prob if necessary + if (prob > 1 & prob <= 100) { + prob <- prob / 100 + } + + # If x is a matrix + if (ncol(as.matrix(x)) > 1) { + HDImin <- c() + HDImax <- c() + for (col in seq_len(ncol(x))) { + HDI <- .HDI(x[, col], prob = prob) + HDImin <- c(HDImin, HDI[1]) + HDImax <- c(HDImax, HDI[2]) + } + return(data.frame(HDImin = HDImin, HDImax = HDImax)) + + + # If x is a vector + } else { + # Process + # ------------- + HDI <- .HDI(x, prob = prob) + HDImin <- HDI[1] + HDImax <- HDI[2] + + # Store results + # ------------- + values <- list(HDImin = HDImin, HDImax = HDImax, prob = prob) + text <- paste( + prob * 100, + "% CI [", + format_string(HDImin, "%.2f"), + ", ", + format_string(HDImax, "%.2f"), + "]", + sep = "" + ) + summary <- data.frame(Probability = prob, HDImin = HDImin, HDImax = HDImax) + + + # Plot + # ------------- + data <- as.data.frame(x = x) + plot <- ggplot(data = data, aes(x)) + + geom_density(fill = "#2196F3") + + geom_vline( + data = data, aes(xintercept = HDImin), + linetype = "dashed", color = "#E91E63", size = 1 + ) + + geom_vline( + data = data, aes(xintercept = HDImax), + linetype = "dashed", color = "#E91E63", size = 1 + ) + + theme_minimal() + + + # Output + # ------------- + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) + } +} + + + + +#' Highest Density Intervals (HDI) +#' +#' See \link[=HDI]{HDI} +#' +#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). +#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. +#' +#' @export +HDImin <- function(x, prob = .95) { + HDImin <- HDI(x, prob = prob)$values$HDImin + return(HDImin) +} + +#' Highest Density Intervals (HDI) +#' +#' See \link[=HDI]{HDI} +#' +#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). +#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. +#' +#' @export +HDImax <- function(x, prob = .95) { + HDImax <- HDI(x, prob = prob)$values$HDImax + return(HDImax) +} + + + + + + +#' @keywords internal +.HDI <- function(x, prob) { + x <- sort(x) + ci.index <- ceiling(prob * length(x)) + nCIs <- length(x) - ci.index + ci.width <- purrr::map_dbl(1:nCIs, ~ x[.x + ci.index] - x[.x]) + HDImin <- x[which.min(ci.width)] + HDImax <- x[which.min(ci.width) + ci.index] + return(c(HDImin, HDImax)) +} + + + + + + + + +#' Bayes Factor Interpretation +#' +#' Return the interpretation of a Bayes Factor. +#' +#' @param x Bayes Factor. +#' @param direction Include direction (against / in favour). +#' @param bf Include Bayes Factor. +#' @param rules Can be "jeffreys1961" (default), "raftery1995", or a custom list. +#' +#' +#' @examples +#' library(psycho) +#' interpret_bf(x = 10) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @references +#' \itemize{ +#' \item{Jeffreys, H. (1961), Theory of Probability, 3rd ed., Oxford University Press, Oxford.} +#' \item{Jarosz, A. F., & Wiley, J. (2014). What are the odds? A practical guide to computing and reporting Bayes factors. The Journal of Problem Solving, 7(1), 2.} +#' } +#' @export +interpret_bf <- function(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961") { + interpretation <- sapply(x, .interpret_bf, direction = direction, bf = bf, rules = rules, return_rules = FALSE) + return(interpretation) +} + + + + + +#' Bayes factor formatting +#' +#' Bayes factor formatting +#' +#' @param bf Bayes Factor. +#' @param max Treshold for maximum. +#' +#' @export +format_bf <- function(bf, max = 100) { + if (bf > max) { + bf <- paste0("BF > ", max) + } else { + bf <- paste0("BF = ", format_digit(bf)) + } + return(bf) +} + + + + + + + + + + +#' @keywords internal +.interpret_bf <- function(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961", return_rules = TRUE) { + if (x < 1) { + x <- 1 / abs(x) + dir <- "against" + } else { + dir <- "in favour of" + } + + + if (!is.list(rules)) { + if (rules == "jeffreys1961") { + rules <- list( + "no" = 0, + "anecdotal" = 1, + "moderate" = 3, + "strong" = 10, + "very strong" = 30, + "extreme" = 100 + ) + } else if (rules == "raftery1995") { + rules <- list( + "no" = 0, + "weak" = 1, + "positive" = 3, + "strong" = 20, + "very strong" = 150 + ) + } else { + stop("rules must be either a list or 'jeffreys1961' or 'raftery1995'.") + } + } + + + + s <- (abs(x) - unlist(rules)) + s <- names(which.min(s[s >= 0])) + if (is.null(s)) { + s <- NA + } else { + s <- paste(s, "evidence") + } + + + + + if (bf == TRUE) { + bf <- paste0("(", format_bf(x), ")") + s <- paste(s, bf) + } + if (direction == TRUE) { + s <- paste(s, dir) + } + + return(s) +} + + + + + + + + +#' Standardized difference (Cohen's d) interpreation. +#' +#' Interpret d with a set of rules. +#' +#' @param x Standardized difference. +#' @param direction Return direction. +#' @param rules Can be "cohen1988" (default), "sawilowsky2009", or a custom list. +#' +#' @examples +#' library(psycho) +#' interpret_d(-0.42) +#' interpret_d(-0.62) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_d <- function(x, direction = FALSE, rules = "cohen1988") { + interpretation <- sapply(x, .interpret_d, direction = direction, rules = rules, return_rules = FALSE) + return(interpretation) +} + + + + + + + +#' Standardized difference (Cohen's d) interpreation for a posterior distribution. +#' +#' Interpret d with a set of rules. +#' +#' @param posterior Posterior distribution of standardized differences. +#' @param rules Can be "cohen1988" (default), "sawilowsky2009", or a custom list. +#' +#' @examples +#' library(psycho) +#' posterior <- rnorm(1000, 0.6, 0.05) +#' interpret_d_posterior(posterior) +#' interpret_d_posterior(rnorm(1000, 0.1, 1)) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_d_posterior <- function(posterior, rules = "cohen1988") { + interpretation <- sapply(posterior, .interpret_d, rules = rules, direction = TRUE, return_rules = TRUE) + rules <- unlist(interpretation[, 1]$rules) + interpretation <- as.data.frame(unlist(interpretation[1, ])) + interpretation <- na.omit(interpretation) + names(interpretation) <- "Interpretation" + + summary <- interpretation %>% + group_by_("Interpretation") %>% + summarise_("Probability" = "n() / length(posterior)") %>% + tidyr::separate("Interpretation", + c("Size", "Direction"), + " and ", + remove = FALSE + ) %>% + mutate_( + "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', + "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", + "Size" = "factor(Size)" + ) %>% + arrange_("Size") + + values <- list() + for (size in names(sort(rules, decreasing = TRUE))) { + if (size %in% summary$Size) { + if (nrow(summary[summary$Size == size & summary$Opposite == FALSE, ]) == 0) { + values[size] <- 0 + } else { + values[size] <- summary[summary$Size == size & summary$Opposite == FALSE, ]$Probability + } + } else { + values[size] <- 0 + } + } + values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) + + + # Text + if (length(summary[summary$Opposite == FALSE, ]$Size) > 1) { + text_sizes <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Size, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Size, 1)) + text_effects <- paste0( + paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), + " and ", + paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") + ) + + text <- paste0( + "The effect's size can be considered as ", + text_sizes, + " with respective probabilities of ", + text_effects, + "." + ) + } else { + text_sizes <- summary[summary$Opposite == FALSE, ]$Size + text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") + + text <- paste0( + "The effect's size can be considered as ", + text_sizes, + " with a probability of ", + text_effects, + "." + ) + } + + + + plot <- "Not available." + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + + return(output) +} + + + + + + +#' @keywords internal +.interpret_d <- function(x, direction = FALSE, rules = "cohen1988", return_rules = TRUE) { + if (!is.list(rules)) { + if (rules == "cohen1988") { + rules <- list( + "very small" = 0, + "small" = 0.2, + "medium" = 0.5, + "large" = 0.8 + ) + } else if (rules == "sawilowsky2009") { + rules <- list( + "tiny" = 0, + "very small" = 0.1, + "small" = 0.2, + "medium" = 0.5, + "large" = 0.8, + "very large" = 1.2, + "huge" = 2.0 + ) + } else { + stop("rules must be either a list or 'cohen1988' or 'sawilowsky2009'.") + } + } + + + if (x > 0) { + d <- "positive" + } else { + d <- "negative" + } + + x <- (abs(x) - unlist(rules)) + s <- names(which.min(x[x >= 0])) + if (is.null(s)) { + s <- NA + } + + + if (direction) { + interpretation <- paste(s, "and", d) + } else { + interpretation <- s + } + + + if (return_rules) { + return(list(interpretation = interpretation, rules = rules)) + } else { + return(interpretation) + } +} + + + + + + + +#' Interpret fit measures of lavaan or blavaan objects +#' +#' Interpret fit measures of lavaan or blavaan objects +#' +#' @param fit lavaan or blavaan object. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_lavaan <- function(fit, ...) { + UseMethod("interpret_lavaan") +} + + + + + + +#' Interpret fit measures of lavaan objects +#' +#' Interpret fit measures of lavaan objects +#' +#' @param fit lavaan or blavaan object. +#' @param ... Arguments passed to or from other methods. +#' +#' @importFrom lavaan fitmeasures +#' @export +interpret_lavaan.lavaan <- function(fit, ...) { + values <- list() + + indices <- lavaan::fitmeasures(fit) + + + for (index in names(indices)) { + values[index] <- indices[index] + } + + # awang2012 + # https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM + if (values$cfi >= 0.9) { + cfi <- "satisfactory" + } else { + cfi <- "poor" + } + if (values$rmsea <= 0.08) { + rmsea <- "satisfactory" + } else { + rmsea <- "poor" + } + if (values$gfi >= 0.9) { + gfi <- "satisfactory" + } else { + gfi <- "poor" + } + if (values$tli >= 0.9) { + tli <- "satisfactory" + } else { + tli <- "poor" + } + if (values$nfi >= 0.9) { + nfi <- "satisfactory" + } else { + nfi <- "poor" + } + + # Summary + summary <- data.frame( + Index = c("RMSEA", "CFI", "GFI", "TLI", "NFI", "Chisq"), + Value = c(values$rmsea, values$cfi, values$gfi, values$tli, values$nfi, values$chisq), + Interpretation = c(rmsea, cfi, gfi, tli, nfi, NA), + Treshold = c("< .08", "> .90", "> 0.90", "> 0.90", "> 0.90", NA) + ) + + # Text + if ("satisfactory" %in% summary$Interpretation) { + satisfactory <- summary %>% + filter_("Interpretation == 'satisfactory'") %>% + mutate_("Index" = "paste0(Index, ' (', format_digit(Value), ' ', Treshold, ')')") %>% + select_("Index") %>% + pull() %>% + paste0(collapse = ", ") + satisfactory <- paste0("The ", satisfactory, " show satisfactory indices of fit.") + } else { + satisfactory <- "" + } + if ("poor" %in% summary$Interpretation) { + poor <- summary %>% + filter_("Interpretation == 'poor'") %>% + mutate_( + "Treshold" = 'stringr::str_replace(Treshold, "<", "SUP")', + "Treshold" = 'stringr::str_replace(Treshold, ">", "INF")', + "Treshold" = 'stringr::str_replace(Treshold, "SUP", ">")', + "Treshold" = 'stringr::str_replace(Treshold, "INF", "<")' + ) %>% + mutate_("Index" = "paste0(Index, ' (', format_digit(Value), ' ', Treshold, ')')") %>% + select_("Index") %>% + pull() %>% + paste0(collapse = ", ") + poor <- paste0("The ", poor, " show poor indices of fit.") + } else { + poor <- "" + } + text <- paste(satisfactory, poor) + + output <- list(text = text, summary = summary, values = values, plot = "Not available yet") + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + +#' Interpret fit measures of blavaan objects +#' +#' Interpret fit measures of blavaan objects +#' +#' @param indices Vector of strings indicating which indices to report. Only works for bayesian objects for now. +#' @inheritParams interpret_lavaan +#' @export +interpret_lavaan.blavaan <- function(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) { + values <- list() + + indices <- lavaan::fitmeasures(fit) + + + for (index in names(indices)) { + values[index] <- indices[index] + } + + # Summary + summary <- as.data.frame(indices) %>% + rownames_to_column("Index") %>% + rename_("Value" = "indices") %>% + mutate_("Index" = "str_to_upper(Index)") + + # Text + relevant_indices <- summary[summary$Index %in% c("BIC", "DIC", "WAIC", "LOOIC"), ] + text <- paste0(relevant_indices$Index, " = ", format_digit(relevant_indices$Value), collapse = ", ") + + output <- list(text = text, summary = summary, values = values, plot = "Not available yet") + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + +#' Odds ratio interpreation for a posterior distribution. +#' +#' Interpret odds with a set of rules. +#' +#' @param x Odds ratio. +#' @param log Are these log odds ratio? +#' @param direction Return direction. +#' @param rules Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list. +#' +#' @examples +#' library(psycho) +#' interpret_odds(x = 2) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize +#' +#' @references +#' \itemize{ +#' \item{Chen, H., Cohen, P., & Chen, S. (2010). How big is a big odds ratio? Interpreting the magnitudes of odds ratios in epidemiological studies. Communications in Statistics—Simulation and Computation, 39(4), 860-864.} +#' } +#' @export +interpret_odds <- function(x, log = FALSE, direction = FALSE, rules = "chen2010") { + if (rules %in% c("cohen1988", "sawilowsky2009")) { + interpretation <- sapply(odds_to_d(x, log = log), .interpret_d, direction = direction, rules = rules, return_rules = FALSE) + } else { + interpretation <- sapply(x, .interpret_odds, log = log, direction = direction, rules = rules, return_rules = FALSE) + } + return(interpretation) +} + + + + + + + + + + +#' Odds ratio interpreation for a posterior distribution. +#' +#' Interpret odds with a set of rules. +#' +#' @param posterior Posterior distribution of odds ratio. +#' @param log Are these log odds ratio? +#' @param rules Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list. +#' +#' @examples +#' library(psycho) +#' posterior <- rnorm(1000, 0.6, 0.05) +#' interpret_odds_posterior(posterior) +#' interpret_odds_posterior(rnorm(1000, 0.1, 1)) +#' interpret_odds_posterior(rnorm(1000, 3, 1.5)) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_odds_posterior <- function(posterior, log = FALSE, rules = "chen2010") { + if (rules %in% c("cohen1988", "sawilowsky2009")) { + posterior <- odds_to_d(posterior, log = log) + interpretation <- sapply(posterior, .interpret_d, direction = TRUE, rules = rules, return_rules = TRUE) + } else { + interpretation <- sapply(posterior, .interpret_odds, log = log, direction = TRUE, rules = rules, return_rules = TRUE) + } + rules <- unlist(interpretation[, 1]$rules) + interpretation <- as.data.frame(unlist(interpretation[1, ])) + interpretation <- na.omit(interpretation) + names(interpretation) <- "Interpretation" + + summary <- interpretation %>% + group_by_("Interpretation") %>% + summarise_("Probability" = "n() / length(posterior)") %>% + tidyr::separate("Interpretation", + c("Size", "Direction"), + " and ", + remove = FALSE + ) %>% + mutate_( + "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', + "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", + "Size" = "factor(Size)" + ) %>% + arrange_("Size") + + values <- list() + for (size in names(sort(rules, decreasing = TRUE))) { + if (size %in% summary$Size) { + if (nrow(summary[summary$Size == size & summary$Opposite == FALSE, ]) == 0) { + values[size] <- 0 + } else { + values[size] <- summary[summary$Size == size & summary$Opposite == FALSE, ]$Probability + } + } else { + values[size] <- 0 + } + } + values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) + + + # Text + if (length(summary[summary$Opposite == FALSE, ]$Size) > 1) { + text_sizes <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Size, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Size, 1)) + text_effects <- paste0( + paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), + " and ", + paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") + ) + + text <- paste0( + "The effect's size can be considered as ", + text_sizes, + " with respective probabilities of ", + text_effects, + "." + ) + } else { + text_sizes <- summary[summary$Opposite == FALSE, ]$Size + text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") + + text <- paste0( + "The effect's size can be considered as ", + text_sizes, + " with a probability of ", + text_effects, + "." + ) + } + + + + plot <- "Not available." + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + + return(output) +} + + + + + + + + +#' @keywords internal +.interpret_odds <- function(x, log = FALSE, direction = FALSE, rules = "chen2010", return_rules = TRUE) { + if (x > 0) { + d <- "positive" + } else { + d <- "negative" + } + + if (log == TRUE) { + x <- exp(abs(x)) + } + + if (!is.list(rules)) { + if (rules == "chen2010") { + rules <- list( + "very small" = 0, + "small" = 1.68, + "medium" = 3.47, + "large" = 6.71 + ) + } else { + stop("rules must be either a list or 'chen2010'.") + } + } + + + s <- (abs(x) - unlist(rules)) + s <- names(which.min(s[s >= 0])) + if (is.null(s)) { + s <- NA + } + + if (direction) { + interpretation <- paste(s, "and", d) + } else { + interpretation <- s + } + + if (return_rules) { + return(list(interpretation = interpretation, rules = rules)) + } else { + return(interpretation) + } +} + + + + + + + + + + + + + + + + + +#' (Log) odds ratio to Cohen's d +#' +#' (Log) odds ratio to Cohen's d. +#' +#' @param x Odds ratio. +#' @param log Are these log odds ratio? +#' +#' @examples +#' library(psycho) +#' odds_to_d(x = 2) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso https://www.meta-analysis.com/downloads/Meta-analysis%20Converting%20among%20effect%20sizes.pdf +#' +#' @references +#' \itemize{ +#' \item{Sánchez-Meca, J., Marín-Martínez, F., & Chacón-Moscoso, S. (2003). Effect-size indices for dichotomized outcomes in meta-analysis. Psychological methods, 8(4), 448.} +#' } +#' @export +odds_to_d <- function(x, log = TRUE) { + if (log == FALSE) { + x <- log(x) + } + d <- x * (sqrt(3) / pi) + return(d) +} + + + + + + + + + + +#' Omega Squared Interpretation +#' +#' Return the interpretation of Omegas Squared. +#' +#' @param x Omega Squared. +#' @param rules Can be "field2013" (default), or a custom list. +#' +#' @examples +#' library(psycho) +#' interpret_omega_sq(x = 0.05) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize +#' +#' @references +#' \itemize{ +#' \item{Field, A (2013) Discovering statistics using IBM SPSS Statistics. Fourth Edition. Sage:London.} +#' } +#' @export +interpret_omega_sq <- function(x, rules = "field2013") { + interpretation <- sapply(x, .interpret_omega_sq, rules = rules, return_rules = FALSE) + return(interpretation) +} + + + + + + +#' @keywords internal +.interpret_omega_sq <- function(x, rules = "field2013", return_rules = TRUE) { + if (!is.list(rules)) { + if (rules == "field2013") { + rules <- list( + "very small" = 0, + "small" = 0.01, + "medium" = 0.06, + "large" = 0.14 + ) + } else { + stop("rules must be either a list or 'field2013'.") + } + } + + + + interpretation <- (abs(x) - unlist(rules)) + interpretation <- names(which.min(interpretation[interpretation >= 0])) + if (is.null(interpretation)) { + interpretation <- NA + } + + return(interpretation) +} + + + + + + + + + +#' Correlation coefficient r interpreation. +#' +#' Interpret r with a set of rules. +#' +#' @param x Correlation coefficient. +#' @param direction Return direction. +#' @param strength Return strength. +#' @param rules Can be "cohen1988" (default), "evans1996", or a custom list. +#' +#' +#' @examples +#' library(psycho) +#' interpret_r(-0.42) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso Page 88 of APA's 6th Edition +#' +#' @export +interpret_r <- function(x, direction = TRUE, strength = TRUE, rules = "cohen1988") { + interpretation <- sapply(x, .interpret_r, direction = direction, strength = strength, rules = rules, return_rules = FALSE) + return(interpretation) +} + + + + + + + + + +#' Correlation coefficient r interpreation for a posterior distribution. +#' +#' Interpret r with a set of rules. +#' +#' @param posterior Posterior distribution of correlation coefficient. +#' @param rules Can be "cohen1988" (default) or "evans1996", or a custom list. +#' +#' @examples +#' library(psycho) +#' posterior <- rnorm(1000, 0.5, 0.5) +#' interpret_r_posterior(posterior) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @seealso Page 88 of APA's 6th Edition +#' +#' @export +interpret_r_posterior <- function(posterior, rules = "cohen1988") { + interpretation <- sapply(posterior, .interpret_r, rules = rules) + rules <- unlist(interpretation[, 1]$rules) + interpretation <- as.data.frame(unlist(interpretation[1, ])) + interpretation <- na.omit(interpretation) + names(interpretation) <- "Interpretation" + + summary <- interpretation %>% + group_by_("Interpretation") %>% + summarise_("Probability" = "n() / length(posterior)") %>% + separate("Interpretation", + c("Strength", "Direction"), + ", and ", + remove = FALSE + ) %>% + mutate_( + "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', + "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", + "Strength" = "factor(Strength)" + ) %>% + arrange_("Strength") + + values <- list() + for (strength in names(sort(rules, decreasing = TRUE))) { + if (strength %in% summary$Strength) { + values[strength] <- summary[summary$Strength == strength & summary$Opposite == FALSE, ]$Probability + } else { + values[strength] <- 0 + } + } + values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) + + # Text + if (length(summary[summary$Opposite == FALSE, ]$Strength) > 1) { + text_strength <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Strength, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Strength, 1)) + text_effects <- paste0( + paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), + " and ", + paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") + ) + + text <- paste0( + "The correlation can be considered as ", + text_strength, + " with respective probabilities of ", + text_effects, + "." + ) + } else { + text_sizes <- summary[summary$Opposite == FALSE, ]$Strength + text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") + + text <- paste0( + "The correlation can be considered as ", + text_sizes, + " with a probability of ", + text_effects, + "." + ) + } + + + plot <- "Not available." + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + + return(output) +} + + + + + + + + + + + + + + + + +#' @keywords internal +.interpret_r <- function(x, direction = TRUE, strength = TRUE, rules = "cohen1988", return_rules = TRUE) { + if (!is.list(rules)) { + if (rules == "evans1996") { + rules <- list( + "very weak" = 0, + "weak" = 0.20, + "moderate" = 0.40, + "strong" = 0.60, + "very strong" = 0.80 + ) + } else if (rules == "cohen1988") { + rules <- list( + "very small" = 0, + "small" = 0.10, + "moderate" = 0.30, + "large" = 0.50 + ) + } else { + stop("rules must be either a list or 'cohen1988' or 'evans1996'.") + } + } + + + if (x > 0) { + d <- "positive" + } else { + d <- "negative" + } + + x <- (abs(x) - unlist(rules)) + s <- names(which.min(x[x >= 0])) + if (is.null(s)) { + s <- NA + } + + + + if (strength & direction) { + interpretation <- paste0(s, ", and ", d) + } else if (strength & direction == FALSE) { + interpretation <- s + } else { + interpretation <- d + } + + + + if (return_rules) { + return(list(interpretation = interpretation, rules = rules)) + } else { + return(interpretation) + } +} + + + + + + + + +#' R2 interpreation. +#' +#' Interpret R2 with a set of rules. +#' +#' @param x Value. +#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. +#' +#' @examples +#' library(psycho) +#' interpret_R2(x = 0.42) +#' interpret_R2(x = c(0.42, 0.2, 0.9, 0)) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_R2 <- function(x, rules = "cohen1988") { + interpretation <- sapply(x, .interpret_R2, rules = rules, return_rules = FALSE) + return(interpretation) +} + + + + + +#' R2 interpreation for a posterior distribution. +#' +#' Interpret R2 with a set of rules. +#' +#' @param posterior Distribution of R2. +#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. +#' +#' @examples +#' library(psycho) +#' posterior <- rnorm(1000, 0.4, 0.1) +#' interpret_R2_posterior(posterior) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_R2_posterior <- function(posterior, rules = "cohen1988") { + interpretation <- sapply(posterior, .interpret_R2, rules = rules) + rules <- unlist(interpretation[, 1]$rules) + interpretation <- as.data.frame(unlist(interpretation[1, ])) + interpretation <- na.omit(interpretation) + names(interpretation) <- "Interpretation" + + summary <- interpretation %>% + group_by_("Interpretation") %>% + summarise_("Probability" = "n() / length(posterior)") + + values <- list() + for (value in names(sort(rules, decreasing = TRUE))) { + if (value %in% summary$Interpretation) { + values[value] <- summary[summary$Interpretation == value, ]$Probability + } else { + values[value] <- 0 + } + } + + # Text + if (length(summary$Interpretation) > 1) { + text_strength <- paste0(paste0(head(summary$Interpretation, -1), collapse = ", "), " or ", tail(summary$Interpretation, 1)) + text_effects <- paste0( + paste0(paste0(format_digit(head(summary$Probability * 100, -1)), "%"), collapse = ", "), + " and ", + paste0(format_digit(tail(summary$Probability, 1) * 100), "%") + ) + + text <- paste0( + "The R2 can be considered as ", + text_strength, + " with respective probabilities of ", + text_effects, + "." + ) + } else { + text_sizes <- summary$Interpretation + text_effects <- paste0(format_digit(summary$Probability * 100), "%") + + text <- paste0( + "The R2 can be considered as ", + text_sizes, + " with a probability of ", + text_effects, + "." + ) + } + + + plot <- "Not available." + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + + return(output) +} + + + + + + +#' @keywords internal +.interpret_R2 <- function(x, rules = "cohen1988", return_rules = TRUE) { + if (!is.list(rules)) { + if (rules == "cohen1988") { + rules <- list( + "very small" = 0, + "small" = 0.02, + "medium" = 0.13, + "large" = 0.26 + ) + } else if (rules == "chin1998") { + rules <- list( + "very small" = 0, + "small" = 0.19, + "medium" = 0.33, + "large" = 0.67 + ) + } else if (rules == "hair2013") { + rules <- list( + "very small" = 0, + "small" = 0.25, + "medium" = 0.50, + "large" = 0.75 + ) + } else { + stop("rules must be either a list or 'cohen1988', 'chin1998' or 'hair2013'.") + } + } + + x <- (x - unlist(rules)) + interpretation <- names(which.min(x[x >= 0])) + if (is.null(interpretation)) { + interpretation <- NA + } + + if (return_rules) { + return(list(interpretation = interpretation, rules = rules)) + } else { + return(interpretation) + } +} + + + + + + +#' RMSEA interpreation. +#' +#' Interpret RMSEA with a set of rules. +#' +#' @param x RMSEA. +#' @param rules Can be "awang2012", or a custom list. +#' +#' @examples +#' library(psycho) +#' interpret_RMSEA(0.04) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +interpret_RMSEA <- function(x, rules = "awang2012") { + interpretation <- sapply(x, .interpret_RMSEA, rules = rules, return_rules = FALSE) + return(interpretation) +} + + + + + +#' @keywords internal +.interpret_RMSEA <- function(x, rules = "awang2012", return_rules = TRUE) { + if (!is.list(rules)) { + if (rules == "awang2012") { + rules <- list( + "good" = 0, + "acceptable" = 0.05, + "poor" = 0.08 + ) + } else { + stop("rules must be either a list or 'awang2012'.") + } + } + + x <- (abs(x) - unlist(rules)) + s <- names(which.min(x[x >= 0])) + if (is.null(s)) { + s <- NA + } + + if (return_rules) { + return(list(interpretation = s, rules = rules)) + } else { + return(s) + } +} + + + + + +#' Check if model includes random effects. +#' +#' Check if model is mixed. See the +#' documentation for your model's class: +#' \itemize{ +#' \item{\link[=is.mixed.stanreg]{is.mixed.stanreg}} +#' } +#' +#' @param fit Model. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +is.mixed <- function(fit, ...) { + UseMethod("is.mixed") +} + + + + + + + + + + + + + +#' Check if model includes random effects. +#' +#' Check if model is mixed. +#' +#' @param fit Model. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +is.mixed.stanreg <- function(fit, ...) { + mixed <- tryCatch({ + broom::tidy(fit, parameters = "varying") + TRUE + }, error = function(e) { + FALSE + }) + return(mixed) +} + + + + + + + + + +#' Check if a dataframe is standardized. +#' +#' Check if a dataframe is standardized. +#' +#' @param df A dataframe. +#' @param tol The error treshold. +#' +#' @examples +#' library(psycho) +#' +#' df <- psycho::affective +#' is.standardized(df) +#' +#' dfZ <- psycho::standardize(df) +#' is.standardized(dfZ) +#' @return bool. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import purrr +#' @export +is.standardized <- function(df, tol = 0.1) { + dfZ <- standardize(df) + dfZnum <- purrr::keep(dfZ, is.numeric) + + dfnum <- purrr::keep(df, is.numeric) + + error <- as.matrix(dfnum) - as.matrix(dfZnum) + error <- as.data.frame(error) + names(error) <- names(dfnum) + + error_mean <- error %>% + summarise_all(mean) + + if (TRUE %in% as.character(error_mean[1, ] > tol)) { + standardized <- FALSE + } else { + standardized <- TRUE + } + return(standardized) +} + + + + + + + +#' Mellenbergh & van den Brink (1998) test for pre-post comparison. +#' +#' Test for comparing post-test to baseline for a single participant. +#' +#' @param t0 Single value (pretest or baseline score). +#' @param t1 Single value (posttest score). +#' @param controls Vector of scores of the control group OR single value corresponding to the control SD of the score. +#' +#' @return Returns a data frame containing the z-value and p-value. If significant, the difference between pre and post tests is significant. +#' +#' @examples +#' library(psycho) +#' +#' mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) +#' @author Dominique Makowski +#' +#' @importFrom stats pnorm sd +#' @export +mellenbergh.test <- function(t0, t1, controls) { + if (length(controls) > 1) { + sd <- sd(controls) * sqrt(2) + } else { + sd <- controls * sqrt(2) + } + + diff <- t1 - t0 + + diff_CI_bottom <- diff - 1.65 * sd + diff_CI_top <- diff + 1.65 * sd + + z <- diff / sd + pval <- 2 * pnorm(-abs(z)) + + # One-tailed p value + if (pval > .05 & pval / 2 < .05) { + one_tailed <- paste0( + " However, the null hypothesis of no change can be rejected at a one-tailed 5% significance level (one-tailed p ", + format_p(pval / 2), + ")." + ) + } else { + one_tailed <- "" + } + + + + p_interpretation <- ifelse(pval < 0.05, " ", " not ") + text <- paste0( + "The Mellenbergh & van den Brink (1998) test suggests that the change is", + p_interpretation, + "significant (d = ", + format_digit(diff), + ", 90% CI [", + format_digit(diff_CI_bottom), + ", ", + format_digit(diff_CI_top), + "], z = ", + format_digit(z), + ", p ", + format_p(pval), + ").", + one_tailed + ) + + + values <- list( + text = text, + diff = diff, + diff_90_CI_lower = diff_CI_bottom, + diff_90_CI_higher = diff_CI_top, + z = z, + p = pval + ) + summary <- data.frame(diff = diff, diff_90_CI_lower = diff_CI_bottom, diff_90_CI_higher = diff_CI_top, z = z, p = pval) + plot <- "Not available yet" + + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + return(output) + # return("The method for no-controls is not implemented yet.") +} + + + + + + + + + + +#' Model to Prior. +#' +#' Convert a Bayesian model's results to priors. +#' +#' @param fit A stanreg model. +#' @param autoscale Set autoscale. +#' @examples +#' \dontrun{ +#' library(rstanarm) +#' library(psycho) +#' +#' fit <- stan_glm(Sepal.Length ~ Petal.Width, data = iris) +#' priors <- model_to_priors(fit) +#' update(fit, prior = priors$prior) +#' +#' fit <- stan_glmer(Subjective_Valence ~ Emotion_Condition + (1 | Participant_ID), +#' data = psycho::emotion +#' ) +#' priors <- model_to_priors(fit) +#' +#' fit1 <- stan_glm(Subjective_Valence ~ Emotion_Condition, +#' data = filter(psycho::emotion, Participant_ID == "1S") +#' ) +#' +#' fit2 <- stan_glm(Subjective_Valence ~ Emotion_Condition, +#' data = filter(psycho::emotion, Participant_ID == "1S"), +#' prior = priors$prior, prior_intercept = priors$prior_intercept +#' ) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import dplyr +#' @importFrom stats update +#' @importFrom rstanarm normal +#' @export +model_to_priors <- function(fit, autoscale = FALSE) { + posteriors <- as.data.frame(fit) + + # Varnames + varnames <- names(posteriors) + varnames <- varnames[grepl("b\\[", varnames) == FALSE] + + fixed_effects <- names(fit$coefficients) + fixed_effects <- fixed_effects[grepl("b\\[", fixed_effects) == FALSE] + fixed_effects <- fixed_effects[fixed_effects != "(Intercept)"] + + # Get priors + prior_intercept <- list() + priors <- list() + prior_aux <- list() + for (prior in varnames) { + if (prior == "(Intercept)") { + prior_intercept$mean <- mean(posteriors[[prior]]) + prior_intercept$sd <- sd(posteriors[[prior]]) + } else if (prior %in% fixed_effects) { + priors[[prior]] <- list() + priors[[prior]]$mean <- mean(posteriors[[prior]]) + priors[[prior]]$sd <- sd(posteriors[[prior]]) + } else { + prior_aux[[prior]] <- list() + prior_aux[[prior]]$mean <- mean(posteriors[[prior]]) + prior_aux[[prior]]$sd <- sd(posteriors[[prior]]) + } + } + + + prior_intercept <- rstanarm::normal( + prior_intercept$mean, + prior_intercept$sd, + autoscale = autoscale + ) + prior <- .format_priors(priors, autoscale = autoscale) + prior_aux <- .format_priors(prior_aux, autoscale = autoscale) + + return(list(prior_intercept = prior_intercept, prior = prior, priox_aux = prior_aux)) +} + + +#' @keywords internal +.format_priors <- function(priors, autoscale = FALSE) { + prior_mean <- data.frame(priors) %>% + select(contains("mean")) %>% + gather() %>% + select_("value") %>% + pull() + + prior_sd <- data.frame(priors) %>% + select(contains("sd")) %>% + gather() %>% + select_("value") %>% + pull() + + prior <- rstanarm::normal( + prior_mean, + prior_sd, + autoscale = autoscale + ) +} + + + + + + + +#' Compute Maximum Probability of Effect (MPE). +#' +#' Compute the Maximum Probability of Effect (MPE), i.e., the proportion of posterior distribution that is of the same sign as the median. In other words, it corresponds to the maximum probability that the effect is different from 0 in the median’s direction. +#' +#' @param posterior Posterior Distribution. +#' +#' @return list containing the MPE and its values. +#' +#' @examples +#' library(psycho) +#' library(rstanarm) +#' +#' fit <- rstanarm::stan_glm(rating ~ advance, data = attitude) +#' posterior <- psycho::analyze(fit)$values$effects$advance$posterior +#' mpe <- psycho::mpe(posterior) +#' print(mpe$MPE) +#' print(mpe$values) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +mpe <- function(posterior) { + median <- median(posterior) + if (median >= 0) { + MPE <- length(posterior[posterior >= 0]) / length(posterior) * 100 + if (MPE == 100) { + MPE_values <- c(min(posterior), max(posterior)) + } else { + MPE_values <- c(0, max(posterior)) + } + } else { + MPE <- length(posterior[posterior < 0]) / length(posterior) * 100 + if (MPE == 100) { + MPE_values <- c(min(posterior), max(posterior)) + } else { + MPE_values <- c(min(posterior), 0) + } + } + + MPE <- list(MPE = MPE, values = MPE_values) + return(MPE) +} + + + + + + + +#' Find Optimal Factor Number. +#' +#' Find optimal components number using maximum method aggreement. +#' +#' @param df A dataframe or correlation matrix +#' @param rotate What rotation to use c("none", "varimax", "oblimin","promax") +#' @param fm Factoring method: "pa" for Principal Axis Factor Analysis, +#' "minres" (default) for minimum residual (OLS) factoring, "mle" for +#' Maximum Likelihood FA and "pc" for Principal Components +#' @param n If correlation matrix is passed, the sample size. +#' +#' @return output +#' +#' @examples +#' df <- dplyr::select_if(attitude, is.numeric) +#' results <- psycho::n_factors(df) +#' +#' summary(results) +#' plot(results) +#' +#' # See details on methods +#' psycho::values(results)$methods +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom qgraph cor_auto +#' @importFrom psych VSS +#' @importFrom MASS mvrnorm +#' @importFrom MASS ginv +#' @importFrom nFactors moreStats +#' @importFrom nFactors nScree +#' @importFrom stats cov +#' @importFrom stats dnorm +#' @importFrom stats qnorm +#' @export +n_factors <- function(df, rotate = "varimax", fm = "minres", n = NULL) { + + # Copy the parallel function from nFactors to correct the use of mvrnorm + parallel <- function(subject = 100, var = 10, rep = 100, cent = 0.05, + quantile = cent, model = "components", + sd = diag(1, var), ...) { + r <- subject + c <- var + y <- matrix(c(1:r * c), nrow = r, ncol = c) + evpea <- NULL + for (k in c(1:rep)) { + y <- MASS::mvrnorm(n = r, mu = rep(0, var), Sigma = sd, empirical = FALSE) + corY <- cov(y, ...) + if (model == "components") { + diag(corY) <- diag(sd) + } + if (model == "factors") { + corY <- corY - MASS::ginv(diag(diag(MASS::ginv(corY)))) + } + evpea <- rbind(evpea, eigen(corY)[[1]]) + } + SEcentile <- function(sd, n = 100, p = 0.95) { + return(sd / sqrt(n) * sqrt(p * (1 - p)) / dnorm(qnorm(p))) + } + mevpea <- sapply(as.data.frame(evpea), mean) + sevpea <- sapply(as.data.frame(evpea), sd) + qevpea <- nFactors::moreStats(evpea, quantile = quantile)[3, ] + sqevpea <- sevpea + sqevpea <- sapply( + as.data.frame(sqevpea), SEcentile, + n = rep, + p = cent + ) + result <- list( + eigen = data.frame( + mevpea, sevpea, qevpea, + sqevpea + ), + subject = r, + variables = c, + centile = cent + ) + class(result) <- "parallel" + return(result) + } + + # Detect if df us a correlation matrix + if (length(setdiff(names(df), rownames(df))) != 0) { + cor <- qgraph::cor_auto(df, forcePD = FALSE) + n <- nrow(df) + } else { + if (is.null(n)) { + stop("A correlation matrix was passed. You must provided the sample size (n).") + } + cor <- df + } + + + ap <- parallel(subject = n, var = ncol(cor)) + nS <- nFactors::nScree(x = eigen(cor)$values, aparallel = ap$eigen$qevpea) + + # Eigeinvalues data + eigenvalues <- nS$Analysis %>% + dplyr::select_( + "Eigenvalues", + "Exp.Variance" = "Prop", + "Cum.Variance" = "Cumu" + ) %>% + mutate_("n.Factors" = ~ seq_len(nrow(nS$Analysis))) + + + + + + # Processing + # ------------------- + results <- data.frame( + Method = c( + "Optimal Coordinates", + "Acceleration Factor", + "Parallel Analysis", + "Eigenvalues (Kaiser Criterion)" + ), + n_optimal = as.numeric(nS$Components[1, ]) + ) + + # EGA Method + # Doesn't really work for now :( + # ega <- EGA::EGA(cor, plot.EGA = F, matrix=TRUE, n = n) + # ega <- EGA::bootEGA(df, n = 1000) + + # VSS + vss <- psych::VSS( + cor, + n.obs = n, + rotate = rotate, + fm = fm, plot = F + ) # fm can be "pa", "pc", "minres", "mle" + stats <- vss$vss.stats + stats$map <- vss$map + stats$n_factors <- seq_len(nrow(stats)) + + # map + if (length(stats$map[!is.na(stats$map)]) > 0) { + min <- min(stats$map[!is.na(stats$map)]) + opt <- stats[stats$map == min, ]$n_factors[!is.na(stats[stats$map == min, ]$n_factors)] + results <- rbind( + results, + data.frame( + Method = c("Velicer MAP"), + n_optimal = c(opt) + ) + ) + } + # bic + if (length(stats$BIC[!is.na(stats$BIC)]) > 0) { + min <- min(stats$BIC[!is.na(stats$BIC)]) + opt <- stats[stats$BIC == min, ]$n_factors[!is.na(stats[stats$BIC == min, ]$n_factors)] + results <- rbind( + results, + data.frame( + Method = c("BIC"), + n_optimal = c(opt) + ) + ) + } + # sabic + if (length(stats$SABIC[!is.na(stats$SABIC)]) > 0) { + min <- min(stats$SABIC[!is.na(stats$SABIC)]) + opt <- stats[stats$SABIC == min, ]$n_factors[!is.na(stats[stats$SABIC == min, ]$n_factors)] + results <- rbind( + results, + data.frame( + Method = c("Sample Size Adjusted BIC"), + n_optimal = c(opt) + ) + ) + } + + + cfits <- vss[grep("cfit", names(vss))] + for (name in names(cfits)) { + cfit <- cfits[[name]] + + cfit <- data.frame(cfit = cfit, n_factors = seq_len(length(cfit))) + + result3 <- data.frame( + Method = c(gsub("cfit.", "VSS Complexity ", name)), + n_optimal = c(na.omit(cfit[cfit$cfit == max(cfit$cfit, na.rm = TRUE), ])$n_factors) + ) + + results <- rbind(results, result3) + } + + + eigenvalues <- results %>% + group_by_("n_optimal") %>% + summarise_("n_method" = ~ n()) %>% + mutate_("n_optimal" = ~ factor(n_optimal, levels = seq_len(nrow(eigenvalues)))) %>% + complete_("n_optimal", fill = list(n_method = 0)) %>% + arrange_("n_optimal") %>% + rename_( + "n.Factors" = "n_optimal", + "n.Methods" = "n_method" + ) %>% + mutate_("n.Factors" = ~ as.integer(n.Factors)) %>% + left_join(eigenvalues, by = "n.Factors") %>% + select_("-Exp.Variance") + + + # Summary + # ------------- + summary <- eigenvalues + + # Values + # ------------- + + best_n_df <- filter_(summary, "n.Methods == max(n.Methods)") + best_n <- best_n_df$n.Factors + + best_n_methods <- list() + for (i in as.list(best_n)) { + methods_list <- results[results$n_optimal %in% as.list(i), ] + methods_list <- as.character(methods_list$Method) + best_n_methods[[paste0("n_", i)]] <- paste(methods_list, collapse = ", ") + } + + + + values <- list(summary = summary, methods = results, best_n_df = best_n) + + + + # Text + # ------------- + # Deal with equality + if (length(best_n) > 1) { + best_n <- head(best_n, length(best_n) - 1) %>% + paste(collapse = ", ") %>% + paste(best_n[length(best_n)], sep = " and ") + factor_text <- " factors " + n_methods <- unique(best_n_df$n.Methods) + best_n_methods <- paste0(paste(best_n_methods, collapse = "; "), "; respectively") + } else { + n_methods <- best_n_df$n.Methods + # Plural + if (best_n == 1) { + factor_text <- " factor " + } else { + factor_text <- " factors " + } + } + + + + text <- paste0( + "The choice of ", + best_n, + factor_text, + "is supported by ", + n_methods, + " (out of ", + round(nrow(results)), + "; ", + round(n_methods / nrow(results) * 100, 2), + "%) methods (", + best_n_methods, + ")." + ) + + + # Plot + # ------------- + plot_data <- summary + plot_data$n.Methods.Ratio <- plot_data$n.Methods / sum(plot_data$n.Methods) + plot_data$n.Methods.Ratio <- plot_data$n.Methods.Ratio * (1 / max(plot_data$n.Methods.Ratio)) + plot_data$area <- plot_data$n.Methods.Ratio / (max(plot_data$n.Methods.Ratio) / max(plot_data$Eigenvalues)) + plot_data$var <- plot_data$Cum.Variance / (max(plot_data$Cum.Variance) / max(plot_data$Eigenvalues)) + + plot <- plot_data %>% + ggplot(aes_string(x = "n.Factors", y = "Eigenvalues")) + + geom_area( + aes_string(y = "area"), + fill = "#FFC107", + alpha = 0.5 + ) + + geom_line( + colour = "#E91E63", + size = 1 + ) + + geom_hline(yintercept = 1, linetype = "dashed", colour = "#607D8B") + + geom_line( + aes_string(y = "var"), + colour = "#2196F3", + size = 1 + ) + + scale_y_continuous(sec.axis = sec_axis( + trans = ~ . * (max(plot_data$Cum.Variance) / max(plot_data$Eigenvalues)), + name = "Cumulative Variance\n" + )) + + ylab("Eigenvalues\n") + + xlab("\nNumber of Factors") + + theme_minimal() + + # Output + # ------------- + output <- list(text = text, plot = plot, summary = summary, values = values) + + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + +#' Convert (log)odds to probabilies. +#' +#' @param odds Odds values in vector or dataframe. +#' @param subset Character or list of characters of column names to be +#' transformed. +#' @param except Character or list of characters of column names to be excluded +#' from transformation. +#' @param log Are these Log odds (such as in logistic models)? +#' +#' @examples +#' library(psycho) +#' odds_to_probs(-1.45) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom purrr keep discard +#' @export +odds_to_probs <- function(odds, subset = NULL, except = NULL, log = TRUE) { + + # If vector + if (ncol(as.matrix(odds)) == 1) { + return(.odds_to_probs(odds, log = log)) + } else { + df <- odds + } + + # Variable order + var_order <- names(df) + + # Keep subset + if (!is.null(subset) && subset %in% names(df)) { + to_keep <- as.data.frame(df[!names(df) %in% c(subset)]) + df <- df[names(df) %in% c(subset)] + } else { + to_keep <- NULL + } + + # Remove exceptions + if (!is.null(except) && except %in% names(df)) { + if (is.null(to_keep)) { + to_keep <- as.data.frame(df[except]) + } else { + to_keep <- cbind(to_keep, as.data.frame(df[except])) + } + + df <- df[!names(df) %in% c(except)] + } + + # Remove non-numerics + dfother <- purrr::discard(df, is.numeric) + dfnum <- purrr::keep(df, is.numeric) + + # Tranform + dfnum <- .odds_to_probs(dfnum, log = log) + + # Add non-numerics + if (is.null(ncol(dfother))) { + df <- dfnum + } else { + df <- dplyr::bind_cols(dfother, dfnum) + } + + # Add exceptions + if (!is.null(subset) | !is.null(except) && exists("to_keep")) { + df <- dplyr::bind_cols(df, to_keep) + } + + # Reorder + df <- df[var_order] + + return(df) +} + + +#' @keywords internal +.odds_to_probs <- function(odds, log = TRUE) { + if (log == TRUE) { + odds <- exp(odds) + } + probs <- odds / (1 + odds) + return(probs) +} + + + + + + + + +#' Overlap of Two Empirical Distributions. +#' +#' A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). +#' +#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). +#' @param y Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. +#' @param method Method of AUC computation. Can be "trapezoid" (default), "step" or "spline". +#' +#' @examples +#' library(psycho) +#' +#' x <- rnorm(100, 1, 0.5) +#' y <- rnorm(100, 0, 1) +#' overlap(x, y) +#' @author S. Venne +#' +#' @importFrom stats density +#' @importFrom DescTools AUC +#' @export +overlap <- function(x, y, method = "trapezoid") { + # define limits of a common grid, adding a buffer so that tails aren't cut off + lower <- min(c(x, y)) - 1 + upper <- max(c(x, y)) + 1 + + # generate kernel densities + da <- stats::density(x, from = lower, to = upper) + db <- stats::density(y, from = lower, to = upper) + d <- data.frame(x = da$x, a = da$y, b = db$y) + + # calculate intersection densities + d$w <- pmin(d$a, d$b) + + # integrate areas under curves + total <- DescTools::AUC(d$x, d$a, method = method) + DescTools::AUC(d$x, d$b, method = method) + intersection <- DescTools::AUC(d$x, d$w, method = method) + + # compute overlap coefficient + overlap <- 2 * intersection / total + return(overlap) +} + + + + + + + + + + + +#' Transform z score to percentile. +#' +#' @param z_score Z score. +#' +#' @examples +#' library(psycho) +#' percentile(-1.96) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats pnorm +#' @export +percentile <- function(z_score) { + perc <- pnorm(z_score) * 100 + return(perc) +} + + + +#' Transform a percentile to a z score. +#' +#' @param percentile Percentile +#' +#' @examples +#' library(psycho) +#' percentile_to_z(95) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats pnorm +#' @export +percentile_to_z <- function(percentile) { + z <- qnorm(percentile / 100) + return(z) +} + + + + + + + + + + + +#' Plot the results. +#' +#' @param x A psychobject class object. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +plot.psychobject <- function(x, ...) { + plot <- x$plot + return(plot) +} + + + + + + + + + + + +#' Power analysis for fitted models. +#' +#' Compute the n models based on n sampling of data. +#' +#' @param fit A lm or stanreg model. +#' @param n_max Max sample size. +#' @param n_min Min sample size. If null, take current nrow. +#' @param step Increment of the sequence. +#' @param n_batch Number of iterations at each sample size. +#' @param groups Grouping variable name (string) to preserve proportions. Can be a list of strings. +#' @param verbose Print progress. +#' @param CI Argument for \link[=analyze]{analyze}. +#' @param effsize Argument for \link[=analyze]{analyze}. +#' @param effsize_rules Argument for \link[=analyze]{analyze}. +#' @param bayes_factor Argument for \link[=analyze]{analyze}. +#' @param overlap rgument for \link[=analyze]{analyze}. +#' +#' @return A dataframe containing the summary of all models for all iterations. +#' +#' @examples +#' \dontrun{ +#' library(dplyr) +#' library(psycho) +#' +#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) +#' +#' results <- power_analysis(fit, n_max = 300, n_min = 100, step = 5, n_batch = 20) +#' +#' results %>% +#' filter(Variable == "Sepal.Width") %>% +#' select(n, p) %>% +#' group_by(n) %>% +#' summarise( +#' p_median = median(p), +#' p_mad = mad(p) +#' ) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats model.frame +#' @import dplyr +#' @export +power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, groups = NULL, verbose = TRUE, CI = 90, effsize = FALSE, effsize_rules = "cohen1988", bayes_factor = FALSE, overlap = FALSE) { + + # Parameters + df <- model.frame(fit) + + if (is.null(n_min)) { + n_min <- nrow(df) + } + + + results <- data.frame() + for (n in seq(n_min, n_max, step)) { + for (batch in 1:n_batch) { + + # Progress + if (verbose == TRUE) { + cat(".") + } + + + # Sample data.frame + if (!is.null(groups)) { + newdf <- df %>% + group_by_(groups) %>% + dplyr::sample_frac(n / nrow(df), replace = TRUE) + } else { + newdf <- dplyr::sample_frac(df, n / nrow(df), replace = TRUE) + } + + # Fit new model + newfit <- update(fit, data = newdf) + newfit <- analyze(newfit, CI = CI, effsize = effsize, bayes_factor = bayes_factor, overlap = overlap, effsize_rules = effsize_rules) + + # Store results + newresults <- summary(newfit) + newresults$n <- n + newresults$batch <- batch + results <- rbind(results, newresults) + } + # Progress + if (verbose == TRUE) { + cat(paste0(format_digit(round((n - n_min) / (n_max - n_min) * 100)), "%\n")) + } + } + return(results) +} + + + + + + + + + + + +#' Print the results. +#' +#' @param x A psychobject class object. +#' @param ... Further arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +print.psychobject <- function(x, ...) { + text <- x$text + cat(text, sep = "\n") + invisible(text) +} + + + + + + + + + +#' Convert probabilities to (log)odds. +#' +#' @param probs Probabilities values in vector or dataframe. +#' @param log Compute log odds (such as in logistic models)? +#' +#' @examples +#' library(psycho) +#' probs_to_odds(0.75) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +probs_to_odds <- function(probs, log = FALSE) { + + # If vector + if (ncol(as.matrix(probs)) == 1) { + return(.probs_to_odds(probs, log = log)) + } else { + warning("Provide single value or vector.") + } +} + + +#' @keywords internal +.probs_to_odds <- function(probs, log = FALSE) { + odds <- probs / (1 - probs) + if (log == TRUE) { + odds <- log(odds) + } + return(odds) +} + + + + + + diff --git a/R/dprime.R b/R/dprime.R deleted file mode 100644 index 18bb257..0000000 --- a/R/dprime.R +++ /dev/null @@ -1,131 +0,0 @@ -#' Dprime and Other Signal Detection Theory indices. -#' -#' Computes Signal Detection Theory indices (d', beta, A', B''D, c). -#' -#' @param n_hit Number of hits. -#' @param n_fa Number of false alarms. -#' @param n_miss Number of misses. -#' @param n_cr Number of correct rejections. -#' @param n_targets Number of targets (n_hit + n_miss). -#' @param n_distractors Number of distractors (n_fa + n_cr). -#' @param adjusted Should it use the Hautus (1995) adjustments for extreme values. -#' -#' @return Calculates the d', the beta, the A' and the B''D based on the signal detection theory (SRT). See Pallier (2002) for the algorithms. -#' -#' Returns a list containing the following indices: -#' \itemize{ -#' \item{\strong{dprime (d')}: }{The sensitivity. Reflects the distance between the two distributions: signal, and signal+noise and corresponds to the Z value of the hit-rate minus that of the false-alarm rate.} -#' \item{\strong{beta}: }{The bias (criterion). The value for beta is the ratio of the normal density functions at the criterion of the Z values used in the computation of d'. This reflects an observer's bias to say 'yes' or 'no' with the unbiased observer having a value around 1.0. As the bias to say 'yes' increases (liberal), resulting in a higher hit-rate and false-alarm-rate, beta approaches 0.0. As the bias to say 'no' increases (conservative), resulting in a lower hit-rate and false-alarm rate, beta increases over 1.0 on an open-ended scale.} -#' \item{\strong{c}: }{Another index of bias. the number of standard deviations from the midpoint between these two distributions, i.e., a measure on a continuum from "conservative" to "liberal".} -#' \item{\strong{aprime (A')}: }{Non-parametric estimate of discriminability. An A' near 1.0 indicates good discriminability, while a value near 0.5 means chance performance.} -#' \item{\strong{bppd (B''D)}: }{Non-parametric estimate of bias. A B''D equal to 0.0 indicates no bias, positive numbers represent conservative bias (i.e., a tendency to answer 'no'), negative numbers represent liberal bias (i.e. a tendency to answer 'yes'). The maximum absolute value is 1.0.} -#' } -#' -#' -#' Note that for d' and beta, adjustement for extreme values are made following the recommandations of Hautus (1995). - - -#' @examples -#' library(psycho) -#' -#' n_hit <- 9 -#' n_fa <- 2 -#' n_miss <- 1 -#' n_cr <- 7 -#' -#' indices <- psycho::dprime(n_hit, n_fa, n_miss, n_cr) -#' -#' -#' df <- data.frame( -#' Participant = c("A", "B", "C"), -#' n_hit = c(1, 2, 5), -#' n_fa = c(6, 8, 1) -#' ) -#' -#' indices <- psycho::dprime( -#' n_hit = df$n_hit, -#' n_fa = df$n_fa, -#' n_targets = 10, -#' n_distractors = 10, -#' adjusted = FALSE -#' ) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats qnorm -#' @export -dprime <- function(n_hit, n_fa, n_miss = NULL, n_cr = NULL, n_targets = NULL, n_distractors = NULL, adjusted = TRUE) { - if (is.null(n_targets)) { - n_targets <- n_hit + n_miss - } - - if (is.null(n_distractors)) { - n_distractors <- n_fa + n_cr - } - - - # Parametric Indices ------------------------------------------------------ - - - if (adjusted == TRUE) { - if (is.null(n_miss) | is.null(n_cr)) { - warning("Please provide n_miss and n_cr in order to compute adjusted ratios. Computing indices anyway with non-adjusted ratios...") - - # Non-Adjusted ratios - hit_rate_adjusted <- n_hit / n_targets - fa_rate_adjusted <- n_fa / n_distractors - } else { - # Adjusted ratios - hit_rate_adjusted <- (n_hit + 0.5) / ((n_hit + 0.5) + n_miss + 1) - fa_rate_adjusted <- (n_fa + 0.5) / ((n_fa + 0.5) + n_cr + 1) - } - - # dprime - dprime <- qnorm(hit_rate_adjusted) - qnorm(fa_rate_adjusted) - - # beta - zhr <- qnorm(hit_rate_adjusted) - zfar <- qnorm(fa_rate_adjusted) - beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) - - # c - c <- -(qnorm(hit_rate_adjusted) + qnorm(fa_rate_adjusted)) / 2 - } else { - # Ratios - hit_rate <- n_hit / n_targets - fa_rate <- n_fa / n_distractors - - # dprime - dprime <- qnorm(hit_rate) - qnorm(fa_rate) - - # beta - zhr <- qnorm(hit_rate) - zfar <- qnorm(fa_rate) - beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) - - # c - c <- -(qnorm(hit_rate) + qnorm(fa_rate)) / 2 - } - - # Non-Parametric Indices ------------------------------------------------------ - - # Ratios - hit_rate <- n_hit / n_targets - fa_rate <- n_fa / n_distractors - - # aprime - a <- 1 / 2 + ((hit_rate - fa_rate) * (1 + hit_rate - fa_rate) / (4 * hit_rate * (1 - fa_rate))) - b <- 1 / 2 - ((fa_rate - hit_rate) * (1 + fa_rate - hit_rate) / (4 * fa_rate * (1 - hit_rate))) - - a[fa_rate > hit_rate] <- b[fa_rate > hit_rate] - a[fa_rate == hit_rate] <- .5 - aprime <- a - - # bppd - bppd <- (hit_rate * (1 - hit_rate) - fa_rate * (1 - fa_rate)) / (hit_rate * (1 - hit_rate) + fa_rate * (1 - fa_rate)) - bppd_b <- (fa_rate * (1 - fa_rate) - hit_rate * (1 - hit_rate)) / (fa_rate * (1 - fa_rate) + hit_rate * (1 - hit_rate)) - bppd[fa_rate > hit_rate] <- bppd_b[fa_rate > hit_rate] - - - - return(list(dprime = dprime, beta = beta, aprime = aprime, bppd = bppd, c = c)) -} diff --git a/R/find_best_model.R b/R/find_best_model.R deleted file mode 100644 index 8b98e0d..0000000 --- a/R/find_best_model.R +++ /dev/null @@ -1,20 +0,0 @@ -#' Returns the best model. -#' -#' Returns the best model. See the -#' documentation for your model's class: -#' \itemize{ -#' \item{\link[=find_best_model.stanreg]{find_best_model.stanreg}} -#' \item{\link[=find_best_model.lmerModLmerTest]{find_best_model.lmerModLmerTest}} -#' } -#' -#' @param fit Model -#' @param ... Arguments passed to or from other methods. -#' -#' @seealso \code{\link{find_best_model.stanreg}} -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_best_model <- function(fit, ...) { - UseMethod("find_best_model") -} diff --git a/R/find_best_model.lavaan.R b/R/find_best_model.lavaan.R deleted file mode 100644 index 1be31ba..0000000 --- a/R/find_best_model.lavaan.R +++ /dev/null @@ -1,92 +0,0 @@ -#' Returns all combinations of lavaan models with their indices of fit. -#' -#' Returns all combinations of lavaan models with their indices of fit. -#' -#' @param fit A lavaan object. -#' @param latent Copy/paste the part related to latent variables loadings. -#' @param samples Number of random draws. -#' @param verbose Show progress. -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' library(psycho) -#' library(lavaan) -#' -#' model <- " visual =~ x1 + x2 + x3 -#' textual =~ x4 + x5 + x6 -#' speed =~ x7 + x8 + x9 -#' visual ~ textual -#' textual ~ speed" -#' fit <- lavaan::sem(model, data = HolzingerSwineford1939) -#' -#' models <- find_best_model(fit, latent = "visual =~ x1 + x2 + x3 -#' textual =~ x4 + x5 + x6 -#' speed =~ x7 + x8 + x9") -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' -#' @method find_best_model lavaan -#' @export -find_best_model.lavaan <- function(fit, latent = "", samples = 1000, verbose = FALSE, ...) { - update_model <- function(fit, latent, model) { - newfit <- update(fit, paste0(latent, "\n", model)) - - indices <- data.frame(Value = lavaan::fitMeasures(newfit)) %>% - tibble::rownames_to_column("Index") %>% - tidyr::spread_("Index", "Value") %>% - cbind(data.frame( - model = model, - n_links = nrow(lavaan::lavInspect(fit, "est")$beta) - )) - return(indices) - } - - vars <- row.names(lavaan::lavInspect(fit, "est")$beta) - # info <- fit@Model - - data <- data.frame() - for (outcome in vars) { - remaning_vars <- vars[!stringr::str_detect(vars, outcome)] - combinations <- c() - for (y in 1:length(remaning_vars)) { - combinations <- c(combinations, combn(remaning_vars, y, simplify = FALSE)) - } - combinations <- sapply(combinations, paste0, collapse = "+") - combinations <- paste0(outcome, "~", combinations) - x <- data.frame(A = combinations) - names(x) <- c(outcome) - if (nrow(data) == 0) { - data <- x - } else { - data <- cbind(data, x) - } - } - - data <- rbind(data, head(data[NA, ], 1)) - data[] <- lapply(data, as.character) - data[is.na(data)] <- "" - rownames(data) <- NULL - - out <- data.frame() - for (i in 1:samples) { - if (verbose == TRUE) { - cat(".") - } - model <- "" - for (var in names(data)) { - model <- paste0(model, sample(data[[var]], 1), "\n") - } - - if (!model %in% out$model) { - out <- tryCatch( - rbind(out, update_model(fit, latent, model)), - error = function(e) out, - warning = function(w) out - ) - } - } - return(out) -} diff --git a/R/find_best_model.lmerModLmerTest.R b/R/find_best_model.lmerModLmerTest.R deleted file mode 100644 index 5778f1f..0000000 --- a/R/find_best_model.lmerModLmerTest.R +++ /dev/null @@ -1,91 +0,0 @@ -#' Returns the best combination of predictors for lmerTest objects. -#' -#' Returns the best combination of predictors for lmerTest objects. -#' -#' @param fit A merModLmerTest object. -#' @param interaction Include interaction term. -#' @param fixed Additional formula part to add at the beginning of -#' each formula -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(lmerTest) -#' -#' data <- standardize(iris) -#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = data) -#' -#' best <- find_best_model(fit) -#' best_formula <- best$formula -#' best$table -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats update -#' @import dplyr -#' -#' @method find_best_model lmerModLmerTest -#' @export -find_best_model.lmerModLmerTest <- function(fit, interaction = TRUE, fixed = NULL, ...) { - - # Extract infos - combinations <- find_combinations(as.formula(get_formula(fit)), interaction = interaction, fixed = fixed) - - - # Recreating the dataset without NA - dataComplete <- fit@frame[complete.cases(fit@frame), ] - - - # fit models - models <- c() - for (formula in combinations) { - newfit <- update(fit, formula, data = dataComplete) - models <- c(models, newfit) - } - - - # No warning messages for this part - options(warn = -1) - - # Model comparison - comparison <- as.data.frame(do.call("anova", models)) - - # Re-displaying warning messages - options(warn = 0) - - # Creating row names to the combinations array equivalent to the comparison data frame - combinations <- as.data.frame(combinations, row.names = paste0("MODEL", seq(1, length(combinations)))) - - # Reordering the rows in the same way for both combinations and comparison before implementing the formulas - comparison <- comparison[ order(row.names(comparison)), ] - comparison$formula <- combinations[order(row.names(combinations)), ] - - # Sorting the data frame by the AIC then BIC - comparison <- comparison[order(comparison$AIC, comparison$BIC), ] - - - - # Best model by criterion - best_aic <- dplyr::arrange_(comparison, "AIC") %>% - dplyr::select_("formula") %>% - head(1) - best_aic <- as.character(best_aic[[1]]) - - best_bic <- dplyr::arrange_(comparison, "BIC") %>% - dplyr::select_("formula") %>% - head(1) - best_bic <- as.character(best_bic[[1]]) - - by_criterion <- data.frame(formula = c(best_aic, best_bic), criterion = c("AIC", "BIC")) - - # Best formula - best <- table(by_criterion$formula) - best <- names(best[which.max(best)]) - - best <- list(formula = best, by_criterion = by_criterion, table = comparison) - return(best) -} diff --git a/R/find_best_model.stanreg.R b/R/find_best_model.stanreg.R deleted file mode 100644 index 9c807da..0000000 --- a/R/find_best_model.stanreg.R +++ /dev/null @@ -1,139 +0,0 @@ -#' Returns the best combination of predictors based on LOO cross-validation indices. -#' -#' Returns the best combination of predictors based on LOO cross-validation indices. -#' -#' @param fit A stanreg object. -#' @param interaction Include interaction term. -#' @param fixed Additional formula part to add at the beginning of -#' each formula -#' @param K For kfold, the number of subsets of equal (if possible) size into -#' which the data will be randomly partitioned for performing K-fold -#' cross-validation. The model is refit K times, each time leaving out one of -#' the K subsets. If K is equal to the total number of observations in the data -#' then K-fold cross-validation is equivalent to exact leave-one-out -#' cross-validation. -#' @param k_treshold Threshold for flagging estimates of the Pareto shape -#' parameters k estimated by loo. -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' data <- standardize(attitude) -#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) -#' -#' best <- find_best_model(fit) -#' best_formula <- best$formula -#' best$table -#' -#' # To deactivate Kfold evaluation -#' best <- find_best_model(fit, K = 0) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom rstanarm loo kfold bayes_R2 -#' @importFrom stats update median -#' @import dplyr -#' -#' @method find_best_model stanreg -#' @export -find_best_model.stanreg <- function(fit, interaction = TRUE, fixed = NULL, K = 10, k_treshold = NULL, ...) { - - # Extract infos - combinations <- find_combinations(fit$formula, interaction = interaction, fixed = fixed) - - # Compute fitting indices - loos <- list() - kfolds <- list() - complexities <- list() - R2s <- list() - for (i in seq_len(length(combinations))) { - print(paste0(i, "/", length(combinations))) - - formula <- combinations[i] - newfit <- update(fit, formula = formula, verbose = FALSE) - R2s[[formula]] <- median(rstanarm::bayes_R2(newfit)) - - - if (!is.null(k_treshold)) { - loo <- rstanarm::loo(newfit, k_treshold = k_treshold) - } else { - loo <- rstanarm::loo(newfit) - } - - - complexities[[formula]] <- length(newfit$coefficients) - loos[[formula]] <- loo - if (K > 1) { - kfold <- rstanarm::kfold(newfit, K = K) - } else { - kfold <- list(elpd_kfold = 0, se_elpd_kfold = 0) - } - kfolds[[formula]] <- kfold - } - - # Model comparison - comparison <- data.frame() - for (formula in names(loos)) { - loo <- loos[[formula]] - kfold <- kfolds[[formula]] - complexity <- complexities[[formula]] - Estimates <- loo[["estimates"]] - model <- data.frame( - formula = formula, - complexity = complexity - 1, - R2 = R2s[[formula]], - looic = Estimates["looic", "Estimate"], - looic_se = Estimates["looic", "SE"], - elpd_loo = Estimates["elpd_loo", "Estimate"], - elpd_loo_se = Estimates["elpd_loo", "SE"], - p_loo = Estimates["p_loo", "Estimate"], - p_loo_se = Estimates["p_loo", "SE"], - elpd_kfold = Estimates["p_loo", "Estimate"], - elpd_kfold_se = Estimates["p_loo", "SE"] - ) - comparison <- rbind(comparison, model) - } - - # Format - comparison <- comparison %>% - dplyr::mutate_( - "looic_d" = "looic - min(looic)", - "elpd_loo_d" = "elpd_loo - max(elpd_loo)", - "elpd_kfold_d" = "elpd_kfold - max(elpd_kfold)" - ) - - # Best model by criterion - best_looic <- dplyr::arrange_(comparison, "looic") %>% - dplyr::select_("formula") %>% - head(1) - best_looic <- as.character(best_looic[[1]]) - - best_elpd_loo <- dplyr::arrange_(comparison, "desc(elpd_loo)") %>% - dplyr::select_("formula") %>% - head(1) - best_elpd_loo <- as.character(best_elpd_loo[[1]]) - - if (K > 1) { - best_elpd_kfold <- dplyr::arrange_(comparison, "desc(elpd_kfold)") %>% - dplyr::select_("formula") %>% - head(1) - best_elpd_kfold <- as.character(best_elpd_kfold[[1]]) - } else { - best_elpd_kfold <- NA - } - - by_criterion <- data.frame(formula = c(best_looic, best_elpd_loo, best_elpd_kfold), criterion = c("looic", "elpd_loo", "elpd_kfold")) - - # Best formula - best <- table(by_criterion$formula) - best <- names(best[which.max(best)]) - - best <- list(formula = best, by_criterion = by_criterion, table = comparison) - return(best) -} diff --git a/R/find_combinations.R b/R/find_combinations.R deleted file mode 100644 index 8915ad6..0000000 --- a/R/find_combinations.R +++ /dev/null @@ -1,104 +0,0 @@ -#' Generate all combinations. -#' -#' Generate all combinations. -#' -#' @param object Object -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_combinations <- function(object, ...) { - UseMethod("find_combinations") -} - - - - - - - - - - - - - - -#' Generate all combinations of predictors of a formula. -#' -#' Generate all combinations of predictors of a formula. -#' -#' @param object Formula. -#' @param interaction Include interaction term. -#' @param fixed Additional formula part to add at the beginning of -#' each combination. -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' library(psycho) -#' -#' f <- as.formula("Y ~ A + B + C + D") -#' f <- as.formula("Y ~ A + B + C + D + (1|E)") -#' f <- as.formula("Y ~ A + B + C + D + (1|E) + (1|F)") -#' -#' find_combinations(f) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @method find_combinations formula -#' @importFrom utils combn -#' @importFrom stats terms -#' @export -find_combinations.formula <- function(object, interaction = TRUE, fixed = NULL, ...) { - - # Extract infos - formula <- object - vars <- attributes(terms(formula))$term.labels - outcome <- all.vars(formula)[1] - pred <- vars[!grepl("\\|", vars)] - if (length(vars[grepl("\\|", vars)]) > 0) { - random <- paste0(" + (", vars[grepl("\\|", vars)], ")") - } else { - random <- "" - } - - if (is.null(fixed)) { - fixed <- "" - } else { - fixed <- fixed - } - - # Generate combinations - n <- length(pred) - - id <- unlist( - lapply( - 1:n, - function(i) combn(1:n, i, simplify = FALSE) - ), - recursive = FALSE - ) - - combinations <- sapply(id, function(i) - paste(paste(pred[i], collapse = " + "))) - - - # Generate interactions - if (interaction == TRUE) { - for (comb in combinations) { - n_signs <- stringr::str_count(comb, "\\+") - if (n_signs > 0) { - new_formula <- comb - for (i in 1:n_signs) { - new_formula <- stringr::str_replace(new_formula, "\\+", "*") - combinations <- c(combinations, new_formula) - } - } - } - } - - combinations <- paste0(outcome, " ~ ", fixed, combinations, paste0(random, collapse = "")) - return(combinations) -} diff --git a/R/find_distance_cluster.R b/R/find_distance_cluster.R deleted file mode 100644 index d5cdc89..0000000 --- a/R/find_distance_cluster.R +++ /dev/null @@ -1,27 +0,0 @@ -#' Find the distance of a point with its kmean cluster. -#' -#' Find the distance of a point with its kmean cluster. -#' -#' @param df Data -#' @param km kmean object. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_distance_cluster <- function(df, km) { - myDist <- function(p1, p2) sqrt((p1[, 1] - p2[, 1])^2 + (p1[, 2] - p2[, 2])^2) - - data <- df %>% - as.data.frame() %>% - select(one_of(colnames(km$centers))) - - n_clusters <- nrow(km$centers) - - data$Distance <- NA - for (clust in 1:n_clusters) { - data$Distance[km$cluster == clust] <- myDist(data[km$cluster == clust, ], km$centers[clust, , drop = FALSE]) - } - - return(data$Distance) -} diff --git a/R/find_highest_density_point.R b/R/find_highest_density_point.R deleted file mode 100644 index e455319..0000000 --- a/R/find_highest_density_point.R +++ /dev/null @@ -1,18 +0,0 @@ -#' Find the Highest Density Point. -#' -#' Returns the Highest Density Point. -#' -#' @param x Vector. -#' @param precision Number of points in density. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_highest_density_point <- function(x, precision = 1e+03) { - d <- x %>% - density(n = precision) %>% - as.data.frame() - y <- d$x[which.max(d$y)] - return(y) -} diff --git a/R/find_matching_string.R b/R/find_matching_string.R deleted file mode 100644 index 9b965d0..0000000 --- a/R/find_matching_string.R +++ /dev/null @@ -1,33 +0,0 @@ -#' Fuzzy string matching. -#' -#' @param x Strings. -#' @param y List of strings to be matched. -#' @param value Return value or the index of the closest string. -#' @param step Step by which decrease the distance. -#' @param ignore.case if FALSE, the pattern matching is case sensitive and if TRUE, case is ignored during matching. -#' -#' @examples -#' library(psycho) -#' find_matching_string("Hwo rea ouy", c("How are you", "Not this word", "Nice to meet you")) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_matching_string <- function(x, y, value = TRUE, step = 0.1, ignore.case = TRUE) { - z <- c() - for (i in seq_len(length(x))) { - s <- x[i] - distance <- 0.99 - closest <- agrep(s, y, max.distance = distance, value = value, ignore.case = ignore.case) - - while (length(closest) != 1) { - closest <- agrep(s, closest, max.distance = distance, value = value, ignore.case = ignore.case) - distance <- distance - step - if (distance < 0) { - warning(paste0("Couldn't find matching string for '", s, "'. Try lowering the step parameter.")) - closest <- s - } - } - z <- c(z, closest) - } - return(z) -} diff --git a/R/find_random_effects.R b/R/find_random_effects.R deleted file mode 100644 index 1c05da0..0000000 --- a/R/find_random_effects.R +++ /dev/null @@ -1,19 +0,0 @@ -#' Find random effects in formula. -#' -#' @param formula Formula - -#' @examples -#' library(psycho) -#' find_random_effects("Y ~ X + (1|Group)") -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stringr str_remove_all -#' @importFrom lme4 findbars -#' @export -find_random_effects <- function(formula) { - random <- lme4::findbars(as.formula(formula)) - random <- paste0("(", random, ")") - random <- stringr::str_remove_all(random, " ") - random <- paste(random, collapse = " + ") - return(random) -} diff --git a/R/find_season.R b/R/find_season.R deleted file mode 100644 index 84e70e7..0000000 --- a/R/find_season.R +++ /dev/null @@ -1,39 +0,0 @@ -#' Find season of dates. -#' -#' Returns the season of an array of dates. -#' -#' @param dates Array of dates. -#' @param winter month-day of winter solstice. -#' @param spring month-day of spring equinox. -#' @param summer month-day of summer solstice. -#' @param fall month-day of fall equinox. -#' -#' @return season -#' -#' @examples -#' library(psycho) -#' -#' dates <- c("2012-02-15", "2017-05-15", "2009-08-15", "1912-11-15") -#' find_season(dates) -#' @author Josh O'Brien -#' -#' @seealso -#' https://stackoverflow.com/questions/9500114/find-which-season-a-particular-date-belongs-to -#' -#' @export -find_season <- function(dates, winter = "12-21", spring = "3-20", summer = "6-21", fall = "9-22") { - WS <- as.Date(paste0("2012-", winter), format = "%Y-%m-%d") # Winter Solstice - SE <- as.Date(paste0("2012-", spring), format = "%Y-%m-%d") # Spring Equinox - SS <- as.Date(paste0("2012-", summer), format = "%Y-%m-%d") # Summer Solstice - FE <- as.Date(paste0("2012-", fall), format = "%Y-%m-%d") # Fall Equinox - - # Convert dates from any year to 2012 dates - d <- as.Date(strftime(as.character(dates), format = "2012-%m-%d")) - - season <- ifelse(d >= WS | d < SE, "Winter", - ifelse(d >= SE & d < SS, "Spring", - ifelse(d >= SS & d < FE, "Summer", "Fall") - ) - ) - return(season) -} diff --git a/R/format_digit.R b/R/format_digit.R new file mode 100644 index 0000000..2ecb090 --- /dev/null +++ b/R/format_digit.R @@ -0,0 +1,18 @@ +#' Formatting +#' +#' @param x number. +#' @param digits number of significant digits. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @examples +#' +#' format_digit(1.20) +#' format_digit(1.2) +#' format_digit(1.2012313) +#' format_digit(0.0045) +#' +#' @export +format_digit <- function(x, digits=2){ + return(trimws(format(round(x, digits), nsmall = digits))) +} diff --git a/R/formatting.R b/R/formatting.R deleted file mode 100644 index 0bf7691..0000000 --- a/R/formatting.R +++ /dev/null @@ -1,144 +0,0 @@ -#' Format digits. -#' -#' @param x A digit. -#' @param digits Number of significant digits. -#' @param null_treshold Treshold below which return 0. -#' @param inf_treshold Treshold above which return Inf. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -format_digit <- function(x, digits = 2, null_treshold = 0.001, inf_treshold = 9e+8) { - if (length(x) > 1) { - return(sapply(x, .format_digit, digits = digits, null_treshold = null_treshold, inf_treshold = inf_treshold)) - } else { - return(.format_digit(x, digits = digits, null_treshold = null_treshold, inf_treshold = inf_treshold)) - } -} - - - -#' @keywords internal -.format_digit <- function(x, digits = 2, null_treshold = 0.001, inf_treshold = 9e+8) { - - # if x is NA - if (is.na(x)) { - return("NA") - } - - # if x is inf - if (x > inf_treshold) { - return("Inf.") - } - - # If x is an Integer - if (all(x == as.integer(x))) { - formatted <- as.character(x) - } else { - # If x is close to zero - if (abs(x) < null_treshold) { - formatted <- "0" - } else { - x <- round(x, digits = 15) # Prevent edge cases where x is really close to 1 - # If x is close to trailing zeros - if (abs(x) < 1) { - formatted <- as.character(signif(x, digits)) - # If signif cut off trailing zero, add it - # TODO: that line of code is ugly - if (nchar(gsub("0|-|\\.", "", formatted)) < digits) { - formatted <- paste0(formatted, strrep("0", digits - 1)) - } - } else { - formatted <- format_string(round(x, digits), paste0("%.", digits, "f")) - } - } - } - return(formatted) -} - - -#' Tidyverse-friendly sprintf. -#' -#' @param x Values. -#' @param fmt A character vector of format strings, each of up to 8192 bytes. -#' @param ... values to be passed into fmt. Only logical, integer, real and -#' character vectors are supported, but some coercion will be done: see the ‘Details’ section. Up to 100. -#' -#' @export -format_string <- function(x, fmt, ...) { - x <- sprintf(fmt, x, ...) - return(x) -} - - - - - - -#' Format p values. -#' -#' @param pvalues p values (scalar or vector). -#' @param stars Add significance stars. -#' @param stars_only Return only significance stars. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stringr str_remove_all -#' @export -format_p <- function(pvalues, stars = TRUE, stars_only=FALSE) { - p <- ifelse(pvalues < 0.001, "< .001***", - ifelse(pvalues < 0.01, "< .01**", - ifelse(pvalues < 0.05, "< .05*", - ifelse(pvalues < 0.1, paste0("= ", round(pvalues, 2), "\xB0"), - "> .1" - ) - ) - ) - ) - - if (stars_only == TRUE) { - p <- stringr::str_remove_all(p, "[^\\*]") - } else { - if (stars == FALSE) { - p <- stringr::str_remove_all(p, "\\*") - } - } - - return(p) -} - - - - - - - - -#' Clean and format formula. -#' -#' Clean and format formula. -#' -#' @param formula formula -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' fit <- lm(hp ~ wt, data = mtcars) -#' -#' format_formula(get_formula(fit)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -format_formula <- function(formula) { - formula <- tryCatch({ - stringr::str_squish(paste(format(eval(formula)), collapse = "")) - }, error = function(e) { - formula <- stringr::str_squish(paste(format(formula), collapse = "")) - }) - - return(formula) -} diff --git a/R/get_R2.R b/R/get_R2.R deleted file mode 100644 index 80f94fc..0000000 --- a/R/get_R2.R +++ /dev/null @@ -1,306 +0,0 @@ -#' Get Indices of Explanatory Power. -#' -#' See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=get_R2.lm]{get_R2.lm}} -#' \item{\link[=get_R2.glm]{get_R2.glm}} -#' \item{\link[=get_R2.stanreg]{get_R2.stanreg}} -#' } -#' -#' @param fit Object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_R2 <- function(fit, ...) { - UseMethod("get_R2") -} - - -#' R2 and adjusted R2 for Linear Models. -#' -#' R2 and adjusted R2 for Linear Models. -#' -#' @param fit A linear model. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -get_R2.lm <- function(fit, ...) { - R2 <- summary(fit)$r.squared - R2.adj <- summary(fit)$adj.r.squared - - out <- list(R2 = R2, R2.adj = R2.adj) - return(out) -} - - - -#' Pseudo-R-squared for Logistic Models. -#' -#' Pseudo-R-squared for Logistic Models. -#' -#' @param fit A logistic model. -#' @param method Can be \link[=R2_nakagawa]{"nakagawa"} or \link[=R2_tjur]{"tjur"}. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- glm(vs ~ wt, data = mtcars, family = "binomial") -#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_R2.glm <- function(fit, method = "nakagawa", ...) { - if (method == "nakagawa") { - R2 <- as.numeric(R2_nakagawa(fit)$R2m) - } else if (method == "tjur") { - R2 <- R2_tjur(fit) - } else { - stop("Method must be 'nakagawa' or 'tjur'.") - } - return(R2) -} - - - - -#' R2 or Bayesian Models. -#' -#' Computes R2 and \link[=R2_LOO_Adjusted]{LOO-adjusted R2}. -#' -#' @param fit A stanreg model. -#' @param silent If R2 not available, throw warning. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' fit <- rstanarm::stan_glm(Adjusting ~ Tolerating, data = psycho::affective) -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso \link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} -#' -#' @export -get_R2.stanreg <- function(fit, silent = FALSE, ...) { - tryCatch({ - R2 <- rstanarm::bayes_R2(fit) - }, error = function(e) { - R2 <- "NA" - }) - - if (!is.numeric(R2)) { - if (silent) { - return(R2) - } else { - stop("Couldn't compute R2 for this model.") - } - } - - out <- list( - R2_median = median(R2), - R2_MAD = mad(R2), - R2_posterior = R2 - ) - - if (fit$family$family == "gaussian") { - out$R2.adj <- R2_LOO_Adjusted(fit) - } else { - out$R2.adj <- NA - } - - return(out) -} - - - -#' R2 and adjusted R2 for GLMMs. -#' -#' R2 and adjusted R2 for GLMMs. -#' -#' @param fit A GLMM. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), -#' data = psycho::affective -#' ) -#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), -#' data = na.omit(psycho::affective), family = "binomial" -#' ) -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -get_R2.merMod <- function(fit, ...) { - out <- suppressMessages(R2_nakagawa(fit)) - return(out) -} - - - - - -#' Pseudo-R-squared for Generalized Mixed-Effect models. -#' -#' For mixed-effects models, R² can be categorized into two types. Marginal R_GLMM² represents the variance explained by fixed factors, and Conditional R_GLMM² is interpreted as variance explained by both fixed and random factors (i.e. the entire model). IMPORTANT: Looking for help to reimplement this method. -#' -#' @param fit A mixed model. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -#' -#' R2_nakagawa(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references -#' Nakagawa, S., Johnson, P. C., & Schielzeth, H. (2017). The coefficient of determination R2 and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. Journal of the Royal Society Interface, 14(134), 20170213. -#' Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @export -R2_nakagawa <- function(fit) { - out <- MuMIn::r.squaredGLMM(fit) - out <- list( - R2m = as.numeric(out[1]), - R2c = as.numeric(out[2]) - ) - return(out) -} - - - -#' Compute LOO-adjusted R2. -#' -#' Compute LOO-adjusted R2. -#' -#' @param fit A stanreg model. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' data <- attitude -#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) -#' -#' R2_LOO_Adjusted(fit) -#' } -#' -#' @author \href{https://github.com/strengejacke}{Daniel Luedecke} -#' -#' @import rstantools -#' -#' @export -R2_LOO_Adjusted <- function(fit) { - predictors <- all.vars(as.formula(fit$formula)) - y <- fit$data[[predictors[[1]]]] - ypred <- rstantools::posterior_linpred(fit) - ll <- rstantools::log_lik(fit) - - nsamples <- 0 - nchains <- length(fit$stanfit@stan_args) - for (chain in fit$stanfit@stan_args) { - nsamples <- nsamples + (chain$iter - chain$warmup) - } - - - r_eff <- loo::relative_eff(exp(ll), - chain_id = rep(1:nchains, each = nsamples / nchains) - ) - - psis_object <- loo::psis(log_ratios = -ll, r_eff = r_eff) - ypredloo <- loo::E_loo(ypred, psis_object, log_ratios = -ll)$value - if (length(ypredloo) != length(y)) { - warning("Something went wrong in the Loo-adjusted R2 computation.") - return(NA) - } - eloo <- ypredloo - y - - adj_r_squared <- 1 - stats::var(eloo) / stats::var(y) - return(adj_r_squared) -} - - - - -#' Tjur's (2009) coefficient of determination. -#' -#' Computes Tjur's (2009) coefficient of determination. -#' -#' @param fit Logistic Model. -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' R2_tjur(fit) -#' @author \href{https://github.com/strengejacke}{Daniel Lüdecke} -#' -#' @import dplyr -#' @importFrom stats predict residuals -#' @importFrom lme4 getME -#' -#' @references Tjur, T. (2009). Coefficients of determination in logistic regression models—A new proposal: The coefficient of discrimination. The American Statistician, 63(4), 366-372. -#' -#' @export -R2_tjur <- function(fit) { - # check for valid object class - if (!inherits(fit, c("glmerMod", "glm"))) { - stop("`x` must be an object of class `glm` or `glmerMod`.", call. = F) - } - - # mixed models (lme4) - if (inherits(fit, "glmerMod")) { - # check for package availability - y <- lme4::getME(fit, "y") - pred <- stats::predict(fit, type = "response", re.form = NULL) - } else { - y <- fit$y - pred <- stats::predict.glm(fit, type = "response") - } - - # delete pred for cases with missing residuals - if (anyNA(stats::residuals(fit))) pred <- pred[!is.na(stats::residuals(fit))] - - categories <- unique(y) - m1 <- mean(pred[which(y == categories[1])], na.rm = T) - m2 <- mean(pred[which(y == categories[2])], na.rm = T) - - D <- abs(m2 - m1) - names(D) <- "Tjur's D" - - return(D) -} diff --git a/R/get_contrasts.R b/R/get_contrasts.R deleted file mode 100644 index b140fcc..0000000 --- a/R/get_contrasts.R +++ /dev/null @@ -1,234 +0,0 @@ -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts between factor levels based on a fitted model. -#' See the documentation for your model's class: -#' \itemize{ -#' \item{\link[=get_contrasts.glm]{get_contrasts.glm}} -#' \item{\link[=get_contrasts.lmerModLmerTest]{get_contrasts.merModLmerTest}} -#' \item{\link[=get_contrasts.glmerMod]{get_contrasts.glmerMod}} -#' \item{\link[=get_contrasts.stanreg]{get_contrasts.stanreg}} -#' } -#' -#' -#' @param fit A model. -#' @param ... Arguments passed to or from other methods. -#' -#' @return Estimated contrasts. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' require(lmerTest) -#' require(rstanarm) -#' -#' fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) -#' get_contrasts(fit) -#' -#' fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) -#' get_contrasts(fit, adjust = "bonf") -#' -#' fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) -#' get_contrasts(fit, formula = "Birth_Season") -#' -#' fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) -#' get_contrasts(fit, formula = "Birth_Season", ROPE_bounds = c(-0.1, 0.1)) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_contrasts <- function(fit, ...) { - UseMethod("get_contrasts") -} - - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @param fit A Bayesian model. -#' @param formula A character vector (formula like format, i.e., including -#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. -#' @param CI Determine the confidence or credible interval bounds. -#' @param ROPE_bounds Optional bounds of the ROPE for Bayesian models. -#' @param overlap Set to TRUE to add Overlap index (for Bayesian models). -#' @param ... Arguments passed to or from other methods. -#' @method get_contrasts stanreg -#' @export -get_contrasts.stanreg <- function(fit, formula = NULL, CI = 90, ROPE_bounds = NULL, overlap = FALSE, ...) { - .get_contrasts_bayes(fit, formula, CI, ROPE_bounds, overlap, ...) -} - - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @param fit A frequentist model. -#' @param formula A character vector (formula like format, i.e., including -#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. -#' @param CI Determine the confidence or credible interval bounds. -#' @param adjust P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -#' "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none". -#' @param ... Arguments passed to or from other methods. -#' @method get_contrasts lm -#' @export -get_contrasts.lm <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts glm -#' @export -get_contrasts.glm <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts lmerModLmerTest -#' @export -get_contrasts.lmerModLmerTest <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts glmerMod -#' @export -get_contrasts.glmerMod <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts lmerMod -#' @export -get_contrasts.lmerMod <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom graphics pairs -#' @importFrom stats confint mad -#' @keywords internal -.get_contrasts_bayes <- function(fit, formula = NULL, CI = 90, ROPE_bounds = NULL, overlap = FALSE, ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Contrasts --------------------------------------------------------------- - contrasts_posterior <- fit %>% - emmeans::emmeans(formula) %>% - graphics::pairs() %>% - emmeans::as.mcmc.emmGrid() %>% - as.matrix() %>% - as.data.frame() - - contrasts <- data.frame() - - - for (name in names(contrasts_posterior)) { - posterior <- contrasts_posterior[[name]] - - CI_values <- HDI(posterior, prob = CI / 100) - CI_values <- c(CI_values$values$HDImin, CI_values$values$HDImax) - - var <- data.frame( - Contrast = stringr::str_remove(name, "contrast "), - Median = median(posterior), - MAD = mad(posterior), - CI_lower = CI_values[seq(1, length(CI_values), 2)], - CI_higher = CI_values[seq(2, length(CI_values), 2)], - MPE = mpe(posterior)$MPE - ) - - if (overlap == TRUE) { - var$Overlap <- 100 * overlap( - posterior, - rnorm_perfect( - length(posterior), - 0, - sd(posterior) - ) - ) - } - - if (!is.null(ROPE_bounds)) { - var$ROPE <- rope(posterior, ROPE_bounds, CI = 95)$rope_probability - } - - contrasts <- rbind(contrasts, var) - } - - - return(contrasts) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom graphics pairs -#' @importFrom stats confint -#' @keywords internal -.get_contrasts_freq <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Contrasts --------------------------------------------------------------- - contrasts <- fit %>% - emmeans::emmeans(formula) %>% - graphics::pairs(adjust = adjust) - - # Confint - CI <- contrasts %>% - confint(CI / 100) %>% - select(contains("CL")) - - - contrasts <- contrasts %>% - as.data.frame() %>% - cbind(CI) %>% - dplyr::rename_( - "Contrast" = "contrast", - "Difference" = "estimate", - "p" = "p.value" - ) - names(contrasts) <- stringr::str_replace(names(contrasts), "lower.CL", "CI_lower") - names(contrasts) <- stringr::str_replace(names(contrasts), "upper.CL", "CI_higher") - names(contrasts) <- stringr::str_replace(names(contrasts), "asymp.LCL", "CI_lower") - names(contrasts) <- stringr::str_replace(names(contrasts), "asymp.UCL", "CI_higher") - names(contrasts) <- stringr::str_replace(names(contrasts), "t.ratio", "t") - names(contrasts) <- stringr::str_replace(names(contrasts), "z.ratio", "z") - - return(contrasts) -} diff --git a/R/get_data.R b/R/get_data.R deleted file mode 100644 index cb82921..0000000 --- a/R/get_data.R +++ /dev/null @@ -1,80 +0,0 @@ -#' Extract the dataframe used in a model. -#' -#' Extract the dataframe used in a model. -#' -#' @param fit A model. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(tidyverse) -#' library(psycho) -#' -#' df <- mtcars %>% -#' mutate( -#' cyl = as.factor(cyl), -#' gear = as.factor(gear) -#' ) -#' -#' fit <- lm(wt ~ mpg, data = df) -#' fit <- lm(wt ~ cyl, data = df) -#' fit <- lm(wt ~ mpg * cyl, data = df) -#' fit <- lm(wt ~ cyl * gear, data = df) -#' fit <- lmerTest::lmer(wt ~ mpg * gear + (1 | cyl), data = df) -#' fit <- rstanarm::stan_lmer(wt ~ mpg * gear + (1 | cyl), data = df) -#' -#' get_data(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -get_data <- function(fit, ...) { - UseMethod("get_data") -} - - -#' @importFrom stats getCall -#' @importFrom utils data -#' @export -get_data.lm <- function(fit, ...) { - tryCatch({ - data <- eval(getCall(fit)$data, environment(formula(fit))) - return(data) - }) - - info <- get_info(fit) - - outcome <- info$outcome - predictors <- info$predictors - - data <- as.data.frame(model.frame(fit)) - - - effects <- names(MuMIn::coeffs(fit)) - effects <- unique(unlist(stringr::str_split(effects, ":"))) - numerics <- predictors[predictors %in% effects] - - numerics <- numerics[!is.na(numerics)] - if (length(unique(model.response(model.frame(fit)))) > 2) { - numerics <- c(outcome, numerics) - } - - - data[!names(data) %in% numerics] <- lapply(data[!names(data) %in% numerics], as.factor) - data[names(data) %in% numerics] <- lapply(data[names(data) %in% numerics], as.numeric) - - return(as.data.frame(data)) -} - -#' @export -get_data.merMod <- get_data.lm - - - - - -#' @export -get_data.stanreg <- function(fit, ...) { - data <- fit$data - return(data) -} diff --git a/R/get_formula.R b/R/get_formula.R deleted file mode 100644 index 99ad77f..0000000 --- a/R/get_formula.R +++ /dev/null @@ -1,54 +0,0 @@ -#' Get formula of models. -#' -#' Get formula of models. Implemented for: -#' \itemize{ -#' \item{analyze.merModLmerTest} -#' \item{analyze.glmerMod} -#' \item{analyze.lm} -#' \item{analyze.glm} -#' \item{analyze.stanreg} -#' } -#' -#' @param x Object. -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' fit <- lm(hp ~ wt, data = mtcars) -#' -#' get_formula(fit) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_formula <- function(x, ...) { - UseMethod("get_formula") -} - - -#' @export -get_formula.lmerModLmerTest <- function(x, ...) { - return(x@call$formula) -} -#' @export -get_formula.glmerMod <- get_formula.lmerModLmerTest -#' @export -get_formula.lmerMod <- get_formula.lmerModLmerTest - - -#' @export -get_formula.lm <- function(x, ...) { - return(stats::formula(x)) -} -#' @export -get_formula.glm <- get_formula.lm - - - -#' @export -get_formula.stanreg <- function(x, ...) { - return(x$formula) -} diff --git a/R/get_graph.R b/R/get_graph.R deleted file mode 100644 index 47bb6cd..0000000 --- a/R/get_graph.R +++ /dev/null @@ -1,233 +0,0 @@ -#' Get graph data. -#' -#' To be used with tidygraph::tbl_graph. See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=get_graph.lavaan]{get_graph.lavaan}} -#' \item{\link[=get_graph.fa]{get_graph.fa}} -#' \item{\link[=get_graph.psychobject_correlation]{get_graph.psychobject_correlation}} -#' } -#' -#' @param fit Object from which to extract the graph data. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_graph <- function(fit, ...) { - UseMethod("get_graph") -} - - - - - - - - - - - - - - - - - - -#' Get graph data from lavaan or blavaan objects. -#' -#' Get graph data from lavaan or blavaan objects. -#' -#' @param fit lavaan object. -#' @param links Which links to include? A list including at least one of "Regression", "Loading" or "Correlation". -#' @param standardize Use standardized coefs. -#' @param threshold_Coef Omit all links with a Coefs below this value. -#' @param threshold_p Omit all links with a p value above this value. -#' @param threshold_MPE In case of a blavaan model, omit all links with a MPE value below this value. -#' @param digits Edges' labels rounding. -#' @param CI CI level. -#' @param labels_CI Add the CI in the edge label. -#' @param ... Arguments passed to or from other methods. -#' -#' @return A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_graph.lavaan <- function(fit, links = c("Regression", "Correlation", "Loading"), standardize = FALSE, threshold_Coef = NULL, threshold_p = NULL, threshold_MPE = NULL, digits = 2, CI = "default", labels_CI = TRUE, ...) { - # https://www.r-bloggers.com/ggplot2-sem-models-with-tidygraph-and-ggraph/ - - - if (labels_CI == TRUE) { - if (CI != "default") { - results <- analyze(fit, CI = CI, standardize = standardize) - } else { - results <- analyze(fit, standardize = standardize) - } - } else { - results <- analyze(fit, standardize = standardize) - } - - summary <- summary(results) - CI <- results$values$CI - - # Check what type of model - if (class(fit) %in% c("blavaan")) { - summary$Coef <- summary$Median - if (is.null(threshold_MPE)) { - threshold_MPE <- -1 - } - summary <- summary %>% - filter_("MPE >= threshold_MPE") - } else if (class(fit) %in% c("lavaan")) { - if (is.null(threshold_p)) { - threshold_p <- 1.1 - } - summary <- summary %>% - filter_("p <= threshold_p") - } else { - stop(paste("Error in UseMethod('plot_lavaan') : no applicable method for 'plot_lavaan' applied to an object of class", class(fit))) - } - - # Deal with thresholds - if (is.null(threshold_Coef)) { - threshold_Coef <- min(abs(summary$Coef)) - 1 - } - - # Edge properties - edges <- summary %>% - mutate_("abs_coef" = "abs(Coef)") %>% - filter_( - "Type %in% c(links)", - "From != To", - "abs_coef >= threshold_Coef" - ) %>% - select(-one_of("abs_coef")) %>% - rename_( - "to" = "To", - "from" = "From" - ) - - # Labels - if (labels_CI == TRUE) { - edges <- edges %>% - mutate_("Label" = 'paste0(format_digit(Coef, digits), - ", ", CI, "% CI [", format_digit(CI_lower, digits), - ", ", format_digit(CI_higher, digits), "]")') - } else { - edges <- edges %>% - mutate_("Label" = "format_digit(Coef, digits)") - } - edges <- edges %>% - mutate_( - "Label_Regression" = "ifelse(Type=='Regression', Label, '')", - "Label_Correlation" = "ifelse(Type=='Correlation', Label, '')", - "Label_Loading" = "ifelse(Type=='Loading', Label, '')" - ) - edges <- edges[colSums(!is.na(edges)) > 0] - - # Identify latent variables for nodes - latent_nodes <- edges %>% - filter_('Type == "Loading"') %>% - distinct_("to") %>% - transmute_("Name" = "to", "Latent" = TRUE) - - nodes_list <- unique(c(edges$from, edges$to)) - - # Node properties - nodes <- summary %>% - filter_( - "From == To", - "From %in% nodes_list" - ) %>% - mutate_("Name" = "From") %>% - left_join(latent_nodes, by = "Name") %>% - mutate_("Latent" = "if_else(is.na(Latent), FALSE, Latent)") %>% - select(one_of(c("Name", "Latent"))) - - return(list(nodes = nodes, edges = edges)) -} - - - - - -#' Get graph data from factor analysis. -#' -#' Get graph data from fa objects. -#' -#' @param fit psych::fa object. -#' @param threshold_Coef Omit all links with a Coefs below this value. -#' @param digits Edges' labels rounding. -#' @param ... Arguments passed to or from other methods. -#' -#' @return A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_graph.fa <- function(fit, threshold_Coef = NULL, digits = 2, ...) { - edges <- summary(analyze(fit)) %>% - gather("To", "Coef", -one_of("N", "Item", "Label")) %>% - rename_("From" = "Item") %>% - mutate_("Label" = "format_digit(Coef, digits)") %>% - select(one_of("From", "To", "Coef", "Label"), everything()) %>% - filter() - - # Deal with thresholds - if (is.null(threshold_Coef)) { - threshold_Coef <- min(abs(edges$Coef)) - 1 - } - - edges <- edges %>% - filter_("Coef > threshold_Coef") - - nodes <- data.frame("Name" = c(edges$From, edges$To)) %>% - distinct_("Name") - - return(list(nodes = nodes, edges = edges)) -} - - - - -#' Get graph data from correlation. -#' -#' Get graph data from correlation. -#' -#' @param fit Object from psycho::correlation. -#' @param ... Arguments passed to or from other methods. -#' -#' @return A list containing nodes and edges data to be used by `igraph::graph_from_data_frame()`. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_graph.psychobject_correlation <- function(fit, ...) { - vars <- row.names(fit$values$r) - - r <- fit$values$r %>% - as.data.frame() %>% - tibble::rownames_to_column("from") %>% - tidyr::gather("to", "r", vars) - - if ("p" %in% names(fit$values)) { - r <- r %>% - full_join( - fit$values$p %>% - as.data.frame() %>% - tibble::rownames_to_column("from") %>% - tidyr::gather("to", "p", vars), - by = c("from", "to") - ) - } - - r <- filter_(r, "!from == to") - return(r) -} diff --git a/R/get_info.R b/R/get_info.R deleted file mode 100644 index 84856a8..0000000 --- a/R/get_info.R +++ /dev/null @@ -1,166 +0,0 @@ -#' Get information about objects. -#' -#' Get information about models. -#' -#' -#' @param x object. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' -#' info <- get_info(fit) -#' info -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_info <- function(x, ...) { - UseMethod("get_info") -} - - - - - - - - - - -#' Get information about models. -#' -#' Get information about models. -#' -#' @param x object. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' -#' info <- get_info(fit) -#' info -#' -#' # -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_info.lmerModLmerTest <- function(x, ...) { - fit <- x - - info <- tryCatch({ - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- all.vars(formula) - outcome <- predictors[[1]] - predictors <- tail(predictors, -1) - random <- names(ranef(fit))[names(ranef(fit)) %in% predictors] - predictors <- predictors[!predictors %in% random] - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome, - random = random - )) - }, error = function(e) { - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- NA - outcome <- "Y" - random <- NA - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome, - random = random - )) - }) - - return(info) -} -#' @export -get_info.glmerMod <- get_info.lmerModLmerTest -#' @export -get_info.lmerMod <- get_info.lmerModLmerTest - - - -#' Get information about models. -#' -#' Get information about models. -#' -#' @param x object. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lm(vs ~ wt, data = mtcars, family = "binomial") -#' -#' info <- get_info(fit) -#' info -#' -#' # -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_info.lm <- function(x, ...) { - fit <- x - - info <- tryCatch({ - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- all.vars(formula) - outcome <- predictors[[1]] - predictors <- tail(predictors, -1) - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome - )) - }, error = function(e) { - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- NA - outcome <- "Y" - random <- NA - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome - )) - }) - - return(info) -} - -#' @export -get_info.stanreg <- get_info.lm -#' @export -get_info.lm <- get_info.lm -#' @export -get_info.glm <- get_info.lm diff --git a/R/get_means.R b/R/get_means.R deleted file mode 100644 index b6c3dd4..0000000 --- a/R/get_means.R +++ /dev/null @@ -1,149 +0,0 @@ -#' Compute estimated means from models. -#' -#' Compute estimated means of factor levels based on a fitted model. -#' -#' @param fit A model (lm, lme4 or rstanarm). -#' @param formula A character vector (formula like format, i.e., including -#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. -#' @param CI Determine the confidence or credible interval bounds. -#' @param ... Arguments passed to or from other methods. For instance, transform="response". -#' -#' -#' @return Estimated means (or median of means for Bayesian models) -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' require(lmerTest) -#' require(rstanarm) -#' -#' -#' fit <- glm(Sex ~ Birth_Season, data = affective, family = "binomial") -#' get_means(fit) -#' -#' fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) -#' get_means(fit, formula = "Birth_Season") -#' -#' fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) -#' get_means(fit, formula = "Birth_Season") -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_means <- function(fit, formula = NULL, CI = 90, ...) { - UseMethod("get_means") -} - - -#' @method get_means stanreg -#' @export -get_means.stanreg <- function(fit, formula = NULL, CI = 90, ...) { - .get_means_bayes(fit, formula, CI, ...) -} - -#' @method get_means lm -#' @export -get_means.lm <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means glm -#' @export -get_means.glm <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means lmerModLmerTest -#' @export -get_means.lmerModLmerTest <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means glmerMod -#' @export -get_means.glmerMod <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means lmerMod -#' @export -get_means.lmerMod <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom stats confint mad -#' @keywords internal -.get_means_bayes <- function(fit, formula = NULL, CI = 90, ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Means --------------------------------------------------------------- - means_posterior <- fit %>% - emmeans::emmeans(formula) %>% - emmeans::as.mcmc.emmGrid() %>% - as.matrix() %>% - as.data.frame() - - means <- data.frame() - - for (name in names(means_posterior)) { - var <- means_posterior[[name]] - - CI_values <- HDI(var, prob = CI / 100) - CI_values <- c(CI_values$values$HDImin, CI_values$values$HDImax) - - var <- data.frame( - Level = name, - Median = median(var), - MAD = mad(var), - CI_lower = CI_values[seq(1, length(CI_values), 2)], - CI_higher = CI_values[seq(2, length(CI_values), 2)] - ) - - means <- rbind(means, var) - } - - return(means) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom stats confint -#' @keywords internal -.get_means_freq <- function(fit, formula = NULL, CI = 95, ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Means --------------------------------------------------------------- - means <- fit %>% - emmeans::emmeans(formula, ...) %>% - confint(CI / 100) %>% - as.data.frame() - - names(means) <- stringr::str_replace(names(means), "emmean", "Mean") - names(means) <- stringr::str_replace(names(means), "lower.CL", "CI_lower") - names(means) <- stringr::str_replace(names(means), "upper.CL", "CI_higher") - names(means) <- stringr::str_replace(names(means), "asymp.LCL", "CI_lower") - names(means) <- stringr::str_replace(names(means), "asymp.UCL", "CI_higher") - - return(means) -} diff --git a/R/get_predicted.R b/R/get_predicted.R deleted file mode 100644 index 5d1e84d..0000000 --- a/R/get_predicted.R +++ /dev/null @@ -1,20 +0,0 @@ -#' Compute predicted values from models. -#' -#' Compute predicted values from models. See the -#' documentation for your model's class: -#' \itemize{ -#' \item{\link[=get_predicted.stanreg]{get_predicted.stanreg}} -#' \item{\link[=get_predicted.merMod]{get_predicted.merMod}} -#' \item{\link[=get_predicted.lm]{get_predicted.lm}} -#' \item{\link[=get_predicted.glm]{get_predicted.glm}} -#' } -#' -#' @param fit Model. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_predicted <- function(fit, ...) { - UseMethod("get_predicted") -} diff --git a/R/get_predicted.glm.R b/R/get_predicted.glm.R deleted file mode 100644 index 2d43f88..0000000 --- a/R/get_predicted.glm.R +++ /dev/null @@ -1,116 +0,0 @@ -#' Compute predicted values of lm models. -#' -#' Compute predicted from a lm model. -#' -#' @param fit An lm model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of confidence intervals (0.9 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). -#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' -#' fit <- glm(Sex ~ Adjusting, data = affective, family = "binomial") -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Sex_CI_2.5, -#' ymax = Sex_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.glm <- function(fit, newdata = "model", prob = 0.95, odds_to_probs = TRUE, ...) { - - - # Extract names - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- fit$data[predictors] - newdata <- na.omit(fit$data[predictors]) - } - } - } - - - # Compute ---------------------------------------------------------- - - # Predicted Y - prediction <- as.data.frame(predict(fit, newdata = newdata, type = "link", se.fit = TRUE)) - SE <- as.data.frame(prediction$se.fit) - pred_y <- as.data.frame(prediction$fit) - names(pred_y) <- paste0(outcome, "_Predicted") - - # Credible Interval - for (CI in c(prob)) { - pred_y_interval <- data.frame( - lwr = prediction$fit - (qnorm(CI) * SE), - upr = prediction$fit + (qnorm(CI) * SE) - ) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - - - # Transform odds to probs ---------------------------------------------------------- - - if (family(fit)$family == "binomial" & family(fit)$link == "logit") { - if (odds_to_probs == TRUE) { - pred_y <- odds_to_probs(pred_y) - } - } - - - # Add predictors ---------------------------------------------------------- - - - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit$data[!names(fit$data) %in% predictors] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} diff --git a/R/get_predicted.lm.R b/R/get_predicted.lm.R deleted file mode 100644 index 2cce683..0000000 --- a/R/get_predicted.lm.R +++ /dev/null @@ -1,100 +0,0 @@ -#' Compute predicted values of lm models. -#' -#' Compute predicted from a lm model. -#' -#' @param fit An lm model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of confidence intervals (0.95 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' -#' fit <- lm(Tolerating ~ Adjusting, data = affective) -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Tolerating_CI_2.5, -#' ymax = Tolerating_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.lm <- function(fit, newdata = "model", prob = 0.95, ...) { - - - # Extract names - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- as.data.frame(fit$model[predictors]) - newdata <- na.omit(fit$model[predictors]) - } - } - } - - - # Compute ---------------------------------------------------------- - - # Predicted Y - pred_y <- as.data.frame(predict(fit, newdata)) - names(pred_y) <- paste0(outcome, "_Predicted") - - # Credible Interval - for (CI in c(prob)) { - pred_y_interval <- as.data.frame(predict(fit, newdata, interval = "confidence", level = CI)[, -1]) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - - - - # Add predictors ---------------------------------------------------------- - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit$model[!names(fit$model) %in% predictors] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} diff --git a/R/get_predicted.merMod.R b/R/get_predicted.merMod.R deleted file mode 100644 index 4e7146b..0000000 --- a/R/get_predicted.merMod.R +++ /dev/null @@ -1,159 +0,0 @@ -#' Compute predicted values of lm models. -#' -#' Compute predicted from a lm model. -#' -#' @param fit An lm model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of confidence intervals (0.95 will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). Default to NULL as it takes a very long time to compute (see \link[lme4]{bootMer}). -#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. -#' @param iter An integer indicating the number of iterations for bootstrapping (when prob is not null). -#' @param seed An optional seed to use. -#' @param re.form Formula for random effects to condition on. If NULL, include all random effects; if NA or ~0, include no random effects (see \link[lme4]{predict.merMod}). If "default", then will ne NULL if the random are present in the data, and NA if not. -#' @param use.u logical, indicating whether the spherical random effects should be simulated / bootstrapped as well. If TRUE, they are not changed, and all inference is conditional on these values. If FALSE, new normal deviates are drawn (see\link[lme4]{bootMer}). -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' -#' fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + -#' geom_line() -#' -#' predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Tolerating_CI_2.5, -#' ymax = Tolerating_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' -#' -#' -#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = affective, family = "binomial") -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + -#' geom_line() -#' -#' predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Sex_CI_2.5, -#' ymax = Sex_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.merMod <- function(fit, newdata = "model", prob = NULL, odds_to_probs = TRUE, iter = 100, seed = NULL, re.form = "default", use.u = FALSE, ...) { - - - # Extract names - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- na.omit(fit@frame) - } - } - } - - - # Deal with random - if (!is.na(re.form)) { - if (re.form == "default") { - # Check if all predictors are in variables - if (all(get_info(fit)$predictors %in% names(newdata))) { - re.form <- NULL - } else { - re.form <- NA - } - } - } - - - - # Compute ---------------------------------------------------------- - - pred_y <- as.data.frame(predict(fit, newdata = newdata, re.form = re.form)) - names(pred_y) <- paste0(outcome, "_Predicted") - - if (!is.null(prob)) { - predFun <- function(fit) { - predict(fit, newdata, newdata = newdata, re.form = re.form) - } - predMat <- lme4::bootMer(fit, nsim = iter, FUN = predFun, use.u = use.u, seed = seed)$t - - for (CI in c(prob)) { - pred_y_interval <- as.data.frame(t(apply(predMat, 2, quantile, c((1 - CI) / 2, CI + (1 - CI) / 2), na.rm = TRUE))) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - } - - - # Transform odds to probs ---------------------------------------------------------- - - if (family(fit)$family == "binomial" & family(fit)$link == "logit") { - if (odds_to_probs == TRUE) { - pred_y <- odds_to_probs(pred_y) - } - } - - - # Add predictors ---------------------------------------------------------- - - - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit@frame[!names(fit@frame) %in% names(newdata)] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} diff --git a/R/get_predicted.stanreg.R b/R/get_predicted.stanreg.R deleted file mode 100644 index f2d2a8a..0000000 --- a/R/get_predicted.stanreg.R +++ /dev/null @@ -1,161 +0,0 @@ -#' Compute predicted values of stanreg models. -#' -#' Compute predicted from a stanreg model. -#' -#' @param fit A stanreg model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of credible intervals (0.9 (default) will compute 5-95\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). -#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. -#' @param keep_iterations Keep all prediction iterations. -#' @param draws An integer indicating the number of draws to return. The default and maximum number of draws is the size of the posterior sample. -#' @param posterior_predict Posterior draws of the outcome instead of the link function (i.e., the regression "line"). -#' @param seed An optional seed to use. -#' @param transform If posterior_predict is False, should the linear predictor be transformed using the inverse-link function? The default is FALSE, in which case the untransformed linear predictor is returned. -#' @param re.form If object contains group-level parameters, a formula indicating which group-level parameters to condition on when making predictions. re.form is specified in the same form as for predict.merMod. NULL indicates that all estimated group-level parameters are conditioned on. To refrain from conditioning on any group-level parameters, specify NA or ~0. The newdata argument may include new levels of the grouping factors that were specified when the model was estimated, in which case the resulting posterior predictions marginalize over the relevant variables (see \link[rstanarm]{posterior_predict.stanreg}). If "default", then will ne NULL if the random are present in the data, and NA if not. -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' require(rstanarm) -#' -#' fit <- rstanarm::stan_glm(Tolerating ~ Adjusting, data = affective) -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Median)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Tolerating_CI_5, -#' ymax = Tolerating_CI_95 -#' ), -#' alpha = 0.1 -#' ) -#' -#' fit <- rstanarm::stan_glm(Sex ~ Adjusting, data = affective, family = "binomial") -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Median)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Sex_CI_5, -#' ymax = Sex_CI_95 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import rstanarm -#' @importFrom stats median family model.matrix -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.stanreg <- function(fit, newdata = "model", prob = 0.9, odds_to_probs = TRUE, keep_iterations = FALSE, draws = NULL, posterior_predict = FALSE, seed = NULL, transform = FALSE, re.form = "default", ...) { - - # Extract names - predictors <- all.vars(as.formula(fit$formula)) - outcome <- predictors[[1]] - predictors <- tail(predictors, -1) - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- fit$data[predictors] - newdata <- na.omit(fit$data[predictors]) - } - } - } - - # Deal with potential random - if (!is.na(re.form)) { - if (re.form == "default") { - if (is.mixed(fit)) { - # Check if all predictors are in variables - if (all(get_info(fit)$predictors %in% names(newdata))) { - re.form <- NULL - } else { - re.form <- NA - } - } - } - } - - # Generate draws ------------------------------------------------------- - if (posterior_predict == FALSE) { - posterior <- rstanarm::posterior_linpred(fit, newdata = newdata, re.form = re.form, seed = seed, draws = draws, transform = transform) - } else { - posterior <- rstanarm::posterior_predict(fit, newdata = newdata, re.form = re.form, seed = seed, draws = draws) - } - - # Format ------------------------------------------------------- - - # Predicted Y - pred_y <- as.data.frame(apply(posterior, 2, median)) - names(pred_y) <- paste0(outcome, "_Median") - - # Credible Interval - for (CI in c(prob)) { - pred_y_interval <- HDI(posterior, prob = CI) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - - - # Keep iterations --------------------------------------------------------- - - if (keep_iterations == TRUE) { - iterations <- as.data.frame(t(posterior)) - names(iterations) <- paste0("iter_", seq_len(length(names(iterations)))) - pred_y <- cbind(pred_y, iterations) - } - - # Transform odds to probs ---------------------------------------------------------- - - if (family(fit)$family == "binomial" & family(fit)$link == "logit") { - if (odds_to_probs == TRUE) { - pred_y <- odds_to_probs(pred_y) - } - } - - - # Add predictors ---------------------------------------------------------- - - - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit$data[!names(fit$data) %in% predictors] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} diff --git a/R/golden.R b/R/golden.R deleted file mode 100644 index 129fe1c..0000000 --- a/R/golden.R +++ /dev/null @@ -1,17 +0,0 @@ -#' Golden Ratio. -#' -#' Returns the golden ratio (1.618034...). -#' -#' @param x A number to be multiplied by the golden ratio. The default (x=1) returns the value of the golden ratio. -#' -#' @examples -#' library(psycho) -#' -#' golden() -#' golden(8) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -golden <- function(x = 1) { - return(x * (1 + sqrt(5)) / 2) -} diff --git a/R/hdi.R b/R/hdi.R deleted file mode 100644 index 4025a4a..0000000 --- a/R/hdi.R +++ /dev/null @@ -1,132 +0,0 @@ -#' Highest Density Intervals (HDI). -#' -#' Compute the Highest Density Intervals (HDI) of a distribution. -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' -#' @examples -#' library(psycho) -#' -#' distribution <- rnorm(1000, 0, 1) -#' HDI_values <- HDI(distribution) -#' print(HDI_values) -#' plot(HDI_values) -#' summary(HDI_values) -#' -#' x <- matrix(rexp(200), 100) -#' HDI_values <- HDI(x) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -HDI <- function(x, prob = .95) { - - # From CI to prob if necessary - if (prob > 1 & prob <= 100) { - prob <- prob / 100 - } - - # If x is a matrix - if (ncol(as.matrix(x)) > 1) { - HDImin <- c() - HDImax <- c() - for (col in seq_len(ncol(x))) { - HDI <- .HDI(x[, col], prob = prob) - HDImin <- c(HDImin, HDI[1]) - HDImax <- c(HDImax, HDI[2]) - } - return(data.frame(HDImin = HDImin, HDImax = HDImax)) - - - # If x is a vector - } else { - # Process - # ------------- - HDI <- .HDI(x, prob = prob) - HDImin <- HDI[1] - HDImax <- HDI[2] - - # Store results - # ------------- - values <- list(HDImin = HDImin, HDImax = HDImax, prob = prob) - text <- paste( - prob * 100, - "% CI [", - format_string(HDImin, "%.2f"), - ", ", - format_string(HDImax, "%.2f"), - "]", - sep = "" - ) - summary <- data.frame(Probability = prob, HDImin = HDImin, HDImax = HDImax) - - - # Plot - # ------------- - data <- as.data.frame(x = x) - plot <- ggplot(data = data, aes(x)) + - geom_density(fill = "#2196F3") + - geom_vline( - data = data, aes(xintercept = HDImin), - linetype = "dashed", color = "#E91E63", size = 1 - ) + - geom_vline( - data = data, aes(xintercept = HDImax), - linetype = "dashed", color = "#E91E63", size = 1 - ) + - theme_minimal() - - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) - } -} - - - - -#' Highest Density Intervals (HDI) -#' -#' See \link[=HDI]{HDI} -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' -#' @export -HDImin <- function(x, prob = .95) { - HDImin <- HDI(x, prob = prob)$values$HDImin - return(HDImin) -} - -#' Highest Density Intervals (HDI) -#' -#' See \link[=HDI]{HDI} -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' -#' @export -HDImax <- function(x, prob = .95) { - HDImax <- HDI(x, prob = prob)$values$HDImax - return(HDImax) -} - - - - - - -#' @keywords internal -.HDI <- function(x, prob) { - x <- sort(x) - ci.index <- ceiling(prob * length(x)) - nCIs <- length(x) - ci.index - ci.width <- purrr::map_dbl(1:nCIs, ~ x[.x + ci.index] - x[.x]) - HDImin <- x[which.min(ci.width)] - HDImax <- x[which.min(ci.width) + ci.index] - return(c(HDImin, HDImax)) -} diff --git a/R/interpret_R2.R b/R/interpret_R2.R deleted file mode 100644 index 1fa505b..0000000 --- a/R/interpret_R2.R +++ /dev/null @@ -1,141 +0,0 @@ -#' R2 interpreation. -#' -#' Interpret R2 with a set of rules. -#' -#' @param x Value. -#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_R2(x = 0.42) -#' interpret_R2(x = c(0.42, 0.2, 0.9, 0)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_R2 <- function(x, rules = "cohen1988") { - interpretation <- sapply(x, .interpret_R2, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - -#' R2 interpreation for a posterior distribution. -#' -#' Interpret R2 with a set of rules. -#' -#' @param posterior Distribution of R2. -#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.4, 0.1) -#' interpret_R2_posterior(posterior) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_R2_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_R2, rules = rules) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") - - values <- list() - for (value in names(sort(rules, decreasing = TRUE))) { - if (value %in% summary$Interpretation) { - values[value] <- summary[summary$Interpretation == value, ]$Probability - } else { - values[value] <- 0 - } - } - - # Text - if (length(summary$Interpretation) > 1) { - text_strength <- paste0(paste0(head(summary$Interpretation, -1), collapse = ", "), " or ", tail(summary$Interpretation, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The R2 can be considered as ", - text_strength, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary$Interpretation - text_effects <- paste0(format_digit(summary$Probability * 100), "%") - - text <- paste0( - "The R2 can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - -#' @keywords internal -.interpret_R2 <- function(x, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.02, - "medium" = 0.13, - "large" = 0.26 - ) - } else if (rules == "chin1998") { - rules <- list( - "very small" = 0, - "small" = 0.19, - "medium" = 0.33, - "large" = 0.67 - ) - } else if (rules == "hair2013") { - rules <- list( - "very small" = 0, - "small" = 0.25, - "medium" = 0.50, - "large" = 0.75 - ) - } else { - stop("rules must be either a list or 'cohen1988', 'chin1998' or 'hair2013'.") - } - } - - x <- (x - unlist(rules)) - interpretation <- names(which.min(x[x >= 0])) - if (is.null(interpretation)) { - interpretation <- NA - } - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} diff --git a/R/interpret_RMSEA.R b/R/interpret_RMSEA.R deleted file mode 100644 index 4a4f061..0000000 --- a/R/interpret_RMSEA.R +++ /dev/null @@ -1,48 +0,0 @@ -#' RMSEA interpreation. -#' -#' Interpret RMSEA with a set of rules. -#' -#' @param x RMSEA. -#' @param rules Can be "awang2012", or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_RMSEA(0.04) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_RMSEA <- function(x, rules = "awang2012") { - interpretation <- sapply(x, .interpret_RMSEA, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - -#' @keywords internal -.interpret_RMSEA <- function(x, rules = "awang2012", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "awang2012") { - rules <- list( - "good" = 0, - "acceptable" = 0.05, - "poor" = 0.08 - ) - } else { - stop("rules must be either a list or 'awang2012'.") - } - } - - x <- (abs(x) - unlist(rules)) - s <- names(which.min(x[x >= 0])) - if (is.null(s)) { - s <- NA - } - - if (return_rules) { - return(list(interpretation = s, rules = rules)) - } else { - return(s) - } -} diff --git a/R/interpret_bf.R b/R/interpret_bf.R deleted file mode 100644 index da51db8..0000000 --- a/R/interpret_bf.R +++ /dev/null @@ -1,112 +0,0 @@ -#' Bayes Factor Interpretation -#' -#' Return the interpretation of a Bayes Factor. -#' -#' @param x Bayes Factor. -#' @param direction Include direction (against / in favour). -#' @param bf Include Bayes Factor. -#' @param rules Can be "jeffreys1961" (default), "raftery1995", or a custom list. -#' -#' -#' @examples -#' library(psycho) -#' interpret_bf(x = 10) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references -#' \itemize{ -#' \item{Jeffreys, H. (1961), Theory of Probability, 3rd ed., Oxford University Press, Oxford.} -#' \item{Jarosz, A. F., & Wiley, J. (2014). What are the odds? A practical guide to computing and reporting Bayes factors. The Journal of Problem Solving, 7(1), 2.} -#' } -#' @export -interpret_bf <- function(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961") { - interpretation <- sapply(x, .interpret_bf, direction = direction, bf = bf, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - -#' Bayes factor formatting -#' -#' Bayes factor formatting -#' -#' @param bf Bayes Factor. -#' @param max Treshold for maximum. -#' -#' @export -format_bf <- function(bf, max = 100) { - if (bf > max) { - bf <- paste0("BF > ", max) - } else { - bf <- paste0("BF = ", format_digit(bf)) - } - return(bf) -} - - - - - - - - - - -#' @keywords internal -.interpret_bf <- function(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961", return_rules = TRUE) { - if (x < 1) { - x <- 1 / abs(x) - dir <- "against" - } else { - dir <- "in favour of" - } - - - if (!is.list(rules)) { - if (rules == "jeffreys1961") { - rules <- list( - "no" = 0, - "anecdotal" = 1, - "moderate" = 3, - "strong" = 10, - "very strong" = 30, - "extreme" = 100 - ) - } else if (rules == "raftery1995") { - rules <- list( - "no" = 0, - "weak" = 1, - "positive" = 3, - "strong" = 20, - "very strong" = 150 - ) - } else { - stop("rules must be either a list or 'jeffreys1961' or 'raftery1995'.") - } - } - - - - s <- (abs(x) - unlist(rules)) - s <- names(which.min(s[s >= 0])) - if (is.null(s)) { - s <- NA - } else { - s <- paste(s, "evidence") - } - - - - - if (bf == TRUE) { - bf <- paste0("(", format_bf(x), ")") - s <- paste(s, bf) - } - if (direction == TRUE) { - s <- paste(s, dir) - } - - return(s) -} diff --git a/R/interpret_d.R b/R/interpret_d.R deleted file mode 100644 index f856423..0000000 --- a/R/interpret_d.R +++ /dev/null @@ -1,174 +0,0 @@ -#' Standardized difference (Cohen's d) interpreation. -#' -#' Interpret d with a set of rules. -#' -#' @param x Standardized difference. -#' @param direction Return direction. -#' @param rules Can be "cohen1988" (default), "sawilowsky2009", or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_d(-0.42) -#' interpret_d(-0.62) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_d <- function(x, direction = FALSE, rules = "cohen1988") { - interpretation <- sapply(x, .interpret_d, direction = direction, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - - - -#' Standardized difference (Cohen's d) interpreation for a posterior distribution. -#' -#' Interpret d with a set of rules. -#' -#' @param posterior Posterior distribution of standardized differences. -#' @param rules Can be "cohen1988" (default), "sawilowsky2009", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.6, 0.05) -#' interpret_d_posterior(posterior) -#' interpret_d_posterior(rnorm(1000, 0.1, 1)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_d_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_d, rules = rules, direction = TRUE, return_rules = TRUE) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") %>% - tidyr::separate("Interpretation", - c("Size", "Direction"), - " and ", - remove = FALSE - ) %>% - mutate_( - "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', - "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", - "Size" = "factor(Size)" - ) %>% - arrange_("Size") - - values <- list() - for (size in names(sort(rules, decreasing = TRUE))) { - if (size %in% summary$Size) { - if (nrow(summary[summary$Size == size & summary$Opposite == FALSE, ]) == 0) { - values[size] <- 0 - } else { - values[size] <- summary[summary$Size == size & summary$Opposite == FALSE, ]$Probability - } - } else { - values[size] <- 0 - } - } - values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) - - - # Text - if (length(summary[summary$Opposite == FALSE, ]$Size) > 1) { - text_sizes <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Size, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Size, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary[summary$Opposite == FALSE, ]$Size - text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - -#' @keywords internal -.interpret_d <- function(x, direction = FALSE, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.2, - "medium" = 0.5, - "large" = 0.8 - ) - } else if (rules == "sawilowsky2009") { - rules <- list( - "tiny" = 0, - "very small" = 0.1, - "small" = 0.2, - "medium" = 0.5, - "large" = 0.8, - "very large" = 1.2, - "huge" = 2.0 - ) - } else { - stop("rules must be either a list or 'cohen1988' or 'sawilowsky2009'.") - } - } - - - if (x > 0) { - d <- "positive" - } else { - d <- "negative" - } - - x <- (abs(x) - unlist(rules)) - s <- names(which.min(x[x >= 0])) - if (is.null(s)) { - s <- NA - } - - - if (direction) { - interpretation <- paste(s, "and", d) - } else { - interpretation <- s - } - - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} diff --git a/R/interpret_lavaan.R b/R/interpret_lavaan.R deleted file mode 100644 index 9c948f4..0000000 --- a/R/interpret_lavaan.R +++ /dev/null @@ -1,146 +0,0 @@ -#' Interpret fit measures of lavaan or blavaan objects -#' -#' Interpret fit measures of lavaan or blavaan objects -#' -#' @param fit lavaan or blavaan object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_lavaan <- function(fit, ...) { - UseMethod("interpret_lavaan") -} - - - - - - -#' Interpret fit measures of lavaan objects -#' -#' Interpret fit measures of lavaan objects -#' -#' @param fit lavaan or blavaan object. -#' @param ... Arguments passed to or from other methods. -#' -#' @importFrom lavaan fitmeasures -#' @export -interpret_lavaan.lavaan <- function(fit, ...) { - values <- list() - - indices <- lavaan::fitmeasures(fit) - - - for (index in names(indices)) { - values[index] <- indices[index] - } - - # awang2012 - # https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM - if (values$cfi >= 0.9) { - cfi <- "satisfactory" - } else { - cfi <- "poor" - } - if (values$rmsea <= 0.08) { - rmsea <- "satisfactory" - } else { - rmsea <- "poor" - } - if (values$gfi >= 0.9) { - gfi <- "satisfactory" - } else { - gfi <- "poor" - } - if (values$tli >= 0.9) { - tli <- "satisfactory" - } else { - tli <- "poor" - } - if (values$nfi >= 0.9) { - nfi <- "satisfactory" - } else { - nfi <- "poor" - } - - # Summary - summary <- data.frame( - Index = c("RMSEA", "CFI", "GFI", "TLI", "NFI", "Chisq"), - Value = c(values$rmsea, values$cfi, values$gfi, values$tli, values$nfi, values$chisq), - Interpretation = c(rmsea, cfi, gfi, tli, nfi, NA), - Treshold = c("< .08", "> .90", "> 0.90", "> 0.90", "> 0.90", NA) - ) - - # Text - if ("satisfactory" %in% summary$Interpretation) { - satisfactory <- summary %>% - filter_("Interpretation == 'satisfactory'") %>% - mutate_("Index" = "paste0(Index, ' (', format_digit(Value), ' ', Treshold, ')')") %>% - select_("Index") %>% - pull() %>% - paste0(collapse = ", ") - satisfactory <- paste0("The ", satisfactory, " show satisfactory indices of fit.") - } else { - satisfactory <- "" - } - if ("poor" %in% summary$Interpretation) { - poor <- summary %>% - filter_("Interpretation == 'poor'") %>% - mutate_( - "Treshold" = 'stringr::str_replace(Treshold, "<", "SUP")', - "Treshold" = 'stringr::str_replace(Treshold, ">", "INF")', - "Treshold" = 'stringr::str_replace(Treshold, "SUP", ">")', - "Treshold" = 'stringr::str_replace(Treshold, "INF", "<")' - ) %>% - mutate_("Index" = "paste0(Index, ' (', format_digit(Value), ' ', Treshold, ')')") %>% - select_("Index") %>% - pull() %>% - paste0(collapse = ", ") - poor <- paste0("The ", poor, " show poor indices of fit.") - } else { - poor <- "" - } - text <- paste(satisfactory, poor) - - output <- list(text = text, summary = summary, values = values, plot = "Not available yet") - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - -#' Interpret fit measures of blavaan objects -#' -#' Interpret fit measures of blavaan objects -#' -#' @param indices Vector of strings indicating which indices to report. Only works for bayesian objects for now. -#' @inheritParams interpret_lavaan -#' @export -interpret_lavaan.blavaan <- function(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) { - values <- list() - - indices <- lavaan::fitmeasures(fit) - - - for (index in names(indices)) { - values[index] <- indices[index] - } - - # Summary - summary <- as.data.frame(indices) %>% - rownames_to_column("Index") %>% - rename_("Value" = "indices") %>% - mutate_("Index" = "str_to_upper(Index)") - - # Text - relevant_indices <- summary[summary$Index %in% c("BIC", "DIC", "WAIC", "LOOIC"), ] - text <- paste0(relevant_indices$Index, " = ", format_digit(relevant_indices$Value), collapse = ", ") - - output <- list(text = text, summary = summary, values = values, plot = "Not available yet") - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/interpret_odds.R b/R/interpret_odds.R deleted file mode 100644 index e26c81c..0000000 --- a/R/interpret_odds.R +++ /dev/null @@ -1,231 +0,0 @@ -#' Odds ratio interpreation for a posterior distribution. -#' -#' Interpret odds with a set of rules. -#' -#' @param x Odds ratio. -#' @param log Are these log odds ratio? -#' @param direction Return direction. -#' @param rules Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_odds(x = 2) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize -#' -#' @references -#' \itemize{ -#' \item{Chen, H., Cohen, P., & Chen, S. (2010). How big is a big odds ratio? Interpreting the magnitudes of odds ratios in epidemiological studies. Communications in Statistics—Simulation and Computation®, 39(4), 860-864.} -#' } -#' @export -interpret_odds <- function(x, log = FALSE, direction = FALSE, rules = "chen2010") { - if (rules %in% c("cohen1988", "sawilowsky2009")) { - interpretation <- sapply(odds_to_d(x, log = log), .interpret_d, direction = direction, rules = rules, return_rules = FALSE) - } else { - interpretation <- sapply(x, .interpret_odds, log = log, direction = direction, rules = rules, return_rules = FALSE) - } - return(interpretation) -} - - - - - - - - - - -#' Odds ratio interpreation for a posterior distribution. -#' -#' Interpret odds with a set of rules. -#' -#' @param posterior Posterior distribution of odds ratio. -#' @param log Are these log odds ratio? -#' @param rules Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.6, 0.05) -#' interpret_odds_posterior(posterior) -#' interpret_odds_posterior(rnorm(1000, 0.1, 1)) -#' interpret_odds_posterior(rnorm(1000, 3, 1.5)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_odds_posterior <- function(posterior, log = FALSE, rules = "chen2010") { - if (rules %in% c("cohen1988", "sawilowsky2009")) { - posterior <- odds_to_d(posterior, log = log) - interpretation <- sapply(posterior, .interpret_d, direction = TRUE, rules = rules, return_rules = TRUE) - } else { - interpretation <- sapply(posterior, .interpret_odds, log = log, direction = TRUE, rules = rules, return_rules = TRUE) - } - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") %>% - tidyr::separate("Interpretation", - c("Size", "Direction"), - " and ", - remove = FALSE - ) %>% - mutate_( - "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', - "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", - "Size" = "factor(Size)" - ) %>% - arrange_("Size") - - values <- list() - for (size in names(sort(rules, decreasing = TRUE))) { - if (size %in% summary$Size) { - if (nrow(summary[summary$Size == size & summary$Opposite == FALSE, ]) == 0) { - values[size] <- 0 - } else { - values[size] <- summary[summary$Size == size & summary$Opposite == FALSE, ]$Probability - } - } else { - values[size] <- 0 - } - } - values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) - - - # Text - if (length(summary[summary$Opposite == FALSE, ]$Size) > 1) { - text_sizes <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Size, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Size, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary[summary$Opposite == FALSE, ]$Size - text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - - - -#' @keywords internal -.interpret_odds <- function(x, log = FALSE, direction = FALSE, rules = "chen2010", return_rules = TRUE) { - if (x > 0) { - d <- "positive" - } else { - d <- "negative" - } - - if (log == TRUE) { - x <- exp(abs(x)) - } - - if (!is.list(rules)) { - if (rules == "chen2010") { - rules <- list( - "very small" = 0, - "small" = 1.68, - "medium" = 3.47, - "large" = 6.71 - ) - } else { - stop("rules must be either a list or 'chen2010'.") - } - } - - - s <- (abs(x) - unlist(rules)) - s <- names(which.min(s[s >= 0])) - if (is.null(s)) { - s <- NA - } - - if (direction) { - interpretation <- paste(s, "and", d) - } else { - interpretation <- s - } - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} - - - - - - - - - - - - - - - - - -#' (Log) odds ratio to Cohen's d -#' -#' (Log) odds ratio to Cohen's d. -#' -#' @param x Odds ratio. -#' @param log Are these log odds ratio? -#' -#' @examples -#' library(psycho) -#' odds_to_d(x = 2) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso https://www.meta-analysis.com/downloads/Meta-analysis%20Converting%20among%20effect%20sizes.pdf -#' -#' @references -#' \itemize{ -#' \item{Sánchez-Meca, J., Marín-Martínez, F., & Chacón-Moscoso, S. (2003). Effect-size indices for dichotomized outcomes in meta-analysis. Psychological methods, 8(4), 448.} -#' } -#' @export -odds_to_d <- function(x, log = TRUE) { - if (log == FALSE) { - x <- log(x) - } - d <- x * (sqrt(3) / pi) - return(d) -} diff --git a/R/interpret_omega_sq.R b/R/interpret_omega_sq.R deleted file mode 100644 index 6340362..0000000 --- a/R/interpret_omega_sq.R +++ /dev/null @@ -1,54 +0,0 @@ -#' Omega Squared Interpretation -#' -#' Return the interpretation of Omegas Squared. -#' -#' @param x Omega Squared. -#' @param rules Can be "field2013" (default), or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_omega_sq(x = 0.05) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize -#' -#' @references -#' \itemize{ -#' \item{Field, A (2013) Discovering statistics using IBM SPSS Statistics. Fourth Edition. Sage:London.} -#' } -#' @export -interpret_omega_sq <- function(x, rules = "field2013") { - interpretation <- sapply(x, .interpret_omega_sq, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - - -#' @keywords internal -.interpret_omega_sq <- function(x, rules = "field2013", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "field2013") { - rules <- list( - "very small" = 0, - "small" = 0.01, - "medium" = 0.06, - "large" = 0.14 - ) - } else { - stop("rules must be either a list or 'field2013'.") - } - } - - - - interpretation <- (abs(x) - unlist(rules)) - interpretation <- names(which.min(interpretation[interpretation >= 0])) - if (is.null(interpretation)) { - interpretation <- NA - } - - return(interpretation) -} diff --git a/R/interpret_r.R b/R/interpret_r.R deleted file mode 100644 index dc7042b..0000000 --- a/R/interpret_r.R +++ /dev/null @@ -1,186 +0,0 @@ -#' Correlation coefficient r interpreation. -#' -#' Interpret r with a set of rules. -#' -#' @param x Correlation coefficient. -#' @param direction Return direction. -#' @param strength Return strength. -#' @param rules Can be "cohen1988" (default), "evans1996", or a custom list. -#' -#' -#' @examples -#' library(psycho) -#' interpret_r(-0.42) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso Page 88 of APA's 6th Edition -#' -#' @export -interpret_r <- function(x, direction = TRUE, strength = TRUE, rules = "cohen1988") { - interpretation <- sapply(x, .interpret_r, direction = direction, strength = strength, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - - - - - -#' Correlation coefficient r interpreation for a posterior distribution. -#' -#' Interpret r with a set of rules. -#' -#' @param posterior Posterior distribution of correlation coefficient. -#' @param rules Can be "cohen1988" (default) or "evans1996", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.5, 0.5) -#' interpret_r_posterior(posterior) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso Page 88 of APA's 6th Edition -#' -#' @export -interpret_r_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_r, rules = rules) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") %>% - separate("Interpretation", - c("Strength", "Direction"), - ", and ", - remove = FALSE - ) %>% - mutate_( - "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', - "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", - "Strength" = "factor(Strength)" - ) %>% - arrange_("Strength") - - values <- list() - for (strength in names(sort(rules, decreasing = TRUE))) { - if (strength %in% summary$Strength) { - values[strength] <- summary[summary$Strength == strength & summary$Opposite == FALSE, ]$Probability - } else { - values[strength] <- 0 - } - } - values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) - - # Text - if (length(summary[summary$Opposite == FALSE, ]$Strength) > 1) { - text_strength <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Strength, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Strength, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The correlation can be considered as ", - text_strength, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary[summary$Opposite == FALSE, ]$Strength - text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") - - text <- paste0( - "The correlation can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - - - - - - - - - - - -#' @keywords internal -.interpret_r <- function(x, direction = TRUE, strength = TRUE, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "evans1996") { - rules <- list( - "very weak" = 0, - "weak" = 0.20, - "moderate" = 0.40, - "strong" = 0.60, - "very strong" = 0.80 - ) - } else if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.10, - "moderate" = 0.30, - "large" = 0.50 - ) - } else { - stop("rules must be either a list or 'cohen1988' or 'evans1996'.") - } - } - - - if (x > 0) { - d <- "positive" - } else { - d <- "negative" - } - - x <- (abs(x) - unlist(rules)) - s <- names(which.min(x[x >= 0])) - if (is.null(s)) { - s <- NA - } - - - - if (strength & direction) { - interpretation <- paste0(s, ", and ", d) - } else if (strength & direction == FALSE) { - interpretation <- s - } else { - interpretation <- d - } - - - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} diff --git a/R/is.mixed.R b/R/is.mixed.R deleted file mode 100644 index 4ced755..0000000 --- a/R/is.mixed.R +++ /dev/null @@ -1,49 +0,0 @@ -#' Check if model includes random effects. -#' -#' Check if model is mixed. See the -#' documentation for your model's class: -#' \itemize{ -#' \item{\link[=is.mixed.stanreg]{is.mixed.stanreg}} -#' } -#' -#' @param fit Model. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -is.mixed <- function(fit, ...) { - UseMethod("is.mixed") -} - - - - - - - - - - - - - -#' Check if model includes random effects. -#' -#' Check if model is mixed. -#' -#' @param fit Model. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -is.mixed.stanreg <- function(fit, ...) { - mixed <- tryCatch({ - broom::tidy(fit, parameters = "varying") - TRUE - }, error = function(e) { - FALSE - }) - return(mixed) -} diff --git a/R/is.standardized.R b/R/is.standardized.R deleted file mode 100644 index 0c90ea0..0000000 --- a/R/is.standardized.R +++ /dev/null @@ -1,41 +0,0 @@ -#' Check if a dataframe is standardized. -#' -#' Check if a dataframe is standardized. -#' -#' @param df A dataframe. -#' @param tol The error treshold. -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' is.standardized(df) -#' -#' dfZ <- psycho::standardize(df) -#' is.standardized(dfZ) -#' @return bool. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import purrr -#' @export -is.standardized <- function(df, tol = 0.1) { - dfZ <- standardize(df) - dfZnum <- purrr::keep(dfZ, is.numeric) - - dfnum <- purrr::keep(df, is.numeric) - - error <- as.matrix(dfnum) - as.matrix(dfZnum) - error <- as.data.frame(error) - names(error) <- names(dfnum) - - error_mean <- error %>% - summarise_all(mean) - - if (TRUE %in% as.character(error_mean[1, ] > tol)) { - standardized <- FALSE - } else { - standardized <- TRUE - } - return(standardized) -} diff --git a/R/mellenbergh.test.R b/R/mellenbergh.test.R deleted file mode 100644 index 52fabc0..0000000 --- a/R/mellenbergh.test.R +++ /dev/null @@ -1,83 +0,0 @@ -#' Mellenbergh & van den Brink (1998) test for pre-post comparison. -#' -#' Test for comparing post-test to baseline for a single participant. -#' -#' @param t0 Single value (pretest or baseline score). -#' @param t1 Single value (posttest score). -#' @param controls Vector of scores of the control group OR single value corresponding to the control SD of the score. -#' -#' @return Returns a data frame containing the z-value and p-value. If significant, the difference between pre and post tests is significant. -#' -#' @examples -#' library(psycho) -#' -#' mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) -#' @author Dominique Makowski -#' -#' @importFrom stats pnorm sd -#' @export -mellenbergh.test <- function(t0, t1, controls) { - if (length(controls) > 1) { - sd <- sd(controls) * sqrt(2) - } else { - sd <- controls * sqrt(2) - } - - diff <- t1 - t0 - - diff_CI_bottom <- diff - 1.65 * sd - diff_CI_top <- diff + 1.65 * sd - - z <- diff / sd - pval <- 2 * pnorm(-abs(z)) - - # One-tailed p value - if (pval > .05 & pval / 2 < .05) { - one_tailed <- paste0( - " However, the null hypothesis of no change can be rejected at a one-tailed 5% significance level (one-tailed p ", - format_p(pval / 2), - ")." - ) - } else { - one_tailed <- "" - } - - - - p_interpretation <- ifelse(pval < 0.05, " ", " not ") - text <- paste0( - "The Mellenbergh & van den Brink (1998) test suggests that the change is", - p_interpretation, - "significant (d = ", - format_digit(diff), - ", 90% CI [", - format_digit(diff_CI_bottom), - ", ", - format_digit(diff_CI_top), - "], z = ", - format_digit(z), - ", p ", - format_p(pval), - ").", - one_tailed - ) - - - values <- list( - text = text, - diff = diff, - diff_90_CI_lower = diff_CI_bottom, - diff_90_CI_higher = diff_CI_top, - z = z, - p = pval - ) - summary <- data.frame(diff = diff, diff_90_CI_lower = diff_CI_bottom, diff_90_CI_higher = diff_CI_top, z = z, p = pval) - plot <- "Not available yet" - - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) - # return("The method for no-controls is not implemented yet.") -} diff --git a/R/model_to_priors.R b/R/model_to_priors.R deleted file mode 100644 index 476c39c..0000000 --- a/R/model_to_priors.R +++ /dev/null @@ -1,99 +0,0 @@ -#' Model to Prior. -#' -#' Convert a Bayesian model's results to priors. -#' -#' @param fit A stanreg model. -#' @param autoscale Set autoscale. -#' @examples -#' \dontrun{ -#' library(rstanarm) -#' library(psycho) -#' -#' fit <- stan_glm(Sepal.Length ~ Petal.Width, data = iris) -#' priors <- model_to_priors(fit) -#' update(fit, prior = priors$prior) -#' -#' fit <- stan_glmer(Subjective_Valence ~ Emotion_Condition + (1 | Participant_ID), -#' data = psycho::emotion -#' ) -#' priors <- model_to_priors(fit) -#' -#' fit1 <- stan_glm(Subjective_Valence ~ Emotion_Condition, -#' data = filter(psycho::emotion, Participant_ID == "1S") -#' ) -#' -#' fit2 <- stan_glm(Subjective_Valence ~ Emotion_Condition, -#' data = filter(psycho::emotion, Participant_ID == "1S"), -#' prior = priors$prior, prior_intercept = priors$prior_intercept -#' ) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' @importFrom stats update -#' @importFrom rstanarm normal -#' @export -model_to_priors <- function(fit, autoscale = FALSE) { - posteriors <- as.data.frame(fit) - - # Varnames - varnames <- names(posteriors) - varnames <- varnames[grepl("b\\[", varnames) == FALSE] - - fixed_effects <- names(fit$coefficients) - fixed_effects <- fixed_effects[grepl("b\\[", fixed_effects) == FALSE] - fixed_effects <- fixed_effects[fixed_effects != "(Intercept)"] - - # Get priors - prior_intercept <- list() - priors <- list() - prior_aux <- list() - for (prior in varnames) { - if (prior == "(Intercept)") { - prior_intercept$mean <- mean(posteriors[[prior]]) - prior_intercept$sd <- sd(posteriors[[prior]]) - } else if (prior %in% fixed_effects) { - priors[[prior]] <- list() - priors[[prior]]$mean <- mean(posteriors[[prior]]) - priors[[prior]]$sd <- sd(posteriors[[prior]]) - } else { - prior_aux[[prior]] <- list() - prior_aux[[prior]]$mean <- mean(posteriors[[prior]]) - prior_aux[[prior]]$sd <- sd(posteriors[[prior]]) - } - } - - - prior_intercept <- rstanarm::normal( - prior_intercept$mean, - prior_intercept$sd, - autoscale = autoscale - ) - prior <- .format_priors(priors, autoscale = autoscale) - prior_aux <- .format_priors(prior_aux, autoscale = autoscale) - - return(list(prior_intercept = prior_intercept, prior = prior, priox_aux = prior_aux)) -} - - -#' @keywords internal -.format_priors <- function(priors, autoscale = FALSE) { - prior_mean <- data.frame(priors) %>% - select(contains("mean")) %>% - gather() %>% - select_("value") %>% - pull() - - prior_sd <- data.frame(priors) %>% - select(contains("sd")) %>% - gather() %>% - select_("value") %>% - pull() - - prior <- rstanarm::normal( - prior_mean, - prior_sd, - autoscale = autoscale - ) -} diff --git a/R/mpe.R b/R/mpe.R deleted file mode 100644 index a6e6c61..0000000 --- a/R/mpe.R +++ /dev/null @@ -1,41 +0,0 @@ -#' Compute Maximum Probability of Effect (MPE). -#' -#' Compute the Maximum Probability of Effect (MPE), i.e., the proportion of posterior distribution that is of the same sign as the median. In other words, it corresponds to the maximum probability that the effect is different from 0 in the median’s direction. -#' -#' @param posterior Posterior Distribution. -#' -#' @return list containing the MPE and its values. -#' -#' @examples -#' library(psycho) -#' library(rstanarm) -#' -#' fit <- rstanarm::stan_glm(rating ~ advance, data = attitude) -#' posterior <- psycho::analyze(fit)$values$effects$advance$posterior -#' mpe <- psycho::mpe(posterior) -#' print(mpe$MPE) -#' print(mpe$values) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -mpe <- function(posterior) { - median <- median(posterior) - if (median >= 0) { - MPE <- length(posterior[posterior >= 0]) / length(posterior) * 100 - if (MPE == 100) { - MPE_values <- c(min(posterior), max(posterior)) - } else { - MPE_values <- c(0, max(posterior)) - } - } else { - MPE <- length(posterior[posterior < 0]) / length(posterior) * 100 - if (MPE == 100) { - MPE_values <- c(min(posterior), max(posterior)) - } else { - MPE_values <- c(min(posterior), 0) - } - } - - MPE <- list(MPE = MPE, values = MPE_values) - return(MPE) -} diff --git a/R/n_factors.R b/R/n_factors.R deleted file mode 100644 index 0973bf8..0000000 --- a/R/n_factors.R +++ /dev/null @@ -1,305 +0,0 @@ -#' Find Optimal Factor Number. -#' -#' Find optimal components number using maximum method aggreement. -#' -#' @param df A dataframe or correlation matrix -#' @param rotate What rotation to use c("none", "varimax", "oblimin","promax") -#' @param fm Factoring method: "pa" for Principal Axis Factor Analysis, -#' "minres" (default) for minimum residual (OLS) factoring, "mle" for -#' Maximum Likelihood FA and "pc" for Principal Components -#' @param n If correlation matrix is passed, the sample size. -#' -#' @return output -#' -#' @examples -#' df <- dplyr::select_if(attitude, is.numeric) -#' results <- psycho::n_factors(df) -#' -#' summary(results) -#' plot(results) -#' -#' # See details on methods -#' psycho::values(results)$methods -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom qgraph cor_auto -#' @importFrom psych VSS -#' @importFrom MASS mvrnorm -#' @importFrom MASS ginv -#' @importFrom nFactors moreStats -#' @importFrom nFactors nScree -#' @importFrom stats cov -#' @importFrom stats dnorm -#' @importFrom stats qnorm -#' @export -n_factors <- function(df, rotate = "varimax", fm = "minres", n = NULL) { - - # Copy the parallel function from nFactors to correct the use of mvrnorm - parallel <- function(subject = 100, var = 10, rep = 100, cent = 0.05, - quantile = cent, model = "components", - sd = diag(1, var), ...) { - r <- subject - c <- var - y <- matrix(c(1:r * c), nrow = r, ncol = c) - evpea <- NULL - for (k in c(1:rep)) { - y <- MASS::mvrnorm(n = r, mu = rep(0, var), Sigma = sd, empirical = FALSE) - corY <- cov(y, ...) - if (model == "components") { - diag(corY) <- diag(sd) - } - if (model == "factors") { - corY <- corY - MASS::ginv(diag(diag(MASS::ginv(corY)))) - } - evpea <- rbind(evpea, eigen(corY)[[1]]) - } - SEcentile <- function(sd, n = 100, p = 0.95) { - return(sd / sqrt(n) * sqrt(p * (1 - p)) / dnorm(qnorm(p))) - } - mevpea <- sapply(as.data.frame(evpea), mean) - sevpea <- sapply(as.data.frame(evpea), sd) - qevpea <- nFactors::moreStats(evpea, quantile = quantile)[3, ] - sqevpea <- sevpea - sqevpea <- sapply( - as.data.frame(sqevpea), SEcentile, - n = rep, - p = cent - ) - result <- list( - eigen = data.frame( - mevpea, sevpea, qevpea, - sqevpea - ), - subject = r, - variables = c, - centile = cent - ) - class(result) <- "parallel" - return(result) - } - - # Detect if df us a correlation matrix - if (length(setdiff(names(df), rownames(df))) != 0) { - cor <- qgraph::cor_auto(df, forcePD = FALSE) - n <- nrow(df) - } else { - if (is.null(n)) { - stop("A correlation matrix was passed. You must provided the sample size (n).") - } - cor <- df - } - - - ap <- parallel(subject = n, var = ncol(cor)) - nS <- nFactors::nScree(x = eigen(cor)$values, aparallel = ap$eigen$qevpea) - - # Eigeinvalues data - eigenvalues <- nS$Analysis %>% - dplyr::select_( - "Eigenvalues", - "Exp.Variance" = "Prop", - "Cum.Variance" = "Cumu" - ) %>% - mutate_("n.Factors" = ~ seq_len(nrow(nS$Analysis))) - - - - - - # Processing - # ------------------- - results <- data.frame( - Method = c( - "Optimal Coordinates", - "Acceleration Factor", - "Parallel Analysis", - "Eigenvalues (Kaiser Criterion)" - ), - n_optimal = as.numeric(nS$Components[1, ]) - ) - - # EGA Method - # Doesn't really work for now :( - # ega <- EGA::EGA(cor, plot.EGA = F, matrix=TRUE, n = n) - # ega <- EGA::bootEGA(df, n = 1000) - - # VSS - vss <- psych::VSS( - cor, - n.obs = n, - rotate = rotate, - fm = fm, plot = F - ) # fm can be "pa", "pc", "minres", "mle" - stats <- vss$vss.stats - stats$map <- vss$map - stats$n_factors <- seq_len(nrow(stats)) - - # map - if (length(stats$map[!is.na(stats$map)]) > 0) { - min <- min(stats$map[!is.na(stats$map)]) - opt <- stats[stats$map == min, ]$n_factors[!is.na(stats[stats$map == min, ]$n_factors)] - results <- rbind( - results, - data.frame( - Method = c("Velicer MAP"), - n_optimal = c(opt) - ) - ) - } - # bic - if (length(stats$BIC[!is.na(stats$BIC)]) > 0) { - min <- min(stats$BIC[!is.na(stats$BIC)]) - opt <- stats[stats$BIC == min, ]$n_factors[!is.na(stats[stats$BIC == min, ]$n_factors)] - results <- rbind( - results, - data.frame( - Method = c("BIC"), - n_optimal = c(opt) - ) - ) - } - # sabic - if (length(stats$SABIC[!is.na(stats$SABIC)]) > 0) { - min <- min(stats$SABIC[!is.na(stats$SABIC)]) - opt <- stats[stats$SABIC == min, ]$n_factors[!is.na(stats[stats$SABIC == min, ]$n_factors)] - results <- rbind( - results, - data.frame( - Method = c("Sample Size Adjusted BIC"), - n_optimal = c(opt) - ) - ) - } - - - cfits <- vss[grep("cfit", names(vss))] - for (name in names(cfits)) { - cfit <- cfits[[name]] - - cfit <- data.frame(cfit = cfit, n_factors = seq_len(length(cfit))) - - result3 <- data.frame( - Method = c(gsub("cfit.", "VSS Complexity ", name)), - n_optimal = c(na.omit(cfit[cfit$cfit == max(cfit$cfit, na.rm = TRUE), ])$n_factors) - ) - - results <- rbind(results, result3) - } - - - eigenvalues <- results %>% - group_by_("n_optimal") %>% - summarise_("n_method" = ~ n()) %>% - mutate_("n_optimal" = ~ factor(n_optimal, levels = seq_len(nrow(eigenvalues)))) %>% - complete_("n_optimal", fill = list(n_method = 0)) %>% - arrange_("n_optimal") %>% - rename_( - "n.Factors" = "n_optimal", - "n.Methods" = "n_method" - ) %>% - mutate_("n.Factors" = ~ as.integer(n.Factors)) %>% - left_join(eigenvalues, by = "n.Factors") %>% - select_("-Exp.Variance") - - - # Summary - # ------------- - summary <- eigenvalues - - # Values - # ------------- - - best_n_df <- filter_(summary, "n.Methods == max(n.Methods)") - best_n <- best_n_df$n.Factors - - best_n_methods <- list() - for (i in as.list(best_n)) { - methods_list <- results[results$n_optimal %in% as.list(i), ] - methods_list <- as.character(methods_list$Method) - best_n_methods[[paste0("n_", i)]] <- paste(methods_list, collapse = ", ") - } - - - - values <- list(summary = summary, methods = results, best_n_df = best_n) - - - - # Text - # ------------- - # Deal with equality - if (length(best_n) > 1) { - best_n <- head(best_n, length(best_n) - 1) %>% - paste(collapse = ", ") %>% - paste(best_n[length(best_n)], sep = " and ") - factor_text <- " factors " - n_methods <- unique(best_n_df$n.Methods) - best_n_methods <- paste0(paste(best_n_methods, collapse = "; "), "; respectively") - } else { - n_methods <- best_n_df$n.Methods - # Plural - if (best_n == 1) { - factor_text <- " factor " - } else { - factor_text <- " factors " - } - } - - - - text <- paste0( - "The choice of ", - best_n, - factor_text, - "is supported by ", - n_methods, - " (out of ", - round(nrow(results)), - "; ", - round(n_methods / nrow(results) * 100, 2), - "%) methods (", - best_n_methods, - ")." - ) - - - # Plot - # ------------- - plot_data <- summary - plot_data$n.Methods.Ratio <- plot_data$n.Methods / sum(plot_data$n.Methods) - plot_data$n.Methods.Ratio <- plot_data$n.Methods.Ratio * (1 / max(plot_data$n.Methods.Ratio)) - plot_data$area <- plot_data$n.Methods.Ratio / (max(plot_data$n.Methods.Ratio) / max(plot_data$Eigenvalues)) - plot_data$var <- plot_data$Cum.Variance / (max(plot_data$Cum.Variance) / max(plot_data$Eigenvalues)) - - plot <- plot_data %>% - ggplot(aes_string(x = "n.Factors", y = "Eigenvalues")) + - geom_area( - aes_string(y = "area"), - fill = "#FFC107", - alpha = 0.5 - ) + - geom_line( - colour = "#E91E63", - size = 1 - ) + - geom_hline(yintercept = 1, linetype = "dashed", colour = "#607D8B") + - geom_line( - aes_string(y = "var"), - colour = "#2196F3", - size = 1 - ) + - scale_y_continuous(sec.axis = sec_axis( - trans = ~ . * (max(plot_data$Cum.Variance) / max(plot_data$Eigenvalues)), - name = "Cumulative Variance\n" - )) + - ylab("Eigenvalues\n") + - xlab("\nNumber of Factors") + - theme_minimal() - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} diff --git a/R/odds_to_probs.R b/R/odds_to_probs.R deleted file mode 100644 index 7e65932..0000000 --- a/R/odds_to_probs.R +++ /dev/null @@ -1,81 +0,0 @@ -#' Convert (log)odds to probabilies. -#' -#' @param odds Odds values in vector or dataframe. -#' @param subset Character or list of characters of column names to be -#' transformed. -#' @param except Character or list of characters of column names to be excluded -#' from transformation. -#' @param log Are these Log odds (such as in logistic models)? -#' -#' @examples -#' library(psycho) -#' odds_to_probs(-1.45) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom purrr keep discard -#' @export -odds_to_probs <- function(odds, subset = NULL, except = NULL, log = TRUE) { - - # If vector - if (ncol(as.matrix(odds)) == 1) { - return(.odds_to_probs(odds, log = log)) - } else { - df <- odds - } - - # Variable order - var_order <- names(df) - - # Keep subset - if (!is.null(subset) && subset %in% names(df)) { - to_keep <- as.data.frame(df[!names(df) %in% c(subset)]) - df <- df[names(df) %in% c(subset)] - } else { - to_keep <- NULL - } - - # Remove exceptions - if (!is.null(except) && except %in% names(df)) { - if (is.null(to_keep)) { - to_keep <- as.data.frame(df[except]) - } else { - to_keep <- cbind(to_keep, as.data.frame(df[except])) - } - - df <- df[!names(df) %in% c(except)] - } - - # Remove non-numerics - dfother <- purrr::discard(df, is.numeric) - dfnum <- purrr::keep(df, is.numeric) - - # Tranform - dfnum <- .odds_to_probs(dfnum, log = log) - - # Add non-numerics - if (is.null(ncol(dfother))) { - df <- dfnum - } else { - df <- dplyr::bind_cols(dfother, dfnum) - } - - # Add exceptions - if (!is.null(subset) | !is.null(except) && exists("to_keep")) { - df <- dplyr::bind_cols(df, to_keep) - } - - # Reorder - df <- df[var_order] - - return(df) -} - - -#' @keywords internal -.odds_to_probs <- function(odds, log = TRUE) { - if (log == TRUE) { - odds <- exp(odds) - } - probs <- odds / (1 + odds) - return(probs) -} diff --git a/R/overlap.R b/R/overlap.R deleted file mode 100644 index f24057a..0000000 --- a/R/overlap.R +++ /dev/null @@ -1,40 +0,0 @@ -#' Overlap of Two Empirical Distributions. -#' -#' A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param y Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' @param method Method of AUC computation. Can be "trapezoid" (default), "step" or "spline". -#' -#' @examples -#' library(psycho) -#' -#' x <- rnorm(100, 1, 0.5) -#' y <- rnorm(100, 0, 1) -#' overlap(x, y) -#' @author S. Venne -#' -#' @importFrom stats density -#' @importFrom DescTools AUC -#' @export -overlap <- function(x, y, method = "trapezoid") { - # define limits of a common grid, adding a buffer so that tails aren't cut off - lower <- min(c(x, y)) - 1 - upper <- max(c(x, y)) + 1 - - # generate kernel densities - da <- stats::density(x, from = lower, to = upper) - db <- stats::density(y, from = lower, to = upper) - d <- data.frame(x = da$x, a = da$y, b = db$y) - - # calculate intersection densities - d$w <- pmin(d$a, d$b) - - # integrate areas under curves - total <- DescTools::AUC(d$x, d$a, method = method) + DescTools::AUC(d$x, d$b, method = method) - intersection <- DescTools::AUC(d$x, d$w, method = method) - - # compute overlap coefficient - overlap <- 2 * intersection / total - return(overlap) -} diff --git a/R/percentile.R b/R/percentile.R deleted file mode 100644 index ad66c45..0000000 --- a/R/percentile.R +++ /dev/null @@ -1,33 +0,0 @@ -#' Transform z score to percentile. -#' -#' @param z_score Z score. -#' -#' @examples -#' library(psycho) -#' percentile(-1.96) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats pnorm -#' @export -percentile <- function(z_score) { - perc <- pnorm(z_score) * 100 - return(perc) -} - - - -#' Transform a percentile to a z score. -#' -#' @param percentile Percentile -#' -#' @examples -#' library(psycho) -#' percentile_to_z(95) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats pnorm -#' @export -percentile_to_z <- function(percentile) { - z <- qnorm(percentile / 100) - return(z) -} diff --git a/R/plot.psychobject.R b/R/plot.psychobject.R deleted file mode 100644 index 75af88d..0000000 --- a/R/plot.psychobject.R +++ /dev/null @@ -1,12 +0,0 @@ -#' Plot the results. -#' -#' @param x A psychobject class object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -plot.psychobject <- function(x, ...) { - plot <- x$plot - return(plot) -} diff --git a/R/power_analysis.R b/R/power_analysis.R deleted file mode 100644 index 05a0193..0000000 --- a/R/power_analysis.R +++ /dev/null @@ -1,89 +0,0 @@ -#' Power analysis for fitted models. -#' -#' Compute the n models based on n sampling of data. -#' -#' @param fit A lm or stanreg model. -#' @param n_max Max sample size. -#' @param n_min Min sample size. If null, take current nrow. -#' @param step Increment of the sequence. -#' @param n_batch Number of iterations at each sample size. -#' @param groups Grouping variable name (string) to preserve proportions. Can be a list of strings. -#' @param verbose Print progress. -#' @param CI Argument for \link[=analyze]{analyze}. -#' @param effsize Argument for \link[=analyze]{analyze}. -#' @param effsize_rules Argument for \link[=analyze]{analyze}. -#' @param bayes_factor Argument for \link[=analyze]{analyze}. -#' @param overlap rgument for \link[=analyze]{analyze}. -#' -#' @return A dataframe containing the summary of all models for all iterations. -#' -#' @examples -#' \dontrun{ -#' library(dplyr) -#' library(psycho) -#' -#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) -#' -#' results <- power_analysis(fit, n_max = 300, n_min = 100, step = 5, n_batch = 20) -#' -#' results %>% -#' filter(Variable == "Sepal.Width") %>% -#' select(n, p) %>% -#' group_by(n) %>% -#' summarise( -#' p_median = median(p), -#' p_mad = mad(p) -#' ) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats model.frame -#' @import dplyr -#' @export -power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, groups = NULL, verbose = TRUE, CI = 90, effsize = FALSE, effsize_rules = "cohen1988", bayes_factor = FALSE, overlap = FALSE) { - - # Parameters - df <- model.frame(fit) - - if (is.null(n_min)) { - n_min <- nrow(df) - } - - - results <- data.frame() - for (n in seq(n_min, n_max, step)) { - for (batch in 1:n_batch) { - - # Progress - if (verbose == TRUE) { - cat(".") - } - - - # Sample data.frame - if (!is.null(groups)) { - newdf <- df %>% - group_by_(groups) %>% - dplyr::sample_frac(n / nrow(df), replace = TRUE) - } else { - newdf <- dplyr::sample_frac(df, n / nrow(df), replace = TRUE) - } - - # Fit new model - newfit <- update(fit, data = newdf) - newfit <- analyze(newfit, CI = CI, effsize = effsize, bayes_factor = bayes_factor, overlap = overlap, effsize_rules = effsize_rules) - - # Store results - newresults <- summary(newfit) - newresults$n <- n - newresults$batch <- batch - results <- rbind(results, newresults) - } - # Progress - if (verbose == TRUE) { - cat(paste0(format_digit(round((n - n_min) / (n_max - n_min) * 100)), "%\n")) - } - } - return(results) -} diff --git a/R/print.psychobject.R b/R/print.psychobject.R deleted file mode 100644 index 069250f..0000000 --- a/R/print.psychobject.R +++ /dev/null @@ -1,13 +0,0 @@ -#' Print the results. -#' -#' @param x A psychobject class object. -#' @param ... Further arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -print.psychobject <- function(x, ...) { - text <- x$text - cat(text, sep = "\n") - invisible(text) -} diff --git a/R/probs_to_odds.R b/R/probs_to_odds.R deleted file mode 100644 index d56c9b8..0000000 --- a/R/probs_to_odds.R +++ /dev/null @@ -1,30 +0,0 @@ -#' Convert probabilities to (log)odds. -#' -#' @param probs Probabilities values in vector or dataframe. -#' @param log Compute log odds (such as in logistic models)? -#' -#' @examples -#' library(psycho) -#' probs_to_odds(0.75) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -probs_to_odds <- function(probs, log = FALSE) { - - # If vector - if (ncol(as.matrix(probs)) == 1) { - return(.probs_to_odds(probs, log = log)) - } else { - warning("Provide single value or vector.") - } -} - - -#' @keywords internal -.probs_to_odds <- function(probs, log = FALSE) { - odds <- probs / (1 - probs) - if (log == TRUE) { - odds <- log(odds) - } - return(odds) -} diff --git a/R/psychobject.R b/R/psychobject.R deleted file mode 100644 index 0dcac92..0000000 --- a/R/psychobject.R +++ /dev/null @@ -1,6 +0,0 @@ -#' Creates or tests for objects of mode "psychobject". -#' -#' @param x an arbitrary R object. -#' -#' @export -is.psychobject <- function(x) inherits(x, "psychobject") diff --git a/R/refdata.R b/R/refdata.R deleted file mode 100644 index a2047c2..0000000 --- a/R/refdata.R +++ /dev/null @@ -1,158 +0,0 @@ -#' Create a reference grid. -#' -#' Create a reference grid. -#' -#' @param df The dataframe. -#' @param target String or list of strings to indicate target columns. Can be "all". -#' @param length.out Length of numeric target variables. -#' @param factors Type of summary for factors. Can be "combination" or "reference". -#' @param numerics Type of summary for numerics Can be "combination", any function ("mean", "median", ...) or a value. -#' @param na.rm Remove NaNs. -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' newdata <- refdata(df, target = "Sex") -#' newdata <- refdata(df, target = "Sex", factors = "combinations") -#' newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), length.out = 3) -#' newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), numerics = 0) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom purrr keep -#' @import tidyr -#' @export -refdata <- function(df, target = "all", length.out = 10, factors = "reference", numerics = "mean", na.rm = TRUE) { - - # Target - if (all(target == "all") | ncol(df) == 1) { - return(.refdata_target(target = df[c(names(df))], length.out = length.out)) - } - - target_df <- .refdata_target(target = df[c(target)], length.out = length.out) - - # Rest - df_rest <- df[!names(df) %in% c(target)] - var_order <- names(df_rest) - - facs <- purrr::discard(df_rest, is.numeric) - facs <- mutate_all(facs, as.factor) - nums <- purrr::keep(df_rest, is.numeric) - - - smart_summary <- function(x, numerics) { - if (na.rm == TRUE) x <- na.omit(x) - - if (is.numeric(x)) { - fun <- paste0(numerics, "(x)") - out <- eval(parse(text = fun)) - } else if (is.factor(x)) { - out <- levels(x)[1] - } else if (is.character(x)) { - out <- unique(x)[1] - } else if (is.logical(x)) { - out <- unique(x)[1] - } else { - warning("Argument is not numeric nor factor: returning NA.") - out <- NA - } - return(out) - } - - - if (factors == "reference") { - facs <- dplyr::summarise_all(facs, smart_summary) - } else { - facs <- tidyr::expand_(facs, names(facs)) - } - - if (is.numeric(numerics)) { - nums[1, ] <- numerics - nums <- nums[1, ] - } else if (numerics == "combination") { - nums <- tidyr::expand_(nums, names(nums)) - } else { - nums <- dplyr::summarise_all(nums, smart_summary, numerics) - } - - - if (nrow(facs) == 0 | ncol(facs) == 0) { - refrest <- nums - } else if (nrow(nums) == 0 | ncol(nums) == 0) { - refrest <- facs - } else { - refrest <- merge(facs, nums) - } - - refrest <- refrest[var_order] - refdata <- merge(target_df, refrest) - - return(refdata) -} - - - - - - - - - - -#' @keywords internal -.refdata_target <- function(target, length.out = 10) { - at_vars <- names(target) - at_df <- data.frame() - for (var in at_vars) { - ref_var <- .refdata_var(x = target[[var]], length.out = length.out, varname = var) - if (nrow(at_df) == 0) { - at_df <- ref_var - } else { - at_df <- merge(at_df, ref_var) - } - } - return(at_df) -} - - - - - - - - - - - - - - - - - - -#' @keywords internal -.refdata_var <- function(x, length.out = 10, varname = NULL) { - if (is.numeric(x)) { - out <- data.frame(seq(min(x, na.rm = TRUE), - max(x, na.rm = TRUE), - length.out = length.out - )) - } else if (is.factor(x)) { - out <- data.frame(levels(x)) - } else if (is.character(x)) { - x <- as.factor(x) - out <- data.frame(levels(x)) - } else { - warning("Argument is not numeric nor factor: returning NA.") - out <- NA - return() - } - - if (is.null(varname)) { - names(out) <- "x" - } else { - names(out) <- varname - } - return(out) -} diff --git a/R/remove_empty_cols.R b/R/remove_empty_cols.R deleted file mode 100644 index 9590e4c..0000000 --- a/R/remove_empty_cols.R +++ /dev/null @@ -1,13 +0,0 @@ -#' Remove empty columns. -#' -#' Removes all columns containing ony NaNs. -#' -#' @param df Dataframe. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -remove_empty_cols <- function(df) { - df <- df[, colSums(is.na(df)) < nrow(df)] - return(df) -} diff --git a/R/remove_outliers.R b/R/remove_outliers.R deleted file mode 100644 index 0fde152..0000000 --- a/R/remove_outliers.R +++ /dev/null @@ -1,43 +0,0 @@ -#' Remove outliers. -#' -#' Removes outliers (with the z-score method only for now). -#' -#' @param df Dataframe. -#' @param target String or list of strings of variables -#' @param threshold The z-score value (deviation of SD) by which to consider outliers. -#' @param direction Can be "both", "upper" or "lower". -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -remove_outliers <- function(df, target, threshold = qnorm(0.95), direction = "both") { - for (var in c(target)) { - df <- .remove_outliers(df, var, threshold, direction) - } - return(df) -} - - - - - - -#' @keywords internal -.remove_outliers <- function(df, target, threshold = qnorm(0.95), direction = "both") { - df <- df %>% - mutate_("outlier_criterion" = target) %>% - standardize(subset = "outlier_criterion") - if (direction %in% c("both", "upper")) { - df <- df %>% - filter_("outlier_criterion <= threshold") - } - if (direction %in% c("both", "lower")) { - df <- df %>% - filter_("outlier_criterion >= -threshold") - } - - df <- df %>% - select_("-outlier_criterion") - - return(df) -} diff --git a/R/rnorm_perfect.R b/R/rnorm_perfect.R deleted file mode 100644 index e9d8c57..0000000 --- a/R/rnorm_perfect.R +++ /dev/null @@ -1,26 +0,0 @@ -#' Perfect Normal Distribution. -#' -#' Generates a sample of size n with a near-perfect normal distribution. -#' -#' @param n number of observations. If length(n) > 1, the length is taken to be the number required. -#' @param mean vector of means. -#' @param sd vector of standard deviations. -#' @param method "qnorm" or "average". -#' @param iter number of iterations (precision). -#' -#' @examples -#' library(psycho) -#' x <- rnorm_perfect(10) -#' plot(density(x)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats rnorm -#' @export -rnorm_perfect <- function(n, mean = 0, sd = 1, method = "qnorm", iter = 10000) { - if (method == "average") { - x <- rowMeans(replicate(iter, sort(rnorm(n, mean, sd)))) - } else { - x <- qnorm(seq(1 / n, 1 - 1 / n, length.out = n), mean, sd) - } - return(x) -} diff --git a/R/rope.R b/R/rope.R deleted file mode 100644 index 9f705c7..0000000 --- a/R/rope.R +++ /dev/null @@ -1,61 +0,0 @@ -#' Region of Practical Equivalence (ROPE) -#' -#' Compute the proportion of a posterior distribution that lies within a region of practical equivalence. -#' -#' @param posterior Posterior Distribution. -#' @param bounds Rope lower and higher bounds. -#' @param CI The credible interval to use. -#' @param overlap Compute rope overlap (EXPERIMENTAL). -#' -#' -#' @return list containing rope indices -#' -#' @examples -#' library(psycho) -#' -#' posterior <- rnorm(1000, 0, 0.01) -#' results <- rope(posterior) -#' results$decision -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -rope <- function(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = FALSE) { - - - # Basic rope -------------------------------------------------------------- - - - HDI_area <- HDI(posterior, CI / 100) - HDI_area <- posterior[dplyr::between( - posterior, - HDI_area$values$HDImin, - HDI_area$values$HDImax - )] - - area_within <- HDI_area[dplyr::between(HDI_area, bounds[1], bounds[2])] - area_outside <- HDI_area[!dplyr::between(HDI_area, bounds[1], bounds[2])] - - p_within <- length(area_within) / length(posterior) - p_outside <- length(area_outside) / length(posterior) - - rope_decision <- ifelse(p_within == 0, "Accept", - ifelse(p_outside == 0, "Reject", "Undecided") - ) - - - - # Rope Overlap ------------------------------------------------------------ - if (overlap == TRUE) { - sd <- abs(bounds[1] - bounds[2]) / 2 - sd <- sd / 3 - norm <- rnorm_perfect(length(posterior), 0, sd) - rope_overlap <- overlap(posterior, norm) * 100 - output <- list(rope_decision = rope_decision, rope_probability = p_within, rope_overlap = rope_overlap) - } else { - output <- list(rope_decision = rope_decision, rope_probability = p_within) - } - - - - return(output) -} diff --git a/R/simulate.R b/R/simulate.R deleted file mode 100644 index e6dcc06..0000000 --- a/R/simulate.R +++ /dev/null @@ -1,56 +0,0 @@ -#' Simulates data for single or multiple regression. -#' -#' Simulates data for single or multiple regression. -#' -#' @param coefs Desired theorethical coefs. Can be a single value or a list. -#' @param sample Desired sample size. -#' @param error The error (standard deviation of gaussian noise). -#' -#' @examples -#' library(psycho) -#' -#' data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) -#' fit <- lm(y ~ ., data = data) -#' coef(fit) -#' analyze(fit) -#' @details See https://stats.stackexchange.com/questions/59062/multiple-linear-regression-simulation -#' -#' @author TPArrow -#' -#' @export -simulate_data_regression <- function(coefs = 0.5, sample = 100, error = 0) { - - # Prevent error - coefs[coefs == 0] <- 0.01 - - y <- rnorm(sample, 0, 1) - - n_var <- length(coefs) - X <- scale(matrix(rnorm(sample * (n_var), 0, 1), ncol = n_var)) - X <- cbind(y, X) - - # find the current correlation matrix - cor_0 <- var(X) - - # cholesky decomposition to get independence - chol_0 <- solve(chol(cor_0)) - - X <- X %*% chol_0 - - # create new correlation structure (zeros can be replaced with other r vals) - coefs_structure <- diag(x = 1, nrow = n_var + 1, ncol = n_var + 1) - coefs_structure[-1, 1] <- coefs - coefs_structure[1, -1] <- coefs - - X <- X %*% chol(coefs_structure) * sd(y) + mean(y) - X <- X[, -1] - - # Add noise - y <- y + rnorm(sample, 0, error) - - data <- data.frame(X) - names(data) <- paste0("V", 1:n_var) - data$y <- as.vector(y) - - return(data) -} diff --git a/R/standardize.R b/R/standardize.R deleted file mode 100644 index ad7c1b7..0000000 --- a/R/standardize.R +++ /dev/null @@ -1,493 +0,0 @@ -#' Standardize. -#' -#' Standardize objects. See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=standardize.numeric]{standardize.numeric}} -#' \item{\link[=standardize.data.frame]{standardize.data.frame}} -#' \item{\link[=standardize.stanreg]{standardize.stanreg}} -#' \item{\link[=standardize.lm]{standardize.lm}} -#' \item{\link[=standardize.glm]{standardize.glm}} -#' } -#' -#' @param x Object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -standardize <- function(x, ...) { - UseMethod("standardize") -} - - - - - - - - - - - - - - - - - - - - - - - - -#' Standardize (scale and reduce) numeric variables. -#' -#' Standardize (Z-score, "normalize") a vector. -#' -#' @param x Numeric vector. -#' @param normalize Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' standardize(x = c(1, 4, 6, 2)) -#' standardize(x = c(1, 4, 6, 2), normalize = TRUE) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -standardize.numeric <- function(x, normalize = FALSE, ...) { - if (all(is.na(x)) | length(unique(x)) == 2) { - return(x) - } - - if (normalize == FALSE) { - return(as.vector(scale(x, ...))) - } else { - return(as.vector((x - min(x, na.rm = TRUE)) / diff(range(x, na.rm = TRUE), na.rm = TRUE))) - } -} - - - - - - - - - - - - - - - - - - -#' Standardize (scale and reduce) Dataframe. -#' -#' Selects numeric variables and standardize (Z-score, "normalize") them. -#' -#' @param x Dataframe. -#' @param subset Character or list of characters of column names to be -#' standardized. -#' @param except Character or list of characters of column names to be excluded -#' from standardization. -#' @param normalize Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1. -#' @param ... Arguments passed to or from other methods. -#' -#' @return Dataframe. -#' -#' @examples -#' \dontrun{ -#' df <- data.frame( -#' Participant = as.factor(rep(1:25, each = 4)), -#' Condition = base::rep_len(c("A", "B", "C", "D"), 100), -#' V1 = rnorm(100, 30, .2), -#' V2 = runif(100, 3, 5), -#' V3 = rnorm(100, 100, 10) -#' ) -#' -#' dfZ <- standardize(df) -#' dfZ <- standardize(df, except = "V3") -#' dfZ <- standardize(df, except = c("V1", "V2")) -#' dfZ <- standardize(df, subset = "V3") -#' dfZ <- standardize(df, subset = c("V1", "V2")) -#' dfZ <- standardize(df, normalize = TRUE) -#' -#' # Respects grouping -#' dfZ <- df %>% -#' dplyr::group_by(Participant) %>% -#' standardize(df) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @importFrom purrr keep discard -#' @import dplyr -#' @export -standardize.data.frame <- function(x, subset = NULL, except = NULL, normalize = FALSE, ...) { - if (inherits(x, "grouped_df")) { - dfZ <- x %>% dplyr::do_(".standardize_df(., subset=subset, except=except, normalize=normalize, ...)") - } else { - dfZ <- .standardize_df(x, subset = subset, except = except, normalize = normalize, ...) - } - - return(dfZ) -} - - - - - - - - - - - - - - - - - -#' @keywords internal -.standardize_df <- function(x, subset = NULL, except = NULL, normalize = FALSE, ...) { - df <- x - - # Variable order - var_order <- names(df) - - # Keep subset - if (!is.null(subset) && subset %in% names(df)) { - to_keep <- as.data.frame(df[!names(df) %in% c(subset)]) - df <- df[names(df) %in% c(subset)] - } else { - to_keep <- NULL - } - - # Remove exceptions - if (!is.null(except) && except %in% names(df)) { - if (is.null(to_keep)) { - to_keep <- as.data.frame(df[except]) - } else { - to_keep <- cbind(to_keep, as.data.frame(df[except])) - } - - df <- df[!names(df) %in% c(except)] - } - - # Remove non-numerics - dfother <- purrr::discard(df, is.numeric) - dfnum <- purrr::keep(df, is.numeric) - - # Scale - dfnum <- as.data.frame(sapply(dfnum, standardize, normalize = normalize)) - - # Add non-numerics - if (is.null(ncol(dfother))) { - df <- dfnum - } else { - df <- dplyr::bind_cols(dfother, dfnum) - } - - # Add exceptions - if (!is.null(subset) | !is.null(except) && exists("to_keep")) { - df <- dplyr::bind_cols(df, to_keep) - } - - # Reorder - df <- df[var_order] - - return(df) -} - - - - - - - - - - - - - -#' Standardize Posteriors. -#' -#' Compute standardized posteriors from which to get standardized coefficients. -#' -#' @param x A stanreg model. -#' @param method "refit" (default) will entirely refit the model based on standardized data. Can take a long time. Other post-hoc methods are "posterior" (based on estimated SD) or "sample" (based on the sample SD). -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = iris) -#' fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = standardize(iris)) -#' posteriors <- standardize(fit) -#' posteriors <- standardize(fit, method = "posterior") -#' } -#' -#' @author \href{https://github.com/jgabry}{Jonah Gabry}, \href{https://github.com/bgoodri}{bgoodri} -#' -#' @seealso https://github.com/stan-dev/rstanarm/issues/298 -#' -#' @importFrom utils capture.output -#' @export -standardize.stanreg <- function(x, method = "refit", ...) { - fit <- x - - predictors <- get_info(fit)$predictors - predictors <- c("(Intercept)", predictors) - - if (method == "sample") { - # By jgabry - predictors <- all.vars(as.formula(fit$formula)) - outcome <- predictors[[1]] - X <- as.matrix(model.matrix(fit)[, -1]) # -1 to drop column of 1s for intercept - sd_X_over_sd_y <- apply(X, 2, sd) / sd(fit$data[[outcome]]) - beta <- as.matrix(fit, pars = colnames(X)) # posterior distribution of regression coefficients - posteriors_std <- sweep(beta, 2, sd_X_over_sd_y, "*") # multiply each row of b by sd_X_over_sd_y - } else if (method == "posterior") { - # By bgoordi - X <- model.matrix(fit) - # if(preserve_factors == TRUE){ - # X <- as.data.frame(X) - # X[!names(as.data.frame(X)) %in% predictors] <- scale(X[!names(as.data.frame(X)) %in% predictors]) - # X <- as.matrix(X) - # } - sd_X <- apply(X, MARGIN = 2, FUN = sd)[-1] - sd_Y <- apply(rstanarm::posterior_predict(fit), MARGIN = 1, FUN = sd) - beta <- as.matrix(fit)[, 2:ncol(X), drop = FALSE] - posteriors_std <- sweep( - sweep(beta, MARGIN = 2, STATS = sd_X, FUN = `*`), - MARGIN = 1, STATS = sd_Y, FUN = `/` - ) - } else { - useless_output <- capture.output(fit_std <- update(fit, data = standardize(fit$data))) - posteriors_std <- as.data.frame(fit_std) - } - - return(posteriors_std) -} - - - - - - - -#' Standardize Coefficients. -#' -#' Compute standardized coefficients. -#' -#' @param x A linear model. -#' @param method The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "agresti". -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Sex), data = psycho::affective, family = "binomial") -#' -#' standardize(fit) -#' } -#' -#' @author Kamil Barton -#' @importFrom stats model.frame model.response model.matrix -#' -#' @seealso https://think-lab.github.io/d/205/ -#' -#' @export -standardize.glm <- function(x, method = "refit", ...) { - fit <- x - - if (method == "agresti") { - coefs <- MuMIn::coefTable(fit)[, 1:2] - X <- as.matrix(model.matrix(fit)[, -1]) # -1 to drop column of 1s for intercept - sd_X <- sd(X, na.rm = TRUE) - coefs <- coefs * sd_X - } else { - # refit method - data <- get_data(fit) - fit_std <- update(fit, data = standardize(data)) - - - coefs <- MuMIn::coefTable(fit_std)[, 1:2] - } - - coefs <- as.data.frame(coefs) - names(coefs) <- c("Coef_std", "SE_std") - return(coefs) -} - -#' @export -standardize.glmerMod <- standardize.glm - - - -#' Standardize Coefficients. -#' -#' Compute standardized coefficients. -#' -#' @param x A linear model. -#' @param method The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "posthoc". -#' @param partial_sd Logical, if set to TRUE, model coefficients are multiplied by partial SD, otherwise they are multiplied by the ratio of the standard deviations of the independent variable and dependent variable. -#' @param preserve_factors Standardize factors-related coefs only by the dependent variable (i.e., do not standardize the dummies generated by factors). -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' df <- mtcars %>% -#' mutate(cyl = as.factor(cyl)) -#' -#' fit <- lm(wt ~ mpg * cyl, data = df) -#' fit <- lmerTest::lmer(wt ~ mpg * cyl + (1 | gear), data = df) -#' -#' summary(fit) -#' standardize(fit) -#' } -#' -#' @author Kamil Barton -#' @importFrom stats model.frame model.response model.matrix -#' -#' @export -standardize.lm <- function(x, method = "refit", partial_sd = FALSE, preserve_factors = TRUE, ...) { - fit <- x - - if (method == "posthoc") { - coefs <- .standardize_coefs(fit, partial_sd = partial_sd, preserve_factors = preserve_factors) - } else { - data <- get_data(fit) - fit_std <- update(fit, data = standardize(data)) - coefs <- MuMIn::coefTable(fit_std)[, 1:2] - } - - coefs <- as.data.frame(coefs) - names(coefs) <- c("Coef_std", "SE_std") - return(coefs) -} - - -#' @export -standardize.lmerMod <- standardize.lm - - - - - - - - - - - - - - - - - -#' @keywords internal -.partialsd <- - function(x, sd, vif, n, p = length(x) - 1) { - sd * sqrt(1 / vif) * sqrt((n - 1) / (n - p)) - } - - -#' @importFrom stats vcov -#' @keywords internal -.vif <- - function(x) { - v <- vcov(x) - nam <- dimnames(v)[[1L]] - if (dim(v)[1L] < 2L) { - return(structure(rep_len(1, dim(v)[1L]), - names = dimnames(v)[[1L]] - )) - } - if ((ndef <- sum(is.na(MuMIn::coeffs(x)))) > 0L) { - stop(sprintf(ngettext( - ndef, "one coefficient is not defined", - "%d coefficients are not defined" - ), ndef)) - } - o <- attr(model.matrix(x), "assign") - if (any(int <- (o == 0))) { - v <- v[!int, !int, drop = FALSE] - } else { - warning("no intercept: VIFs may not be sensible") - } - d <- sqrt(diag(v)) - rval <- numeric(length(nam)) - names(rval) <- nam - rval[!int] <- diag(solve(v / (d %o% d))) - rval[int] <- 1 - rval - } - - - -#' @importFrom stats nobs vcov -#' @keywords internal -.standardize_coefs <- function(fit, partial_sd = FALSE, preserve_factors = TRUE, ...) { - # coefs <- MuMIn::coefTable(fit, ...) - coefs <- as.data.frame(MuMIn::coefTable(fit)) - model_matrix <- model.matrix(fit) - - predictors <- get_info(fit)$predictors - predictors <- c("(Intercept)", predictors) - - if (preserve_factors == TRUE) { - response_sd <- sd(model.response(model.frame(fit))) - factors <- as.data.frame(model_matrix)[!names(as.data.frame(model_matrix)) %in% predictors] - bx_factors <- rep(1 / response_sd, length(names(factors))) - bx_factors <- data.frame(t(bx_factors)) - names(bx_factors) <- names(factors) - coefs_factors <- coefs[names(factors), ] - model_matrix_factors <- as.matrix(factors) - - coefs <- coefs[!rownames(coefs) %in% names(factors), ] - model_matrix <- as.matrix(as.data.frame(model_matrix)[names(as.data.frame(model_matrix)) %in% predictors]) - } - - if (partial_sd == TRUE) { - bx <- .partialsd( - coefs[, 1L], - apply(model_matrix, 2L, sd), - .vif(fit), - nobs(fit), - sum(attr(model_matrix, "assign") != 0) - ) - } else { - response_sd <- sd(model.response(model.frame(fit))) - bx <- apply(model_matrix, 2L, sd) / response_sd - } - bx <- as.data.frame(t(bx)) - names(bx) <- row.names(coefs) - - if (preserve_factors == TRUE) { - bx <- cbind(bx, bx_factors) - } - - - # coefs <- MuMIn::coefTable(fit, ...) - coefs <- as.data.frame(MuMIn::coefTable(fit)) - multiplier <- as.numeric(bx[row.names(coefs)]) - - coefs[, 1L:2L] <- coefs[, 1L:2L] * multiplier - colnames(coefs)[1L:2L] <- c("Coef.std", "SE.std") - return(coefs) -} diff --git a/R/startup_message.R b/R/startup_message.R new file mode 100644 index 0000000..3b8a37d --- /dev/null +++ b/R/startup_message.R @@ -0,0 +1,3 @@ +.onAttach <- function(libname, pkgname) { + packageStartupMessage("message: psycho's `analyze()` is deprecated in favour of the report package. Check it out at https://github.com/easystats/report") +} diff --git a/R/summary.psychobject.R b/R/summary.psychobject.R deleted file mode 100644 index 8c39880..0000000 --- a/R/summary.psychobject.R +++ /dev/null @@ -1,25 +0,0 @@ -#' Print the results. -#' -#' Print the results. -#' -#' @param object A psychobject class object. -#' @param round Round the ouput. -#' @param ... Further arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @method summary psychobject -#' @export -summary.psychobject <- function(object, round = NULL, ...) { - summary <- object$summary - - if (!is.null(round)) { - nums <- dplyr::select_if(summary, is.numeric) - nums <- round(nums, round) - fact <- dplyr::select_if(summary, is.character) - fact <- cbind(fact, dplyr::select_if(summary, is.factor)) - summary <- cbind(fact, nums) - } - - return(summary) -} diff --git a/R/values.R b/R/values.R deleted file mode 100644 index e28dc37..0000000 --- a/R/values.R +++ /dev/null @@ -1,11 +0,0 @@ -#' Extract values as list. -#' -#' @param x A psychobject class object. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -values <- function(x) { - values <- x$values - return(values) -} diff --git a/README.md b/README.md index 5cb3cb7..0d3e164 100644 --- a/README.md +++ b/README.md @@ -12,7 +12,6 @@ [![codecov](https://codecov.io/gh/neuropsychology/psycho.R/branch/master/graph/badge.svg)](https://codecov.io/gh/neuropsychology/psycho.R) [![Dependency Status](https://dependencyci.com/github/neuropsychology/psycho.R/badge)](https://dependencyci.com/github/neuropsychology/psycho.R) [![CRAN downloads month](https://cranlogs.r-pkg.org/badges/psycho)](https://CRAN.R-project.org/package=psycho) -[![HitCount](http://hits.dwyl.io/neuropsychology/neuropsychology/Psycho.r.svg)](http://hits.dwyl.io/neuropsychology/neuropsychology/Psycho.r) @@ -27,6 +26,10 @@ |Authors|[![](https://img.shields.io/badge/CV-D._Makowski-purple.svg?colorB=9C27B0)](https://dominiquemakowski.github.io/)| |Reference|[![DOI](http://joss.theoj.org/papers/10.21105/joss.00470/status.svg)](https://doi.org/10.21105/joss.00470)| +--- + + +:warning: **NOTE: This package is being deprecated in favour of the [report](https://github.com/easystats/report) package. Please check it out and ask for any missing features.** --- diff --git a/man/HDImax.Rd b/man/HDImax.Rd index e2bb438..eb2a78b 100644 --- a/man/HDImax.Rd +++ b/man/HDImax.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hdi.R +% Please edit documentation in R/deprecated.R \name{HDImax} \alias{HDImax} \title{Highest Density Intervals (HDI)} diff --git a/man/HDImin.Rd b/man/HDImin.Rd index 023e147..52e2c15 100644 --- a/man/HDImin.Rd +++ b/man/HDImin.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hdi.R +% Please edit documentation in R/deprecated.R \name{HDImin} \alias{HDImin} \title{Highest Density Intervals (HDI)} diff --git a/man/R2_LOO_Adjusted.Rd b/man/R2_LOO_Adjusted.Rd index 0017360..e7d5e56 100644 --- a/man/R2_LOO_Adjusted.Rd +++ b/man/R2_LOO_Adjusted.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{R2_LOO_Adjusted} \alias{R2_LOO_Adjusted} \title{Compute LOO-adjusted R2.} diff --git a/man/R2_nakagawa.Rd b/man/R2_nakagawa.Rd index 52288bd..db8a858 100644 --- a/man/R2_nakagawa.Rd +++ b/man/R2_nakagawa.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{R2_nakagawa} \alias{R2_nakagawa} \title{Pseudo-R-squared for Generalized Mixed-Effect models.} diff --git a/man/R2_tjur.Rd b/man/R2_tjur.Rd index c14f27e..c6acaad 100644 --- a/man/R2_tjur.Rd +++ b/man/R2_tjur.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{R2_tjur} \alias{R2_tjur} \title{Tjur's (2009) coefficient of determination.} diff --git a/man/affective.Rd b/man/affective.Rd index 25178ac..855d480 100644 --- a/man/affective.Rd +++ b/man/affective.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/affective.R +% Please edit documentation in R/data_affective.R \docType{data} \name{affective} \alias{affective} diff --git a/man/analyze.Rd b/man/analyze.Rd index 422ecc6..6fafb94 100644 --- a/man/analyze.Rd +++ b/man/analyze.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.R +% Please edit documentation in R/deprecated.R \name{analyze} \alias{analyze} \title{Analyze objects.} diff --git a/man/analyze.aov.Rd b/man/analyze.aov.Rd index 83069c9..47b2447 100644 --- a/man/analyze.aov.Rd +++ b/man/analyze.aov.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.anova.R +% Please edit documentation in R/deprecated.R \name{analyze.aov} \alias{analyze.aov} -\title{Analyze aov and anova objects.} +\title{Analyze aov and anova objects} \usage{ \method{analyze}{aov}(x, effsize_rules = "field2013", ...) } diff --git a/man/analyze.blavaan.Rd b/man/analyze.blavaan.Rd index d2af880..3d4710c 100644 --- a/man/analyze.blavaan.Rd +++ b/man/analyze.blavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.blavaan.R +% Please edit documentation in R/deprecated.R \name{analyze.blavaan} \alias{analyze.blavaan} \title{Analyze blavaan (SEM or CFA) objects.} diff --git a/man/analyze.fa.Rd b/man/analyze.fa.Rd index a260885..4109828 100644 --- a/man/analyze.fa.Rd +++ b/man/analyze.fa.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.fa.R +% Please edit documentation in R/deprecated.R \name{analyze.fa} \alias{analyze.fa} \title{Analyze fa objects.} @@ -30,7 +30,7 @@ x <- psych::fa(psych::Thurstone.33, 2) results <- analyze(x) print(results) summary(results) -plot(results) + } \author{ \href{https://dominiquemakowski.github.io/}{Dominique Makowski} diff --git a/man/analyze.glm.Rd b/man/analyze.glm.Rd index 5bd18a4..e813715 100644 --- a/man/analyze.glm.Rd +++ b/man/analyze.glm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.glm.R +% Please edit documentation in R/deprecated.R \name{analyze.glm} \alias{analyze.glm} \title{Analyze glm objects.} diff --git a/man/analyze.glmerMod.Rd b/man/analyze.glmerMod.Rd index 8f4d86b..71a11ac 100644 --- a/man/analyze.glmerMod.Rd +++ b/man/analyze.glmerMod.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.glmerMod.R +% Please edit documentation in R/deprecated.R \name{analyze.glmerMod} \alias{analyze.glmerMod} \title{Analyze glmerMod objects.} diff --git a/man/analyze.htest.Rd b/man/analyze.htest.Rd index 04761cd..a585568 100644 --- a/man/analyze.htest.Rd +++ b/man/analyze.htest.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.htest.R +% Please edit documentation in R/deprecated.R \name{analyze.htest} \alias{analyze.htest} \title{Analyze htest (correlation, t-test...) objects.} diff --git a/man/analyze.lavaan.Rd b/man/analyze.lavaan.Rd index 6ea1a5a..c368f19 100644 --- a/man/analyze.lavaan.Rd +++ b/man/analyze.lavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.lavaan.R +% Please edit documentation in R/deprecated.R \name{analyze.lavaan} \alias{analyze.lavaan} \title{Analyze lavaan SEM or CFA) objects.} diff --git a/man/analyze.lm.Rd b/man/analyze.lm.Rd index 6594fa9..376a077 100644 --- a/man/analyze.lm.Rd +++ b/man/analyze.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.lm.R +% Please edit documentation in R/deprecated.R \name{analyze.lm} \alias{analyze.lm} \title{Analyze lm objects.} diff --git a/man/analyze.lmerModLmerTest.Rd b/man/analyze.lmerModLmerTest.Rd index 1609d7e..5b18e3f 100644 --- a/man/analyze.lmerModLmerTest.Rd +++ b/man/analyze.lmerModLmerTest.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.lmerModLmerTest.R +% Please edit documentation in R/deprecated.R \name{analyze.lmerModLmerTest} \alias{analyze.lmerModLmerTest} \title{Analyze lmerModLmerTest objects.} diff --git a/man/analyze.principal.Rd b/man/analyze.principal.Rd index c1b7f04..3bf21e2 100644 --- a/man/analyze.principal.Rd +++ b/man/analyze.principal.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.principal.R +% Please edit documentation in R/deprecated.R \name{analyze.principal} \alias{analyze.principal} \title{Analyze fa objects.} @@ -30,7 +30,7 @@ x <- psych::pca(psych::Thurstone.33, 2) results <- analyze(x) print(results) summary(results) -plot(results) + } \author{ \href{https://dominiquemakowski.github.io/}{Dominique Makowski} diff --git a/man/analyze.stanreg.Rd b/man/analyze.stanreg.Rd index 4acffa7..932a78b 100644 --- a/man/analyze.stanreg.Rd +++ b/man/analyze.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.stanreg.R +% Please edit documentation in R/deprecated.R \name{analyze.stanreg} \alias{analyze.stanreg} \title{Analyze stanreg objects.} @@ -30,7 +30,7 @@ Contains the following indices: \item{the Median of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models).} \item{the Median Absolute Deviation (MAD), a robust measure of dispertion (could be seen as a robust version of SD).} \item{the Credible Interval (CI) (by default, the 90\% CI; see Kruschke, 2018), representing a range of possible parameter.} - \item{the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).} + \item{the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).} \item{the Overlap (O), the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution.} \item{the ROPE, the proportion of the 95\% CI of the posterior distribution that lies within the region of practical equivalence.} } diff --git a/man/as.data.frame.density.Rd b/man/as.data.frame.density.Rd index 1adecbd..53a09e1 100644 --- a/man/as.data.frame.density.Rd +++ b/man/as.data.frame.density.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/as.data.frame.density.R +% Please edit documentation in R/deprecated.R \name{as.data.frame.density} \alias{as.data.frame.density} \title{Coerce to a Data Frame.} diff --git a/man/assess.Rd b/man/assess.Rd index 68c0ceb..6d2b180 100644 --- a/man/assess.Rd +++ b/man/assess.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/assess.R +% Please edit documentation in R/deprecated.R \name{assess} \alias{assess} \title{Compare a patient's score to a control group} diff --git a/man/bayes_cor.Rd b/man/bayes_cor.Rd index d2842f1..5e1c6e8 100644 --- a/man/bayes_cor.Rd +++ b/man/bayes_cor.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bayes_cor.R +% Please edit documentation in R/deprecated.R \name{bayes_cor} \alias{bayes_cor} \title{Bayesian Correlation Matrix.} diff --git a/man/bayes_cor.test.Rd b/man/bayes_cor.test.Rd index 5a92a7e..fdba52b 100644 --- a/man/bayes_cor.test.Rd +++ b/man/bayes_cor.test.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bayes_cor.R +% Please edit documentation in R/deprecated.R \name{bayes_cor.test} \alias{bayes_cor.test} \title{Performs a Bayesian correlation.} diff --git a/man/cite_packages.Rd b/man/cite_packages.Rd index 3a1e85a..b7320d7 100644 --- a/man/cite_packages.Rd +++ b/man/cite_packages.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cite_packages.R +% Please edit documentation in R/deprecated.R \name{cite_packages} \alias{cite_packages} \title{Citations of loaded packages.} diff --git a/man/correlation.Rd b/man/correlation.Rd index a5980f5..09d64c3 100644 --- a/man/correlation.Rd +++ b/man/correlation.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/correlation.R +% Please edit documentation in R/deprecated.R \name{correlation} \alias{correlation} \title{Multiple Correlations.} diff --git a/man/crawford.test.Rd b/man/crawford.test.Rd index 717bd8d..81f8965 100644 --- a/man/crawford.test.Rd +++ b/man/crawford.test.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/crawford.test.R +% Please edit documentation in R/deprecated.R \name{crawford.test} \alias{crawford.test} \title{Crawford-Garthwaite (2007) Bayesian test for single-case analysis.} diff --git a/man/crawford.test.freq.Rd b/man/crawford.test.freq.Rd index e20fcdb..258635f 100644 --- a/man/crawford.test.freq.Rd +++ b/man/crawford.test.freq.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/crawford.test.R +% Please edit documentation in R/deprecated.R \name{crawford.test.freq} \alias{crawford.test.freq} \title{Crawford-Howell (1998) frequentist t-test for single-case analysis.} diff --git a/man/crawford_dissociation.test.Rd b/man/crawford_dissociation.test.Rd index 78f9418..db2473d 100644 --- a/man/crawford_dissociation.test.Rd +++ b/man/crawford_dissociation.test.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/crawford_dissociation.test.R +% Please edit documentation in R/deprecated.R \name{crawford_dissociation.test} \alias{crawford_dissociation.test} -\title{Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks.} +\title{Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks.} \usage{ crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y, verbose = TRUE) diff --git a/man/create_intervals.Rd b/man/create_intervals.Rd index 122e9fc..45678fd 100644 --- a/man/create_intervals.Rd +++ b/man/create_intervals.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/create_intervals.R +% Please edit documentation in R/deprecated.R \name{create_intervals} \alias{create_intervals} \title{Overlap of Two Empirical Distributions.} diff --git a/man/dprime.Rd b/man/dprime.Rd index e567cd6..37cc694 100644 --- a/man/dprime.Rd +++ b/man/dprime.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dprime.R +% Please edit documentation in R/deprecated.R \name{dprime} \alias{dprime} \title{Dprime and Other Signal Detection Theory indices.} diff --git a/man/emotion.Rd b/man/emotion.Rd index 2656419..4af176f 100644 --- a/man/emotion.Rd +++ b/man/emotion.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/emotion.R +% Please edit documentation in R/data_emotion.R \docType{data} \name{emotion} \alias{emotion} diff --git a/man/find_best_model.Rd b/man/find_best_model.Rd index 2b70942..a33defe 100644 --- a/man/find_best_model.Rd +++ b/man/find_best_model.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_best_model.R +% Please edit documentation in R/deprecated.R \name{find_best_model} \alias{find_best_model} \title{Returns the best model.} diff --git a/man/find_best_model.lavaan.Rd b/man/find_best_model.lavaan.Rd index c3256c4..19d55cf 100644 --- a/man/find_best_model.lavaan.Rd +++ b/man/find_best_model.lavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_best_model.lavaan.R +% Please edit documentation in R/deprecated.R \name{find_best_model.lavaan} \alias{find_best_model.lavaan} \title{Returns all combinations of lavaan models with their indices of fit.} diff --git a/man/find_best_model.lmerModLmerTest.Rd b/man/find_best_model.lmerModLmerTest.Rd index a70fbef..f728424 100644 --- a/man/find_best_model.lmerModLmerTest.Rd +++ b/man/find_best_model.lmerModLmerTest.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_best_model.lmerModLmerTest.R +% Please edit documentation in R/deprecated.R \name{find_best_model.lmerModLmerTest} \alias{find_best_model.lmerModLmerTest} \title{Returns the best combination of predictors for lmerTest objects.} diff --git a/man/find_best_model.stanreg.Rd b/man/find_best_model.stanreg.Rd index 3082aae..ab23d36 100644 --- a/man/find_best_model.stanreg.Rd +++ b/man/find_best_model.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_best_model.stanreg.R +% Please edit documentation in R/deprecated.R \name{find_best_model.stanreg} \alias{find_best_model.stanreg} \title{Returns the best combination of predictors based on LOO cross-validation indices.} diff --git a/man/find_combinations.Rd b/man/find_combinations.Rd index 6f52a2f..b893482 100644 --- a/man/find_combinations.Rd +++ b/man/find_combinations.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_combinations.R +% Please edit documentation in R/deprecated.R \name{find_combinations} \alias{find_combinations} \title{Generate all combinations.} diff --git a/man/find_combinations.formula.Rd b/man/find_combinations.formula.Rd index 5968a49..2490ed0 100644 --- a/man/find_combinations.formula.Rd +++ b/man/find_combinations.formula.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_combinations.R +% Please edit documentation in R/deprecated.R \name{find_combinations.formula} \alias{find_combinations.formula} \title{Generate all combinations of predictors of a formula.} diff --git a/man/find_distance_cluster.Rd b/man/find_distance_cluster.Rd index 3991d08..8b00443 100644 --- a/man/find_distance_cluster.Rd +++ b/man/find_distance_cluster.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_distance_cluster.R +% Please edit documentation in R/deprecated.R \name{find_distance_cluster} \alias{find_distance_cluster} \title{Find the distance of a point with its kmean cluster.} diff --git a/man/find_highest_density_point.Rd b/man/find_highest_density_point.Rd index 1645db9..c495cb8 100644 --- a/man/find_highest_density_point.Rd +++ b/man/find_highest_density_point.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_highest_density_point.R +% Please edit documentation in R/deprecated.R \name{find_highest_density_point} \alias{find_highest_density_point} \title{Find the Highest Density Point.} diff --git a/man/find_matching_string.Rd b/man/find_matching_string.Rd index 1b2e4ad..979121a 100644 --- a/man/find_matching_string.Rd +++ b/man/find_matching_string.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_matching_string.R +% Please edit documentation in R/deprecated.R \name{find_matching_string} \alias{find_matching_string} \title{Fuzzy string matching.} diff --git a/man/find_random_effects.Rd b/man/find_random_effects.Rd index 2fb6fa0..1546667 100644 --- a/man/find_random_effects.Rd +++ b/man/find_random_effects.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_random_effects.R +% Please edit documentation in R/deprecated.R \name{find_random_effects} \alias{find_random_effects} \title{Find random effects in formula.} diff --git a/man/find_season.Rd b/man/find_season.Rd index 4241194..008ba22 100644 --- a/man/find_season.Rd +++ b/man/find_season.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/find_season.R +% Please edit documentation in R/deprecated.R \name{find_season} \alias{find_season} \title{Find season of dates.} diff --git a/man/format_bf.Rd b/man/format_bf.Rd index 2ea606a..02ff281 100644 --- a/man/format_bf.Rd +++ b/man/format_bf.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_bf.R +% Please edit documentation in R/deprecated.R \name{format_bf} \alias{format_bf} \title{Bayes factor formatting} diff --git a/man/format_digit.Rd b/man/format_digit.Rd index 32c80bf..8f7a80d 100644 --- a/man/format_digit.Rd +++ b/man/format_digit.Rd @@ -1,23 +1,26 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formatting.R +% Please edit documentation in R/format_digit.R \name{format_digit} \alias{format_digit} -\title{Format digits.} +\title{Formatting} \usage{ -format_digit(x, digits = 2, null_treshold = 0.001, - inf_treshold = 9e+08) +format_digit(x, digits = 2) } \arguments{ -\item{x}{A digit.} +\item{x}{number.} -\item{digits}{Number of significant digits.} - -\item{null_treshold}{Treshold below which return 0.} - -\item{inf_treshold}{Treshold above which return Inf.} +\item{digits}{number of significant digits.} } \description{ -Format digits. +Formatting +} +\examples{ + +format_digit(1.20) +format_digit(1.2) +format_digit(1.2012313) +format_digit(0.0045) + } \author{ \href{https://dominiquemakowski.github.io/}{Dominique Makowski} diff --git a/man/format_formula.Rd b/man/format_formula.Rd index b01343c..3421128 100644 --- a/man/format_formula.Rd +++ b/man/format_formula.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formatting.R +% Please edit documentation in R/deprecated.R \name{format_formula} \alias{format_formula} \title{Clean and format formula.} diff --git a/man/format_loadings.Rd b/man/format_loadings.Rd index 05faafe..1913d46 100644 --- a/man/format_loadings.Rd +++ b/man/format_loadings.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.fa.R +% Please edit documentation in R/deprecated.R \name{format_loadings} \alias{format_loadings} \title{Format the loadings of a factor analysis.} diff --git a/man/format_p.Rd b/man/format_p.Rd index 9735b2d..cc1c67d 100644 --- a/man/format_p.Rd +++ b/man/format_p.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formatting.R +% Please edit documentation in R/deprecated.R \name{format_p} \alias{format_p} \title{Format p values.} diff --git a/man/format_string.Rd b/man/format_string.Rd index 8b565b5..aa9a889 100644 --- a/man/format_string.Rd +++ b/man/format_string.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formatting.R +% Please edit documentation in R/deprecated.R \name{format_string} \alias{format_string} \title{Tidyverse-friendly sprintf.} diff --git a/man/get_R2.Rd b/man/get_R2.Rd index 6ba1c82..697de7b 100644 --- a/man/get_R2.Rd +++ b/man/get_R2.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{get_R2} \alias{get_R2} \title{Get Indices of Explanatory Power.} diff --git a/man/get_R2.glm.Rd b/man/get_R2.glm.Rd index 24f950b..f3b716e 100644 --- a/man/get_R2.glm.Rd +++ b/man/get_R2.glm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{get_R2.glm} \alias{get_R2.glm} \title{Pseudo-R-squared for Logistic Models.} diff --git a/man/get_R2.lm.Rd b/man/get_R2.lm.Rd index 05231cf..095ec16 100644 --- a/man/get_R2.lm.Rd +++ b/man/get_R2.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{get_R2.lm} \alias{get_R2.lm} \title{R2 and adjusted R2 for Linear Models.} diff --git a/man/get_R2.merMod.Rd b/man/get_R2.merMod.Rd index 7fa9e00..7ee8622 100644 --- a/man/get_R2.merMod.Rd +++ b/man/get_R2.merMod.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{get_R2.merMod} \alias{get_R2.merMod} \title{R2 and adjusted R2 for GLMMs.} diff --git a/man/get_R2.stanreg.Rd b/man/get_R2.stanreg.Rd index c4361b7..d5339a9 100644 --- a/man/get_R2.stanreg.Rd +++ b/man/get_R2.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_R2.R +% Please edit documentation in R/deprecated.R \name{get_R2.stanreg} \alias{get_R2.stanreg} \title{R2 or Bayesian Models.} diff --git a/man/get_cfa_model.Rd b/man/get_cfa_model.Rd index 83ef8de..18afad5 100644 --- a/man/get_cfa_model.Rd +++ b/man/get_cfa_model.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.fa.R +% Please edit documentation in R/deprecated.R \name{get_cfa_model} \alias{get_cfa_model} \title{Get CFA model.} diff --git a/man/get_contrasts.Rd b/man/get_contrasts.Rd index 768e072..75311bb 100644 --- a/man/get_contrasts.Rd +++ b/man/get_contrasts.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts} \alias{get_contrasts} \title{Compute estimated contrasts from models.} diff --git a/man/get_contrasts.glm.Rd b/man/get_contrasts.glm.Rd index 5c307fe..9e031eb 100644 --- a/man/get_contrasts.glm.Rd +++ b/man/get_contrasts.glm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts.glm} \alias{get_contrasts.glm} \title{Compute estimated contrasts from models.} diff --git a/man/get_contrasts.glmerMod.Rd b/man/get_contrasts.glmerMod.Rd index fd3dabe..7603f4d 100644 --- a/man/get_contrasts.glmerMod.Rd +++ b/man/get_contrasts.glmerMod.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts.glmerMod} \alias{get_contrasts.glmerMod} \title{Compute estimated contrasts from models.} diff --git a/man/get_contrasts.lm.Rd b/man/get_contrasts.lm.Rd index b702404..52852ac 100644 --- a/man/get_contrasts.lm.Rd +++ b/man/get_contrasts.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts.lm} \alias{get_contrasts.lm} \title{Compute estimated contrasts from models.} diff --git a/man/get_contrasts.lmerMod.Rd b/man/get_contrasts.lmerMod.Rd index c876161..a5884e0 100644 --- a/man/get_contrasts.lmerMod.Rd +++ b/man/get_contrasts.lmerMod.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts.lmerMod} \alias{get_contrasts.lmerMod} \title{Compute estimated contrasts from models.} diff --git a/man/get_contrasts.lmerModLmerTest.Rd b/man/get_contrasts.lmerModLmerTest.Rd index f00bdbf..e45a9e2 100644 --- a/man/get_contrasts.lmerModLmerTest.Rd +++ b/man/get_contrasts.lmerModLmerTest.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts.lmerModLmerTest} \alias{get_contrasts.lmerModLmerTest} \title{Compute estimated contrasts from models.} diff --git a/man/get_contrasts.stanreg.Rd b/man/get_contrasts.stanreg.Rd index 3b2c6f6..31da2b5 100644 --- a/man/get_contrasts.stanreg.Rd +++ b/man/get_contrasts.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_contrasts.R +% Please edit documentation in R/deprecated.R \name{get_contrasts.stanreg} \alias{get_contrasts.stanreg} \title{Compute estimated contrasts from models.} diff --git a/man/get_data.Rd b/man/get_data.Rd index 1f2d42e..7148cd9 100644 --- a/man/get_data.Rd +++ b/man/get_data.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_data.R +% Please edit documentation in R/deprecated.R \name{get_data} \alias{get_data} \title{Extract the dataframe used in a model.} diff --git a/man/get_formula.Rd b/man/get_formula.Rd index 882a1a6..8c493fb 100644 --- a/man/get_formula.Rd +++ b/man/get_formula.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_formula.R +% Please edit documentation in R/deprecated.R \name{get_formula} \alias{get_formula} \title{Get formula of models.} diff --git a/man/get_graph.Rd b/man/get_graph.Rd index d8ba2a4..a0875ca 100644 --- a/man/get_graph.Rd +++ b/man/get_graph.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_graph.R +% Please edit documentation in R/deprecated.R \name{get_graph} \alias{get_graph} \title{Get graph data.} diff --git a/man/get_graph.fa.Rd b/man/get_graph.fa.Rd index ccd7b18..b198196 100644 --- a/man/get_graph.fa.Rd +++ b/man/get_graph.fa.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_graph.R +% Please edit documentation in R/deprecated.R \name{get_graph.fa} \alias{get_graph.fa} \title{Get graph data from factor analysis.} diff --git a/man/get_graph.lavaan.Rd b/man/get_graph.lavaan.Rd index 71ace85..6e5891c 100644 --- a/man/get_graph.lavaan.Rd +++ b/man/get_graph.lavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_graph.R +% Please edit documentation in R/deprecated.R \name{get_graph.lavaan} \alias{get_graph.lavaan} \title{Get graph data from lavaan or blavaan objects.} diff --git a/man/get_graph.psychobject_correlation.Rd b/man/get_graph.psychobject_correlation.Rd index 3f83cb9..c1402d0 100644 --- a/man/get_graph.psychobject_correlation.Rd +++ b/man/get_graph.psychobject_correlation.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_graph.R +% Please edit documentation in R/deprecated.R \name{get_graph.psychobject_correlation} \alias{get_graph.psychobject_correlation} \title{Get graph data from correlation.} diff --git a/man/get_info.Rd b/man/get_info.Rd index 249d731..dc6e550 100644 --- a/man/get_info.Rd +++ b/man/get_info.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_info.R +% Please edit documentation in R/deprecated.R \name{get_info} \alias{get_info} \title{Get information about objects.} diff --git a/man/get_info.lm.Rd b/man/get_info.lm.Rd index 5994fda..6af880e 100644 --- a/man/get_info.lm.Rd +++ b/man/get_info.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_info.R +% Please edit documentation in R/deprecated.R \name{get_info.lm} \alias{get_info.lm} \title{Get information about models.} diff --git a/man/get_info.lmerModLmerTest.Rd b/man/get_info.lmerModLmerTest.Rd index 9ef22d4..0f79246 100644 --- a/man/get_info.lmerModLmerTest.Rd +++ b/man/get_info.lmerModLmerTest.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_info.R +% Please edit documentation in R/deprecated.R \name{get_info.lmerModLmerTest} \alias{get_info.lmerModLmerTest} \title{Get information about models.} diff --git a/man/get_loadings_max.Rd b/man/get_loadings_max.Rd index 3073720..54224dc 100644 --- a/man/get_loadings_max.Rd +++ b/man/get_loadings_max.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.fa.R +% Please edit documentation in R/deprecated.R \name{get_loadings_max} \alias{get_loadings_max} \title{Get loadings max.} diff --git a/man/get_means.Rd b/man/get_means.Rd index 7e6b279..b547324 100644 --- a/man/get_means.Rd +++ b/man/get_means.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_means.R +% Please edit documentation in R/deprecated.R \name{get_means} \alias{get_means} \title{Compute estimated means from models.} diff --git a/man/get_predicted.Rd b/man/get_predicted.Rd index a554d03..9723c76 100644 --- a/man/get_predicted.Rd +++ b/man/get_predicted.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_predicted.R +% Please edit documentation in R/deprecated.R \name{get_predicted} \alias{get_predicted} \title{Compute predicted values from models.} diff --git a/man/get_predicted.glm.Rd b/man/get_predicted.glm.Rd index ba0386f..9b08d68 100644 --- a/man/get_predicted.glm.Rd +++ b/man/get_predicted.glm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_predicted.glm.R +% Please edit documentation in R/deprecated.R \name{get_predicted.glm} \alias{get_predicted.glm} \title{Compute predicted values of lm models.} diff --git a/man/get_predicted.lm.Rd b/man/get_predicted.lm.Rd index afc8fab..e247775 100644 --- a/man/get_predicted.lm.Rd +++ b/man/get_predicted.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_predicted.lm.R +% Please edit documentation in R/deprecated.R \name{get_predicted.lm} \alias{get_predicted.lm} \title{Compute predicted values of lm models.} diff --git a/man/get_predicted.merMod.Rd b/man/get_predicted.merMod.Rd index c828ccf..37d4329 100644 --- a/man/get_predicted.merMod.Rd +++ b/man/get_predicted.merMod.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_predicted.merMod.R +% Please edit documentation in R/deprecated.R \name{get_predicted.merMod} \alias{get_predicted.merMod} \title{Compute predicted values of lm models.} diff --git a/man/get_predicted.stanreg.Rd b/man/get_predicted.stanreg.Rd index 27ee5ce..7152274 100644 --- a/man/get_predicted.stanreg.Rd +++ b/man/get_predicted.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_predicted.stanreg.R +% Please edit documentation in R/deprecated.R \name{get_predicted.stanreg} \alias{get_predicted.stanreg} \title{Compute predicted values of stanreg models.} diff --git a/man/golden.Rd b/man/golden.Rd index c4fa349..8669672 100644 --- a/man/golden.Rd +++ b/man/golden.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/golden.R +% Please edit documentation in R/deprecated.R \name{golden} \alias{golden} \title{Golden Ratio.} diff --git a/man/hdi.Rd b/man/hdi.Rd index 9517ea1..8a92f9e 100644 --- a/man/hdi.Rd +++ b/man/hdi.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hdi.R +% Please edit documentation in R/deprecated.R \name{HDI} \alias{HDI} \title{Highest Density Intervals (HDI).} diff --git a/man/interpret_R2.Rd b/man/interpret_R2.Rd index 1ad061c..81c8294 100644 --- a/man/interpret_R2.Rd +++ b/man/interpret_R2.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_R2.R +% Please edit documentation in R/deprecated.R \name{interpret_R2} \alias{interpret_R2} \title{R2 interpreation.} diff --git a/man/interpret_R2_posterior.Rd b/man/interpret_R2_posterior.Rd index 4e80418..3015367 100644 --- a/man/interpret_R2_posterior.Rd +++ b/man/interpret_R2_posterior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_R2.R +% Please edit documentation in R/deprecated.R \name{interpret_R2_posterior} \alias{interpret_R2_posterior} \title{R2 interpreation for a posterior distribution.} diff --git a/man/interpret_RMSEA.Rd b/man/interpret_RMSEA.Rd index ff69440..c9c7b62 100644 --- a/man/interpret_RMSEA.Rd +++ b/man/interpret_RMSEA.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_RMSEA.R +% Please edit documentation in R/deprecated.R \name{interpret_RMSEA} \alias{interpret_RMSEA} \title{RMSEA interpreation.} diff --git a/man/interpret_bf.Rd b/man/interpret_bf.Rd index 126f554..9778d03 100644 --- a/man/interpret_bf.Rd +++ b/man/interpret_bf.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_bf.R +% Please edit documentation in R/deprecated.R \name{interpret_bf} \alias{interpret_bf} \title{Bayes Factor Interpretation} diff --git a/man/interpret_d.Rd b/man/interpret_d.Rd index 4c8365c..27d178d 100644 --- a/man/interpret_d.Rd +++ b/man/interpret_d.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_d.R +% Please edit documentation in R/deprecated.R \name{interpret_d} \alias{interpret_d} \title{Standardized difference (Cohen's d) interpreation.} diff --git a/man/interpret_d_posterior.Rd b/man/interpret_d_posterior.Rd index b750d49..e227e6f 100644 --- a/man/interpret_d_posterior.Rd +++ b/man/interpret_d_posterior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_d.R +% Please edit documentation in R/deprecated.R \name{interpret_d_posterior} \alias{interpret_d_posterior} \title{Standardized difference (Cohen's d) interpreation for a posterior distribution.} diff --git a/man/interpret_lavaan.Rd b/man/interpret_lavaan.Rd index a722050..9a02487 100644 --- a/man/interpret_lavaan.Rd +++ b/man/interpret_lavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_lavaan.R +% Please edit documentation in R/deprecated.R \name{interpret_lavaan} \alias{interpret_lavaan} \title{Interpret fit measures of lavaan or blavaan objects} diff --git a/man/interpret_lavaan.blavaan.Rd b/man/interpret_lavaan.blavaan.Rd index 3d72c76..31ecacb 100644 --- a/man/interpret_lavaan.blavaan.Rd +++ b/man/interpret_lavaan.blavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_lavaan.R +% Please edit documentation in R/deprecated.R \name{interpret_lavaan.blavaan} \alias{interpret_lavaan.blavaan} \title{Interpret fit measures of blavaan objects} diff --git a/man/interpret_lavaan.lavaan.Rd b/man/interpret_lavaan.lavaan.Rd index 2df1185..d036690 100644 --- a/man/interpret_lavaan.lavaan.Rd +++ b/man/interpret_lavaan.lavaan.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_lavaan.R +% Please edit documentation in R/deprecated.R \name{interpret_lavaan.lavaan} \alias{interpret_lavaan.lavaan} \title{Interpret fit measures of lavaan objects} diff --git a/man/interpret_odds.Rd b/man/interpret_odds.Rd index 09de8b7..c057123 100644 --- a/man/interpret_odds.Rd +++ b/man/interpret_odds.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_odds.R +% Please edit documentation in R/deprecated.R \name{interpret_odds} \alias{interpret_odds} \title{Odds ratio interpreation for a posterior distribution.} @@ -24,7 +24,7 @@ interpret_odds(x = 2) } \references{ \itemize{ - \item{Chen, H., Cohen, P., & Chen, S. (2010). How big is a big odds ratio? Interpreting the magnitudes of odds ratios in epidemiological studies. Communications in Statistics—Simulation and Computation®, 39(4), 860-864.} + \item{Chen, H., Cohen, P., & Chen, S. (2010). How big is a big odds ratio? Interpreting the magnitudes of odds ratios in epidemiological studies. Communications in Statistics—Simulation and Computation, 39(4), 860-864.} } } \seealso{ diff --git a/man/interpret_odds_posterior.Rd b/man/interpret_odds_posterior.Rd index 3b3a405..c4f4693 100644 --- a/man/interpret_odds_posterior.Rd +++ b/man/interpret_odds_posterior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_odds.R +% Please edit documentation in R/deprecated.R \name{interpret_odds_posterior} \alias{interpret_odds_posterior} \title{Odds ratio interpreation for a posterior distribution.} diff --git a/man/interpret_omega_sq.Rd b/man/interpret_omega_sq.Rd index 579ccf6..7f4bfc8 100644 --- a/man/interpret_omega_sq.Rd +++ b/man/interpret_omega_sq.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_omega_sq.R +% Please edit documentation in R/deprecated.R \name{interpret_omega_sq} \alias{interpret_omega_sq} \title{Omega Squared Interpretation} diff --git a/man/interpret_r.Rd b/man/interpret_r.Rd index c8d1b05..8fea9ab 100644 --- a/man/interpret_r.Rd +++ b/man/interpret_r.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_r.R +% Please edit documentation in R/deprecated.R \name{interpret_r} \alias{interpret_r} \title{Correlation coefficient r interpreation.} diff --git a/man/interpret_r_posterior.Rd b/man/interpret_r_posterior.Rd index a66b884..8d4615d 100644 --- a/man/interpret_r_posterior.Rd +++ b/man/interpret_r_posterior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_r.R +% Please edit documentation in R/deprecated.R \name{interpret_r_posterior} \alias{interpret_r_posterior} \title{Correlation coefficient r interpreation for a posterior distribution.} diff --git a/man/is.mixed.Rd b/man/is.mixed.Rd index fdb091c..d2fd963 100644 --- a/man/is.mixed.Rd +++ b/man/is.mixed.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/is.mixed.R +% Please edit documentation in R/deprecated.R \name{is.mixed} \alias{is.mixed} \title{Check if model includes random effects.} diff --git a/man/is.mixed.stanreg.Rd b/man/is.mixed.stanreg.Rd index 893d05b..794345a 100644 --- a/man/is.mixed.stanreg.Rd +++ b/man/is.mixed.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/is.mixed.R +% Please edit documentation in R/deprecated.R \name{is.mixed.stanreg} \alias{is.mixed.stanreg} \title{Check if model includes random effects.} diff --git a/man/is.psychobject.Rd b/man/is.psychobject.Rd index c965002..f2f089f 100644 --- a/man/is.psychobject.Rd +++ b/man/is.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/psychobject.R +% Please edit documentation in R/deprecated.R \name{is.psychobject} \alias{is.psychobject} \title{Creates or tests for objects of mode "psychobject".} diff --git a/man/is.standardized.Rd b/man/is.standardized.Rd index 48adfcc..85823f1 100644 --- a/man/is.standardized.Rd +++ b/man/is.standardized.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/is.standardized.R +% Please edit documentation in R/deprecated.R \name{is.standardized} \alias{is.standardized} \title{Check if a dataframe is standardized.} diff --git a/man/mellenbergh.test.Rd b/man/mellenbergh.test.Rd index 20c83c7..bdd0372 100644 --- a/man/mellenbergh.test.Rd +++ b/man/mellenbergh.test.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mellenbergh.test.R +% Please edit documentation in R/deprecated.R \name{mellenbergh.test} \alias{mellenbergh.test} \title{Mellenbergh & van den Brink (1998) test for pre-post comparison.} diff --git a/man/model_to_priors.Rd b/man/model_to_priors.Rd index 1c79a2e..eaba6af 100644 --- a/man/model_to_priors.Rd +++ b/man/model_to_priors.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model_to_priors.R +% Please edit documentation in R/deprecated.R \name{model_to_priors} \alias{model_to_priors} \title{Model to Prior.} diff --git a/man/mpe.Rd b/man/mpe.Rd index 46855ed..e531c17 100644 --- a/man/mpe.Rd +++ b/man/mpe.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mpe.R +% Please edit documentation in R/deprecated.R \name{mpe} \alias{mpe} \title{Compute Maximum Probability of Effect (MPE).} @@ -13,7 +13,7 @@ mpe(posterior) list containing the MPE and its values. } \description{ -Compute the Maximum Probability of Effect (MPE), i.e., the proportion of posterior distribution that is of the same sign as the median. In other words, it corresponds to the maximum probability that the effect is different from 0 in the median’s direction. +Compute the Maximum Probability of Effect (MPE), i.e., the proportion of posterior distribution that is of the same sign as the median. In other words, it corresponds to the maximum probability that the effect is different from 0 in the median’s direction. } \examples{ library(psycho) diff --git a/man/n_factors.Rd b/man/n_factors.Rd index 8edefdd..87128d9 100644 --- a/man/n_factors.Rd +++ b/man/n_factors.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/n_factors.R +% Please edit documentation in R/deprecated.R \name{n_factors} \alias{n_factors} \title{Find Optimal Factor Number.} diff --git a/man/odds_to_d.Rd b/man/odds_to_d.Rd index f203f54..04006d9 100644 --- a/man/odds_to_d.Rd +++ b/man/odds_to_d.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_odds.R +% Please edit documentation in R/deprecated.R \name{odds_to_d} \alias{odds_to_d} \title{(Log) odds ratio to Cohen's d} diff --git a/man/odds_to_probs.Rd b/man/odds_to_probs.Rd index 6100cab..d6f2c3e 100644 --- a/man/odds_to_probs.Rd +++ b/man/odds_to_probs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/odds_to_probs.R +% Please edit documentation in R/deprecated.R \name{odds_to_probs} \alias{odds_to_probs} \title{Convert (log)odds to probabilies.} diff --git a/man/omega_sq.Rd b/man/omega_sq.Rd index a7fac9f..03d7571 100644 --- a/man/omega_sq.Rd +++ b/man/omega_sq.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.anova.R +% Please edit documentation in R/deprecated.R \name{omega_sq} \alias{omega_sq} \title{Partial Omega Squared.} diff --git a/man/overlap.Rd b/man/overlap.Rd index 2be189f..bb7ed69 100644 --- a/man/overlap.Rd +++ b/man/overlap.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/overlap.R +% Please edit documentation in R/deprecated.R \name{overlap} \alias{overlap} \title{Overlap of Two Empirical Distributions.} diff --git a/man/percentile.Rd b/man/percentile.Rd index 6dafbdc..135e1c8 100644 --- a/man/percentile.Rd +++ b/man/percentile.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/percentile.R +% Please edit documentation in R/deprecated.R \name{percentile} \alias{percentile} \title{Transform z score to percentile.} diff --git a/man/percentile_to_z.Rd b/man/percentile_to_z.Rd index 39e779a..6e2a87b 100644 --- a/man/percentile_to_z.Rd +++ b/man/percentile_to_z.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/percentile.R +% Please edit documentation in R/deprecated.R \name{percentile_to_z} \alias{percentile_to_z} \title{Transform a percentile to a z score.} diff --git a/man/plot.psychobject.Rd b/man/plot.psychobject.Rd index 3ee22f0..2bb72a8 100644 --- a/man/plot.psychobject.Rd +++ b/man/plot.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.psychobject.R +% Please edit documentation in R/deprecated.R \name{plot.psychobject} \alias{plot.psychobject} \title{Plot the results.} diff --git a/man/plot_loadings.Rd b/man/plot_loadings.Rd index fec9e72..5a07c00 100644 --- a/man/plot_loadings.Rd +++ b/man/plot_loadings.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/analyze.fa.R +% Please edit documentation in R/deprecated.R \name{plot_loadings} \alias{plot_loadings} \title{Plot loadings.} diff --git a/man/power_analysis.Rd b/man/power_analysis.Rd index 6b7b748..80594dd 100644 --- a/man/power_analysis.Rd +++ b/man/power_analysis.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/power_analysis.R +% Please edit documentation in R/deprecated.R \name{power_analysis} \alias{power_analysis} \title{Power analysis for fitted models.} diff --git a/man/print.psychobject.Rd b/man/print.psychobject.Rd index 0008fca..8de8772 100644 --- a/man/print.psychobject.Rd +++ b/man/print.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/print.psychobject.R +% Please edit documentation in R/deprecated.R \name{print.psychobject} \alias{print.psychobject} \title{Print the results.} diff --git a/man/probs_to_odds.Rd b/man/probs_to_odds.Rd index 47e6506..5e03bb8 100644 --- a/man/probs_to_odds.Rd +++ b/man/probs_to_odds.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/probs_to_odds.R +% Please edit documentation in R/deprecated.R \name{probs_to_odds} \alias{probs_to_odds} \title{Convert probabilities to (log)odds.} diff --git a/man/refdata.Rd b/man/refdata.Rd index e7e9ee9..f613c3b 100644 --- a/man/refdata.Rd +++ b/man/refdata.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/refdata.R +% Please edit documentation in R/deprecated.R \name{refdata} \alias{refdata} \title{Create a reference grid.} diff --git a/man/remove_empty_cols.Rd b/man/remove_empty_cols.Rd index 870ecd3..2652e00 100644 --- a/man/remove_empty_cols.Rd +++ b/man/remove_empty_cols.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remove_empty_cols.R +% Please edit documentation in R/deprecated.R \name{remove_empty_cols} \alias{remove_empty_cols} \title{Remove empty columns.} diff --git a/man/remove_outliers.Rd b/man/remove_outliers.Rd index a10fd3c..e5091e3 100644 --- a/man/remove_outliers.Rd +++ b/man/remove_outliers.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remove_outliers.R +% Please edit documentation in R/deprecated.R \name{remove_outliers} \alias{remove_outliers} \title{Remove outliers.} diff --git a/man/reorder_matrix.Rd b/man/reorder_matrix.Rd index b628078..f61e482 100644 --- a/man/reorder_matrix.Rd +++ b/man/reorder_matrix.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bayes_cor.R +% Please edit documentation in R/deprecated.R \name{reorder_matrix} \alias{reorder_matrix} \title{Reorder square matrix.} diff --git a/man/rnorm_perfect.Rd b/man/rnorm_perfect.Rd index 3b646c7..ed92733 100644 --- a/man/rnorm_perfect.Rd +++ b/man/rnorm_perfect.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rnorm_perfect.R +% Please edit documentation in R/deprecated.R \name{rnorm_perfect} \alias{rnorm_perfect} \title{Perfect Normal Distribution.} diff --git a/man/rope.Rd b/man/rope.Rd index 983095c..4f57bb4 100644 --- a/man/rope.Rd +++ b/man/rope.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rope.R +% Please edit documentation in R/deprecated.R \name{rope} \alias{rope} \title{Region of Practical Equivalence (ROPE)} diff --git a/man/simulate_data_regression.Rd b/man/simulate_data_regression.Rd index 46567f0..d0ce07d 100644 --- a/man/simulate_data_regression.Rd +++ b/man/simulate_data_regression.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/simulate.R +% Please edit documentation in R/deprecated.R \name{simulate_data_regression} \alias{simulate_data_regression} \title{Simulates data for single or multiple regression.} diff --git a/man/standardize.Rd b/man/standardize.Rd index 36c0f15..20e31f2 100644 --- a/man/standardize.Rd +++ b/man/standardize.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardize.R +% Please edit documentation in R/deprecated.R \name{standardize} \alias{standardize} \title{Standardize.} diff --git a/man/standardize.data.frame.Rd b/man/standardize.data.frame.Rd index 7a6cf55..951b263 100644 --- a/man/standardize.data.frame.Rd +++ b/man/standardize.data.frame.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardize.R +% Please edit documentation in R/deprecated.R \name{standardize.data.frame} \alias{standardize.data.frame} \title{Standardize (scale and reduce) Dataframe.} diff --git a/man/standardize.glm.Rd b/man/standardize.glm.Rd index ccc70ac..b7b1399 100644 --- a/man/standardize.glm.Rd +++ b/man/standardize.glm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardize.R +% Please edit documentation in R/deprecated.R \name{standardize.glm} \alias{standardize.glm} \title{Standardize Coefficients.} diff --git a/man/standardize.lm.Rd b/man/standardize.lm.Rd index c9efc7c..153fd0f 100644 --- a/man/standardize.lm.Rd +++ b/man/standardize.lm.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardize.R +% Please edit documentation in R/deprecated.R \name{standardize.lm} \alias{standardize.lm} \title{Standardize Coefficients.} diff --git a/man/standardize.numeric.Rd b/man/standardize.numeric.Rd index 82505cb..32b933d 100644 --- a/man/standardize.numeric.Rd +++ b/man/standardize.numeric.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardize.R +% Please edit documentation in R/deprecated.R \name{standardize.numeric} \alias{standardize.numeric} \title{Standardize (scale and reduce) numeric variables.} diff --git a/man/standardize.stanreg.Rd b/man/standardize.stanreg.Rd index dd12d1d..ac9837d 100644 --- a/man/standardize.stanreg.Rd +++ b/man/standardize.stanreg.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardize.R +% Please edit documentation in R/deprecated.R \name{standardize.stanreg} \alias{standardize.stanreg} \title{Standardize Posteriors.} diff --git a/man/summary.psychobject.Rd b/man/summary.psychobject.Rd index 69a9994..e479648 100644 --- a/man/summary.psychobject.Rd +++ b/man/summary.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.psychobject.R +% Please edit documentation in R/deprecated.R \name{summary.psychobject} \alias{summary.psychobject} \title{Print the results.} diff --git a/man/values.Rd b/man/values.Rd index 1026f56..c42a926 100644 --- a/man/values.Rd +++ b/man/values.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/values.R +% Please edit documentation in R/deprecated.R \name{values} \alias{values} \title{Extract values as list.} diff --git a/tests/testthat/test-analyze.aov.R b/tests/testthat/test-analyze.aov.R deleted file mode 100644 index c23181c..0000000 --- a/tests/testthat/test-analyze.aov.R +++ /dev/null @@ -1,23 +0,0 @@ -context("analyze.aov") - -test_that("If it works.", { - library(psycho) - library(lmerTest) - library(lme4) - - df <- psycho::affective - x <- aov(Tolerating ~ Salary, data = df) - testthat::expect_equal(nrow(summary(psycho::analyze(x))), 2) - - x <- anova(lm(Tolerating ~ Salary, data = df)) - testthat::expect_equal(nrow(summary(psycho::analyze(x))), 2) - - x <- aov(Tolerating ~ Birth_Season + Error(Sex), data = df) - testthat::expect_message(psycho::analyze(x)) - - x <- anova(lmerTest::lmer(Tolerating ~ Birth_Season + (1 | Sex), data = df)) - testthat::expect_equal(nrow(summary(psycho::analyze(x))), 1) - - x <- anova(lme4::lmer(Tolerating ~ Birth_Season + (1 | Sex), data = df)) - testthat::expect_error(psycho::analyze(x)) -}) diff --git a/tests/testthat/test-analyze.fa.R b/tests/testthat/test-analyze.fa.R deleted file mode 100644 index 700eb3c..0000000 --- a/tests/testthat/test-analyze.fa.R +++ /dev/null @@ -1,14 +0,0 @@ -context("analyze.fa") - -test_that("If it works.", { - library(psycho) - library(psych) - - x <- psych::fa(psych::Thurstone.33, 2) - - results <- analyze(x) - testthat::expect_equal(nrow(summary(results)), 9) - - cfa_model <- get_cfa_model(results$values$loadings, treshold = 0.3) - testthat::expect_equal(length(cfa_model), 1) -}) diff --git a/tests/testthat/test-analyze.glm.R b/tests/testthat/test-analyze.glm.R deleted file mode 100644 index ce6a3fb..0000000 --- a/tests/testthat/test-analyze.glm.R +++ /dev/null @@ -1,16 +0,0 @@ -context("analyze.glm") - -test_that("If it works.", { - library(psycho) - - # GLM - fit <- glm(vs ~ mpg, data = mtcars, family = "binomial") - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$mpg$Coef, 2), 0.43, tolerance = 0.02) - - # test summary - summa <- summary(model, round = 2) - testthat::expect_equal(nrow(summa), 2) -}) diff --git a/tests/testthat/test-analyze.glmerMod.R b/tests/testthat/test-analyze.glmerMod.R deleted file mode 100644 index e79b6bd..0000000 --- a/tests/testthat/test-analyze.glmerMod.R +++ /dev/null @@ -1,20 +0,0 @@ -context("analyze.glmerMod") - -test_that("If it works.", { - library(lme4) - - # GLM - fit <- lme4::glmer(vs ~ mpg + (1 | cyl), data = mtcars, family = "binomial") - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$mpg$Coef, 2), 0.17, tolerance = 0.02) - - # test summary - summa <- summary(model, round = 2) - testthat::expect_equal(nrow(summa), 2) - - # GLM - fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = psycho::affective, family = "binomial") - testthat::expect_warning(analyze(fit)) -}) diff --git a/tests/testthat/test-analyze.htest.R b/tests/testthat/test-analyze.htest.R deleted file mode 100644 index c461555..0000000 --- a/tests/testthat/test-analyze.htest.R +++ /dev/null @@ -1,23 +0,0 @@ -context("analyze.htest") - -test_that("If it works.", { - library(psycho) - - df <- psycho::affective - - x <- t.test(df$Adjusting, df$Concealing) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) - - x <- cor.test(df$Adjusting, df$Concealing) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) - - x <- t.test(df$Adjusting ~ df$Sex) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) - - x <- t.test(df$Adjusting, mu = 0) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) -}) diff --git a/tests/testthat/test-analyze.lavaan.R b/tests/testthat/test-analyze.lavaan.R deleted file mode 100644 index 67636a0..0000000 --- a/tests/testthat/test-analyze.lavaan.R +++ /dev/null @@ -1,12 +0,0 @@ -context("analyze.lavaan") - -test_that("If it works.", { - library(psycho) - library(lavaan) - - HS.model <- " visual =~ x1 + x2 + x3\n textual =~ x4 + x5 + x6\n speed =~ x7 + x8 + x9 " - - fit <- lavaan::cfa(HS.model, data = lavaan::HolzingerSwineford1939) - rez <- analyze(fit) - testthat::expect_equal(nrow(summary(rez)), 24) -}) diff --git a/tests/testthat/test-analyze.lm.R b/tests/testthat/test-analyze.lm.R deleted file mode 100644 index eb1df1b..0000000 --- a/tests/testthat/test-analyze.lm.R +++ /dev/null @@ -1,24 +0,0 @@ -context("analyze.lm") - -test_that("If it works.", { - library(psycho) - - # GLM - fit <- lm(Sepal.Width ~ Sepal.Length, data = iris) - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$Sepal.Length$Coef, 2), -0.06, tolerance = 0.01) - - # test summary - summa <- summary(model, round = 2) - testthat::expect_equal(nrow(summa), 2) - - - # Poly - fit <- lm(Sepal.Width ~ poly(Sepal.Length, 2), data = iris) - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$`poly(Sepal.Length, 2)2`$Coef, 2), 0.82, tolerance = 0.01) -}) diff --git a/tests/testthat/test-analyze.lmerModLmerTest.R b/tests/testthat/test-analyze.lmerModLmerTest.R deleted file mode 100644 index ff16a19..0000000 --- a/tests/testthat/test-analyze.lmerModLmerTest.R +++ /dev/null @@ -1,15 +0,0 @@ -context("analyze.lmerModLmerTest") - -test_that("If it works.", { - # Fit - library(lmerTest) - - fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal( - round(values$effects$Sepal.Width$Coef, 2), 0.8, - tolerance = 0.05 - ) -}) diff --git a/tests/testthat/test-analyze.stanreg.R b/tests/testthat/test-analyze.stanreg.R deleted file mode 100644 index f9910b8..0000000 --- a/tests/testthat/test-analyze.stanreg.R +++ /dev/null @@ -1,112 +0,0 @@ -context("analyze.stanreg") - -test_that("If it works.", { - # Fit - library(rstanarm) - library(psycho) - - set.seed(666) - - quiet <- function(x) { - sink(tempfile()) - on.exit(sink()) - invisible(force(x)) - } - - - - fit <- quiet(rstanarm::stan_glm( - vs ~ mpg * as.factor(cyl), - data = mtcars, - family = binomial(link = "logit"), - prior = NULL, - chains = 1, iter = 1000, seed = 666 - )) - - model <- psycho::analyze(fit) - values <- psycho::values(model) - testthat::expect_equal(round(values$effects$mpg$median, 2), 0.08, tolerance = 0.10) - - model <- psycho::analyze(fit, effsize = TRUE) - values <- psycho::values(model) - testthat::expect_equal(round(values$effects$mpg$median, 2), 0.08, tolerance = 0.10) - # This needs to be fixed: - # testthat::expect_equal(round(values$effects$mpg$std_median, 2), 0.39, tolerance = 0.10) - - - # Random - fit <- quiet(rstanarm::stan_glmer( - Sepal.Length ~ Sepal.Width + (1 | Species), - data = iris, - chains = 1, iter = 1000, seed = 666 - )) - - model <- psycho::analyze(fit, effsize = FALSE) - values <- psycho::values(model) - testthat::expect_equal( - round(values$effects$Sepal.Width$median, 2), 0.79, - tolerance = 0.05 - ) - - - - # standardized - data <- psycho::standardize(iris) - fit <- quiet(rstanarm::stan_glm(Sepal.Length ~ Sepal.Width + Petal.Width, - data = data, - prior = rstanarm::normal(0, 1, autoscale = FALSE), - chains = 1, iter = 1000, seed = 666 - )) - results <- psycho::analyze(fit) - testthat::expect_equal( - round(results$values$effects$Sepal.Width$median, 2), 0.21, - tolerance = 0.025 - ) - results <- psycho::analyze(fit, effsize = TRUE) - testthat::expect_equal( - round(results$values$effects$Sepal.Width$median, 2), 0.21, - tolerance = 0.025 - ) - - - - # Other algorithms - fit <- quiet(rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width, - data = iris, - seed = 666, - algorithm = "meanfield" - )) - - results <- psycho::analyze(fit) - values <- psycho::values(results) - testthat::expect_equal( - round(values$effects$Sepal.Width$median, 2), -0.46, - tolerance = 0.1 - ) - - # This also needs to be fixed - - # fit <- rstanarm::stan_glm( - # Sepal.Length ~ Sepal.Width, - # data = iris, - # seed = 666, - # algorithm = "fullrank" - # ) - # - # results <- psycho::analyze(fit) - # values <- psycho::values(results) - - # testthat::expect_equal( - # round(values$effects$Sepal.Width$median, 2), -0.12, - # tolerance = 0.1 - # ) - - fit <- quiet(rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width, - data = iris, - seed = 666, - algorithm = "optimizing" - )) - testthat::expect_error(psycho::analyze(fit)) -}) diff --git a/tests/testthat/test-assess.R b/tests/testthat/test-assess.R deleted file mode 100644 index 5baff4c..0000000 --- a/tests/testthat/test-assess.R +++ /dev/null @@ -1,28 +0,0 @@ -context("assess") - -test_that("It works", { - x <- assess( - patient = 10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$p, 0.018, tol = 0.02) - - x <- assess( - patient = 10, - mean = 8, - sd = 2, - n = 10 - ) - - testthat::expect_equal(x$values$p, 0.18, tol = 0.02) - - x <- assess( - patient = c(10, 12), - mean = 8, - sd = 2, - verbose = FALSE - ) - - testthat::expect_equal(x[[1]]$values$p, 0.16, tol = 0.05) -}) diff --git a/tests/testthat/test-bayes_cor.R b/tests/testthat/test-bayes_cor.R deleted file mode 100644 index 1377fde..0000000 --- a/tests/testthat/test-bayes_cor.R +++ /dev/null @@ -1,21 +0,0 @@ -context("bayes_cor") - -test_that("Correct Value", { - results <- psycho::bayes_cor.test( - psycho::affective$Concealing, - psycho::affective$Tolerating - ) - - testthat::expect_equal(results$values$median, 0.073, tol = 0.05) - testthat::expect_equal(results$values$effect_size$values$`very small`, 0.82, tol = 0.05) - - results <- psycho::bayes_cor(iris) - testthat::expect_equal(nrow(results$values$r), 4) - - - results <- psycho::bayes_cor( - dplyr::select(iris, dplyr::starts_with("Sepal")), - dplyr::select(iris, dplyr::starts_with("Petal")) - ) - testthat::expect_equal(nrow(results$values$r), 2) -}) diff --git a/tests/testthat/test-correlation.R b/tests/testthat/test-correlation.R deleted file mode 100644 index 62fc9e8..0000000 --- a/tests/testthat/test-correlation.R +++ /dev/null @@ -1,61 +0,0 @@ -context("correlation") - -test_that("Correlations work", { - df <- attitude[c("rating", "complaints", "privileges", "learning")] - - - # Pearson - output <- psycho::correlation(df) - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.82, tol = 0.1) - - # Spearman - output <- psycho::correlation(df, method = "spearman") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.83, tol = 0.1) - - # Partial - output <- psycho::correlation(df, type = "partial", adjust = "holm") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.72, tol = 0.1) - - # Semi - output <- psycho::correlation(df, type = "semi", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.53, tol = 0.1) - - # glasso - # testthat::expect_warning(psycho::correlation(df, type = "glasso", adjust = "none")) - - # cor_auto - output <- psycho::correlation(df, type = "cor_auto", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.82, tol = 0.1) - - # Dual - df2 <- attitude[c("raises", "critical")] - output <- psycho::correlation(df, df2, type = "full", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.67, tol = 0.1) - - - - type <- "semi" - adjust <- "none" - method <- "pearson" - output <- psycho::correlation(df, df2, type = "semi", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.46, tol = 0.1) - - plot <- plot(output) - testthat::expect_equal(length(plot), 10, tol = 0.1) - - # Other - testthat::expect_warning(psycho::correlation(df, type = "dupa", adjust = "holm")) - - # Plot - plot <- plot(correlation(df)) - testthat::expect_equal(length(plot), 10, tol = 0.1) - - testthat::expect_warning(correlation(data.frame(replicate(11, rnorm(100))), adjust = "none")) -}) diff --git a/tests/testthat/test-crawford.test.R b/tests/testthat/test-crawford.test.R deleted file mode 100644 index d1deeb0..0000000 --- a/tests/testthat/test-crawford.test.R +++ /dev/null @@ -1,54 +0,0 @@ -context("crawford.test") - -test_that("Correct Value", { - - # bayesian ---------------------------------------------------------------- - - - x <- crawford.test( - patient = 10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$p, 0.019, tol = 0.02) - - x <- crawford.test( - patient = -10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$p, 0.019, tol = 0.02) - - - - # frequentist ------------------------------------------------------------- - - - x <- crawford.test.freq( - patient = 10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, 3.05, tol = 0.2) - - x <- crawford.test.freq( - patient = -10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, -3.3, tol = 0.2) - - x <- crawford.test.freq( - patient = 7, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, 2.10, tol = 0.2) - - x <- crawford.test.freq( - patient = 0, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, -0.12, tol = 0.2) -}) diff --git a/tests/testthat/test-crawford_dissociation.test.R b/tests/testthat/test-crawford_dissociation.test.R deleted file mode 100644 index 6083a19..0000000 --- a/tests/testthat/test-crawford_dissociation.test.R +++ /dev/null @@ -1,12 +0,0 @@ -context("crawford.test") - -test_that("Correct Value", { - x <- crawford_dissociation.test( - case_X = 142, - case_Y = 7, - controls_X = c(100, 125, 89, 105, 109, 99), - controls_Y = c(7, 8, 9, 6, 7, 10) - ) - - testthat::expect_equal(x$t, 2.1, tol = 0.02) -}) diff --git a/tests/testthat/test-create_intervals.R b/tests/testthat/test-create_intervals.R deleted file mode 100644 index 2bdac35..0000000 --- a/tests/testthat/test-create_intervals.R +++ /dev/null @@ -1,10 +0,0 @@ -context("create_intervals") - -test_that("Correct Value", { - x <- psycho::rnorm_perfect(1000) - testthat::expect_equal(length(levels(psycho::create_intervals(x, 3))), 3) - testthat::expect_equal(length(levels(psycho::create_intervals(x, length = 100))), 2) - testthat::expect_equal(length(levels(psycho::create_intervals(x, 3, equal_range = FALSE))), 3) - testthat::expect_true(is.numeric(psycho::create_intervals(x, 3, labels = "median"))) - testthat::expect_true(is.numeric(psycho::create_intervals(x, 3, labels = FALSE))) -}) diff --git a/tests/testthat/test-deprecated.R b/tests/testthat/test-deprecated.R new file mode 100644 index 0000000..7aa5568 --- /dev/null +++ b/tests/testthat/test-deprecated.R @@ -0,0 +1,1233 @@ +context("deprecated") + +test_that("If it works.", { + library(psycho) + library(lmerTest) + library(lme4) + + df <- psycho::affective + x <- aov(Tolerating ~ Salary, data = df) + testthat::expect_equal(nrow(summary(psycho::analyze(x))), 2) + + x <- anova(lm(Tolerating ~ Salary, data = df)) + testthat::expect_equal(nrow(summary(psycho::analyze(x))), 2) + + x <- aov(Tolerating ~ Birth_Season + Error(Sex), data = df) + testthat::expect_message(psycho::analyze(x)) + + x <- anova(lmerTest::lmer(Tolerating ~ Birth_Season + (1 | Sex), data = df)) + testthat::expect_equal(nrow(summary(psycho::analyze(x))), 1) + + x <- anova(lme4::lmer(Tolerating ~ Birth_Season + (1 | Sex), data = df)) + testthat::expect_error(psycho::analyze(x)) +}) + + +test_that("analyze.glmer", { + library(lme4) + + # GLM + fit <- lme4::glmer(vs ~ mpg + (1 | cyl), data = mtcars, family = "binomial") + + model <- analyze(fit) + values <- values(model) + testthat::expect_equal(round(values$effects$mpg$Coef, 2), 0.17, tolerance = 0.02) + + # test summary + summa <- summary(model, round = 2) + testthat::expect_equal(nrow(summa), 2) + + # GLM + fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = psycho::affective, family = "binomial") + testthat::expect_warning(analyze(fit)) +}) + + +test_that("analyze.glm", { + library(psycho) + + # GLM + fit <- glm(vs ~ mpg, data = mtcars, family = "binomial") + + model <- analyze(fit) + values <- values(model) + testthat::expect_equal(round(values$effects$mpg$Coef, 2), 0.43, tolerance = 0.02) + + # test summary + summa <- summary(model, round = 2) + testthat::expect_equal(nrow(summa), 2) +}) + + + + +test_that("analyze.htest", { + library(psycho) + + df <- psycho::affective + + x <- t.test(df$Adjusting, df$Concealing) + rez <- psycho::analyze(x) + testthat::expect_equal(ncol(summary(rez)), 6) + + x <- cor.test(df$Adjusting, df$Concealing) + rez <- psycho::analyze(x) + testthat::expect_equal(ncol(summary(rez)), 6) + + x <- t.test(df$Adjusting ~ df$Sex) + rez <- psycho::analyze(x) + testthat::expect_equal(ncol(summary(rez)), 6) + + x <- t.test(df$Adjusting, mu = 0) + rez <- psycho::analyze(x) + testthat::expect_equal(ncol(summary(rez)), 6) +}) + + + + + + + + +test_that("analyze.lavaan", { + library(psycho) + library(lavaan) + + HS.model <- " visual =~ x1 + x2 + x3\n textual =~ x4 + x5 + x6\n speed =~ x7 + x8 + x9 " + + fit <- lavaan::cfa(HS.model, data = lavaan::HolzingerSwineford1939) + rez <- analyze(fit) + testthat::expect_equal(nrow(summary(rez)), 24) +}) + + + + +test_that("analyze.lm", { + library(psycho) + + # GLM + fit <- lm(Sepal.Width ~ Sepal.Length, data = iris) + + model <- analyze(fit) + values <- values(model) + testthat::expect_equal(round(values$effects$Sepal.Length$Coef, 2), -0.06, tolerance = 0.01) + + # test summary + summa <- summary(model, round = 2) + testthat::expect_equal(nrow(summa), 2) + + + # Poly + fit <- lm(Sepal.Width ~ poly(Sepal.Length, 2), data = iris) + + model <- analyze(fit) + values <- values(model) + testthat::expect_equal(round(values$effects$`poly(Sepal.Length, 2)2`$Coef, 2), 0.82, tolerance = 0.01) +}) + + + + + +test_that("analyze.lmerModLmerTest", { + # Fit + library(lmerTest) + + fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) + + model <- analyze(fit) + values <- values(model) + testthat::expect_equal( + round(values$effects$Sepal.Width$Coef, 2), 0.8, + tolerance = 0.05 + ) +}) + + + + +test_that("analyze.stanreg", { + # Fit + library(rstanarm) + library(psycho) + + set.seed(666) + + quiet <- function(x) { + sink(tempfile()) + on.exit(sink()) + invisible(force(x)) + } + + + + fit <- quiet(rstanarm::stan_glm( + vs ~ mpg * as.factor(cyl), + data = mtcars, + family = binomial(link = "logit"), + prior = NULL, + chains = 1, iter = 1000, seed = 666 + )) + + model <- psycho::analyze(fit) + values <- psycho::values(model) + testthat::expect_equal(round(values$effects$mpg$median, 2), 0.08, tolerance = 0.10) + + model <- psycho::analyze(fit, effsize = TRUE) + values <- psycho::values(model) + testthat::expect_equal(round(values$effects$mpg$median, 2), 0.08, tolerance = 0.10) + # This needs to be fixed: + # testthat::expect_equal(round(values$effects$mpg$std_median, 2), 0.39, tolerance = 0.10) + + + # Random + fit <- quiet(rstanarm::stan_glmer( + Sepal.Length ~ Sepal.Width + (1 | Species), + data = iris, + chains = 1, iter = 1000, seed = 666 + )) + + model <- psycho::analyze(fit, effsize = FALSE) + values <- psycho::values(model) + testthat::expect_equal( + round(values$effects$Sepal.Width$median, 2), 0.79, + tolerance = 0.05 + ) + + + + # standardized + data <- psycho::standardize(iris) + fit <- quiet(rstanarm::stan_glm(Sepal.Length ~ Sepal.Width + Petal.Width, + data = data, + prior = rstanarm::normal(0, 1, autoscale = FALSE), + chains = 1, iter = 1000, seed = 666 + )) + results <- psycho::analyze(fit) + testthat::expect_equal( + round(results$values$effects$Sepal.Width$median, 2), 0.21, + tolerance = 0.025 + ) + results <- psycho::analyze(fit, effsize = TRUE) + testthat::expect_equal( + round(results$values$effects$Sepal.Width$median, 2), 0.21, + tolerance = 0.025 + ) + + + + # Other algorithms + fit <- quiet(rstanarm::stan_glm( + Sepal.Length ~ Sepal.Width, + data = iris, + seed = 666, + algorithm = "meanfield" + )) + + results <- psycho::analyze(fit) + values <- psycho::values(results) + testthat::expect_equal( + round(values$effects$Sepal.Width$median, 2), -0.46, + tolerance = 0.1 + ) + + # This also needs to be fixed + + # fit <- rstanarm::stan_glm( + # Sepal.Length ~ Sepal.Width, + # data = iris, + # seed = 666, + # algorithm = "fullrank" + # ) + # + # results <- psycho::analyze(fit) + # values <- psycho::values(results) + + # testthat::expect_equal( + # round(values$effects$Sepal.Width$median, 2), -0.12, + # tolerance = 0.1 + # ) + + fit <- quiet(rstanarm::stan_glm( + Sepal.Length ~ Sepal.Width, + data = iris, + seed = 666, + algorithm = "optimizing" + )) + testthat::expect_error(psycho::analyze(fit)) +}) + + + +test_that("assess", { + x <- assess( + patient = 10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$p, 0.018, tol = 0.02) + + x <- assess( + patient = 10, + mean = 8, + sd = 2, + n = 10 + ) + + testthat::expect_equal(x$values$p, 0.18, tol = 0.02) + + x <- assess( + patient = c(10, 12), + mean = 8, + sd = 2, + verbose = FALSE + ) + + testthat::expect_equal(x[[1]]$values$p, 0.16, tol = 0.05) +}) + + + + +test_that("bayes_cor", { + results <- psycho::bayes_cor.test( + psycho::affective$Concealing, + psycho::affective$Tolerating + ) + + testthat::expect_equal(results$values$median, 0.073, tol = 0.05) + testthat::expect_equal(results$values$effect_size$values$`very small`, 0.82, tol = 0.05) + + results <- psycho::bayes_cor(iris) + testthat::expect_equal(nrow(results$values$r), 4) + + + results <- psycho::bayes_cor( + dplyr::select(iris, dplyr::starts_with("Sepal")), + dplyr::select(iris, dplyr::starts_with("Petal")) + ) + testthat::expect_equal(nrow(results$values$r), 2) +}) + + + + + + +test_that("correlation", { + df <- attitude[c("rating", "complaints", "privileges", "learning")] + + + # Pearson + output <- psycho::correlation(df) + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.82, tol = 0.1) + + # Spearman + output <- psycho::correlation(df, method = "spearman") + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.83, tol = 0.1) + + # Partial + output <- psycho::correlation(df, type = "partial", adjust = "holm") + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.72, tol = 0.1) + + # Semi + output <- psycho::correlation(df, type = "semi", adjust = "none") + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.53, tol = 0.1) + + # glasso + # testthat::expect_warning(psycho::correlation(df, type = "glasso", adjust = "none")) + + # cor_auto + output <- psycho::correlation(df, type = "cor_auto", adjust = "none") + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.82, tol = 0.1) + + # Dual + df2 <- attitude[c("raises", "critical")] + output <- psycho::correlation(df, df2, type = "full", adjust = "none") + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.67, tol = 0.1) + + + + type <- "semi" + adjust <- "none" + method <- "pearson" + output <- psycho::correlation(df, df2, type = "semi", adjust = "none") + value <- output$values$r[2, 1] + testthat::expect_equal(value, 0.46, tol = 0.1) + + plot <- plot(output) + testthat::expect_equal(length(plot), 10, tol = 0.1) + + # Other + testthat::expect_warning(psycho::correlation(df, type = "dupa", adjust = "holm")) + + # Plot + plot <- plot(correlation(df)) + testthat::expect_equal(length(plot), 10, tol = 0.1) + + testthat::expect_warning(correlation(data.frame(replicate(11, rnorm(100))), adjust = "none")) +}) + + + + + +test_that("crawford.test", { + + # bayesian ---------------------------------------------------------------- + + + x <- crawford.test( + patient = 10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$p, 0.019, tol = 0.02) + + x <- crawford.test( + patient = -10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$p, 0.019, tol = 0.02) + + + + # frequentist ------------------------------------------------------------- + + + x <- crawford.test.freq( + patient = 10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, 3.05, tol = 0.2) + + x <- crawford.test.freq( + patient = -10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, -3.3, tol = 0.2) + + x <- crawford.test.freq( + patient = 7, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, 2.10, tol = 0.2) + + x <- crawford.test.freq( + patient = 0, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, -0.12, tol = 0.2) +}) + + + + + + + +test_that("crawford.test", { + x <- crawford_dissociation.test( + case_X = 142, + case_Y = 7, + controls_X = c(100, 125, 89, 105, 109, 99), + controls_Y = c(7, 8, 9, 6, 7, 10) + ) + + testthat::expect_equal(x$t, 2.1, tol = 0.02) +}) + + + + + +test_that("create_intervals", { + x <- psycho::rnorm_perfect(1000) + testthat::expect_equal(length(levels(psycho::create_intervals(x, 3))), 3) + testthat::expect_equal(length(levels(psycho::create_intervals(x, length = 100))), 2) + testthat::expect_equal(length(levels(psycho::create_intervals(x, 3, equal_range = FALSE))), 3) + testthat::expect_true(is.numeric(psycho::create_intervals(x, 3, labels = "median"))) + testthat::expect_true(is.numeric(psycho::create_intervals(x, 3, labels = FALSE))) +}) + + + + + +test_that("dprime", { + testthat::expect_equal(dprime(9, 2, 1, 7)$dprime, 1.65, tolerance = 0.1) + testthat::expect_equal(dprime(1, 9, 1, 0)$dprime, -1.49, tolerance = 0.1) + + df <- data.frame( + Participant = c("A", "B", "C"), + n_hit = c(1, 2, 5), + n_fa = c(6, 8, 1) + ) + + indices <- dprime(n_hit = df$n_hit, n_fa = df$n_fa, n_targets = 10, n_distractors = 10, adjusted = F) + testthat::expect_equal(indices$dprime[1], -1.53, tolerance = 0.1) + + testthat::expect_equal(dprime(5, 0, n_targets = 10, n_distractors = 8, adjusted = FALSE)$aprime, 0.875, tolerance = 0.1) +}) + + + + + +test_that("find_best_model.stanreg", { + testthat::expect_equal(1, 1) + + # The following fails for some reasons + + # data <- standardize(attitude) + # fit <- rstanarm::stan_glm(rating ~ advance + privileges, + # chains = 1, iter = 500, + # data=data, + # seed=666) + # + # best <- find_best_model(fit, K=2) + # best_formula <- best$formula + # testthat::expect_equal(best_formula, "rating ~ privileges") + # + # best <- find_best_model(fit, K=0) + # best_formula <- best$formula + # testthat::expect_equal(best_formula, "rating ~ privileges") +}) + + + + + +test_that("find_combinations.formula", { + f <- as.formula("Y ~ A + B + C + D + (1|E)") + combinations <- find_combinations(f) + testthat::expect_equal(length(combinations), 32) +}) + + + + +test_that("find_matching_string", { + testthat::expect_equal(find_matching_string("Hwo rea ouy", c("How are you", "Not this word", "Nice to meet you")), "How are you") +}) + + + + + +test_that("find_random_effects", { + f <- as.formula("Y ~ A + B + C + D + (1|E)") + rf <- psycho::find_random_effects(f) + testthat::expect_equal(rf, "(1|E)") +}) + + + + + + + +test_that("find_season", { + dates <- c("2017-02-15", "2017-05-15", "2017-08-15", "2017-11-15") + dates <- find_season(dates) + expect_equal(as.character(dates[1]), "Winter") +}) + + + + + +test_that("formatting", { + + testthat::expect_equal(format_p(0.00000), "< .001***") + testthat::expect_equal(format_p(0.00000, stars = FALSE), "< .001") + + testthat::expect_equal(format_formula(paste("A", "~ B")), "A ~ B") +}) + + + + + + + +test_that("get_contrasts", { + # rstanarm + require(rstanarm) + + df <- psycho::affective + fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data = df) + + contrasts <- psycho::get_contrasts(fit, "Salary") + testthat::expect_equal(mean(contrasts$Median), -0.134, tolerance = 0.05) + + # lmerTest + require(lmerTest) + + fit <- lmerTest::lmer(Adjusting ~ Birth_Season + (1 | Salary), data = psycho::affective) + + contrasts <- get_contrasts(fit) + testthat::expect_equal(mean(contrasts$Difference), -0.218, tolerance = 0.05) + + # glmer + require(lme4) + + fit <- lme4::glmer(Sex ~ Birth_Season + (1 | Salary), data = psycho::affective, family = "binomial") + + contrasts <- get_contrasts(fit, adjust = "bonf") + testthat::expect_equal(mean(contrasts$Difference), -0.0734, tolerance = 0.05) + + # glm + fit <- glm(Sex ~ Birth_Season, data = psycho::affective, family = "binomial") + + contrasts <- get_contrasts(fit) + testthat::expect_equal(mean(contrasts$Difference), -0.0458, tolerance = 0.05) +}) + + + + + + + + + + + +test_that("get_info", { + fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") + info <- get_info(fit) + testthat::expect_equal(info$outcome, "vs") + + fit <- lme4::lmer(hp ~ wt + (1 | gear), data = mtcars) + info <- get_info(fit) + testthat::expect_equal(info$outcome, "hp") + + fit <- glm(vs ~ wt, data = mtcars, family = "binomial") + info <- get_info(fit) + testthat::expect_equal(info$outcome, "vs") + + fit <- lm(hp ~ wt, data = mtcars) + info <- get_info(fit) + testthat::expect_equal(info$outcome, "hp") + + fit <- rstanarm::stan_glm(hp ~ wt, data = mtcars) + info <- get_info(fit) + testthat::expect_equal(info$outcome, "hp") + + outcome <- "hp" + fit <- lm(paste(outcome, " ~ wt"), data = mtcars) + info <- get_info(fit) + testthat::expect_equal(info$outcome, "hp") +}) + + + + + + + + +test_that("get_means", { + # rstanarm + require(rstanarm) + + df <- psycho::affective + fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data = df) + + means <- psycho::get_means(fit, "Salary") + testthat::expect_equal(mean(means$Median), 4.876, tolerance = 0.05) + + + # lmerTest + require(lmerTest) + + fit <- lmerTest::lmer(Adjusting ~ Birth_Season + (1 | Salary), data = psycho::affective) + + means <- get_means(fit, formula = "Birth_Season") + testthat::expect_equal(mean(means$Mean), 3.860, tolerance = 0.05) + + + # glmer + require(lme4) + + fit <- lme4::glmer(Sex ~ Birth_Season + (1 | Salary), data = psycho::affective, family = "binomial") + + means <- get_means(fit, formula = "Birth_Season") + testthat::expect_equal(mean(means$Mean), -1.221759, tolerance = 0.05) + + # glm + fit <- glm(Sex ~ Birth_Season, data = psycho::affective, family = "binomial") + + means <- get_means(fit, formula = "Birth_Season") + testthat::expect_equal(mean(means$Mean), -1.413, tolerance = 0.05) +}) + + + + + + + + + + + + + + +test_that("get_predicted", { + + + + # Rstanarm ---------------------------------------------------------------- + library(psycho) + require(rstanarm) + + + fit <- rstanarm::stan_glm( + vs ~ mpg, + data = mtcars, + family = binomial(link = "logit"), + seed = 666 + ) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(data$vs, data$vs_Median)$estimate) + testthat::expect_equal(r, 0.68, tolerance = 0.2) + + + + + fit <- rstanarm::stan_glm( + cyl ~ mpg, + data = mtcars, + seed = 666 + ) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(data$cyl, data$cyl_Median)$estimate) + testthat::expect_equal(r, 0.85, tolerance = 0.02) + + + + fit <- rstanarm::stan_glm( + Sepal.Length ~ Sepal.Width + Species, + data = iris, + seed = 666 + ) + data <- psycho::get_predicted(fit, posterior_predict = TRUE) + r <- as.numeric(cor.test(data$Sepal.Length, data$Sepal.Length_Median)$estimate) + testthat::expect_equal(r, 0.84, tolerance = 0.02) + + + # Actual test ------------------------------------------------------------- + + df <- psycho::affective + fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, data = df) + ref_grid <- emmeans::ref_grid(fit, at = list( + Tolerating = seq(min(df$Tolerating), + max(df$Tolerating), + length.out = 10 + ) + )) + + predicted <- psycho::get_predicted(fit, newdata = ref_grid) + testthat::expect_equal(mean(predicted$Life_Satisfaction_Median), 4.77, tolerance = 0.05) + + predicted <- psycho::get_predicted(fit, newdata = ref_grid, keep_iterations = TRUE) + testthat::expect_equal(length(predicted), 4004) + + + + + + + + # GLM and LM -------------------------------------------------------------- + + fit <- glm(vs ~ mpg, data = mtcars, family = binomial(link = "logit")) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(data$vs, data$vs_Predicted)$estimate) + testthat::expect_equal(r, 0.68, tolerance = 0.2) + + + fit <- lm(cyl ~ mpg, data = mtcars) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(mtcars$cyl, data$cyl_Predicted)$estimate) + testthat::expect_equal(r, 0.85, tolerance = 0.02) + + # glmerMod ---------------------------------------------------------------- + library(lme4) + + fit <- lme4::glmer(vs ~ mpg + (1 | cyl), data = mtcars, family = binomial(link = "logit")) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(data$vs, data$vs_Predicted)$estimate) + testthat::expect_equal(r, 0.79, tolerance = 0.02) + + fit <- lme4::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(data$Tolerating, data$Tolerating_Predicted)$estimate) + testthat::expect_equal(r, 0.3, tolerance = 0.02) + + library(lmerTest) + fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) + data <- psycho::get_predicted(fit) + r <- as.numeric(cor.test(data$Tolerating, data$Tolerating_Predicted)$estimate) + testthat::expect_equal(r, 0.3, tolerance = 0.02) +}) + + + + + + + + + + + +test_that("get_R2", { + # Fit + library(psycho) + + fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) + testthat::expect_equal(psycho::get_R2(fit)$R2, 0.08, tol = 0.01) + + fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") + testthat::expect_equal(psycho::get_R2(fit), 0.025, tol = 0.01) + + fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), data = psycho::affective) + testthat::expect_equal(psycho::get_R2(fit)$R2m, 0.08, tol = 0.01) + testthat::expect_equal(psycho::get_R2(fit, method = "tjur")$R2m, 0.081, tol = 0.01) + + fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = na.omit(psycho::affective), family = "binomial") + testthat::expect_equal(psycho::get_R2(fit)$R2m, 0.037, tol = 0.01) +}) + + + + + + + +test_that("hdi", { + x <- attitude$rating + results <- psycho::HDI(x, 0.95) + + testthat::expect_equal(results$values$HDImin, 40) + testthat::expect_equal(length(plot(results)), 9) + testthat::expect_equal(psycho::HDI(x, 95)$values$HDImin, 40) +}) + + + + + + + + +test_that("interpret_bf", { + testthat::expect_equal(psycho::interpret_bf(3), "moderate evidence (BF = 3.00) in favour of") + testthat::expect_equal(psycho::interpret_bf(1 / 3), "moderate evidence (BF = 3.00) against") + testthat::expect_equal(psycho::interpret_bf(1 / 3, rules = "raftery1995"), "positive evidence (BF = 3.00) against") +}) + + + + + +test_that("interpret_d", { + testthat::expect_equal(psycho::interpret_d(0), "very small") + testthat::expect_equal(psycho::interpret_d(0, rules = "sawilowsky2009"), "tiny") + + testthat::expect_equal(psycho::interpret_d_posterior(c(0.1, 0.1, 0.1, 0.1))$values$large, 0) +}) + + + + + + +test_that("interpret_odds", { + testthat::expect_equal(psycho::interpret_odds(0), "very small") + testthat::expect_equal(psycho::interpret_odds(0, log = TRUE), "very small") + testthat::expect_equal(psycho::interpret_odds(5, log = TRUE), "large") + testthat::expect_equal(psycho::interpret_odds(5, log = TRUE, rules = "cohen1988"), "large") + + testthat::expect_equal(psycho::interpret_odds_posterior(c(5, 5, 5, 5))$values$large, 0) +}) + + + + + + + + +test_that("interpret_r", { + testthat::expect_equal(psycho::interpret_r(0), "very small, and negative") + testthat::expect_equal(psycho::interpret_r(0, rules = "evans1996"), "very weak, and negative") +}) + + + + + + + +test_that("interpret_R2", { + testthat::expect_equal(psycho::interpret_R2(0.2), "medium") + testthat::expect_equal(psycho::interpret_R2(0.2, rules = "chin1998"), "small") + testthat::expect_equal(psycho::interpret_R2(0.2, rules = "hair2013"), "very small") + testthat::expect_true(is.na(psycho::interpret_R2(-5))) + + testthat::expect_equal(psycho::interpret_R2_posterior(c(0.2, 0.2, 0.2))$values$medium, 1) + testthat::expect_equal(psycho::interpret_R2_posterior(c(0.1, 0.2, 0.3, 0.4))$values$large, 0.5) +}) + + + + + + + + +test_that("interpret_RMSEA", { + testthat::expect_equal(psycho::interpret_RMSEA(0.04), "good") + testthat::expect_equal(psycho::interpret_RMSEA(0.05), "acceptable") + testthat::expect_equal(psycho::interpret_RMSEA(0.08), "poor") +}) + + + + + + + + + +test_that("is.mixed.stanreg", { + library(rstanarm) + fit <- rstanarm::stan_glm(Sepal.Length ~ Petal.Length, data = iris, iter = 100) + testthat::expect_equal(is.mixed(fit), FALSE) + fit <- rstanarm::stan_lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris, iter = 100) + testthat::expect_equal(is.mixed(fit), TRUE) +}) + + + + + + + + + +test_that("is.psychobject", { + df <- attitude + results <- psycho::correlation(df) + testthat::expect_true(psycho::is.psychobject(results)) +}) + + + + + + + + +test_that("is.standardized", { + df <- psycho::affective + testthat::expect_equal(is.standardized(df), F) + df <- psycho::standardize(df) + testthat::expect_equal(is.standardized(df), T) +}) + + + + + + +test_that("mellenbergh.test", { + x <- mellenbergh.test( + t0 = 4, + t1 = 12, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$z, 1.90, tol = 0.2) + + + x <- mellenbergh.test( + t0 = 4, + t1 = 12, + controls = 2.54 + ) + + testthat::expect_equal(x$values$z, 2.22, tol = 0.2) + + x <- mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) + testthat::expect_equal(x$values$z, 1.90, tol = 0.1) + x <- mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) + testthat::expect_equal(x$values$z, -1.63, tol = 0.1) +}) + + + + + + + +test_that("model_to_priors", { + fit <- rstanarm::stan_glm(Sepal.Length ~ Petal.Width, data = iris) + priors <- psycho::model_to_priors(fit) + testthat::expect_equal(length(priors), 3) +}) + + + + + + +test_that("n_factors", { + results <- attitude %>% + select_if(is.numeric) %>% + psycho::n_factors() + + testthat::expect_equal(nrow(summary(results)), 7) + testthat::expect_equal(nrow(psycho::values(results)$methods), 9) + testthat::expect_equal(length(plot(results)), 9) +}) + + + + + +test_that("odds_to_probs", { + testthat::expect_equal(odds_to_probs(-1.6), 0.17, tolerance = 0.01) + testthat::expect_equal(odds_to_probs(-1.6, log = F), 2.66, tolerance = 0.01) + + testthat::expect_equal( + ncol(odds_to_probs( + psycho::affective, + subset = c("Life_Satisfaction"), + except = c("Sex") + )), + 8 + ) +}) + + + + + + + + +test_that("overlap", { + x <- rnorm(1000, 1, 0.5) + y <- rnorm(1000, 0, 1) + testthat::expect_equal(overlap(x, y), 0.43, tolerance = 0.1) +}) + + + + + + + +test_that("plot.psychobject", { + output <- list(plot = 1) + class(output) <- c("psychobject", "list") + plot <- plot(output) + expect_equal(plot, 1) +}) + + + + + + + +test_that("power_analysis", { + fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) + results <- psycho::power_analysis(fit, n_max = 300, n_min = 150, step = 50, n_batch = 1) + + testthat::expect_equal(nrow(results), 8, tolerance = 0.01) +}) + + + + + + + +test_that("print.psychobject", { + output <- list(text = 1) + class(output) <- c("psychobject", "list") + text <- print(output) + expect_equal(text, 1) +}) + + + + + +test_that("probs_to_odds", { + testthat::expect_equal(probs_to_odds(0.75), 3, tolerance = 0.01) + testthat::expect_equal(probs_to_odds(0.75, log = TRUE), 1.098, tolerance = 0.01) +}) + + + + + + +test_that("refdata", { + testthat::expect_equal(nrow(psycho::refdata(psycho::affective, target = "Sex")), 2) + testthat::expect_equal(nrow(psycho::refdata(iris, length.out = 2)), 48) + testthat::expect_equal(nrow(psycho::refdata(iris, target = "Sepal.Length", length.out = 2, factors = "combinations")), 6) + testthat::expect_equal(nrow(psycho::refdata(iris, target = "Species", length.out = 2, factors = "combinations")), 3) + testthat::expect_equal(nrow(psycho::refdata(iris, target = "Species", length.out = 2, numerics = 0)), 3) +}) + + + + + + + + + + +test_that("remove_empty_cols", { + df <- data.frame( + A = c(1, 2, 3), + B = c(1, 2, 3) + ) + df$C <- NA + + testthat::expect_equal(ncol(psycho::remove_empty_cols(df)), 2) +}) + + + + + +test_that("rnorm_perfect", { + x <- psycho::rnorm_perfect(10, 0, 1) + testthat::expect_equal(mean(x), 0, tolerance = 0.02) + + x <- psycho::rnorm_perfect(10, 0, 1, method = "average") + testthat::expect_equal(mean(x), 0, tolerance = 0.05) +}) + + + + + + +test_that("standardize", { + library(psycho) + + set.seed(666) + df <- data.frame( + Participant = as.factor(rep(1:25, each = 4)), + Condition = base::rep_len(c("A", "B", "C", "D"), 100), + V1 = rnorm(100, 30, .2), + V2 = runif(100, 3, 5), + V3 = rnorm(100, 100, 10) + ) + + # Deactivate all this for CRAN + + # dfZ <- standardize(df) + # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) + # + # dfZ <- standardize(df, except = "V3") + # testthat::expect_equal(mean(dfZ$V2), 0, tol = 0.01) + # + # dfZ <- standardize(df, except = c("V1", "V2")) + # testthat::expect_equal(mean(dfZ$V3), 0, tol = 0.01) + # + # dfZ <- standardize(df$V1) + # testthat::expect_equal(mean(dfZ), 0, tol = 0.01) + # + # dfZ <- standardize(df, subset = c("V1", "V2")) + # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) + # + # dfZ <- standardize(df, subset = "V1", except = "V3") + # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) + # + # dfZ <- standardize(dplyr::group_by(df, Participant)) + # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) + # + # dfN <- standardize(df, except = "V3", normalize = TRUE) + # testthat::expect_equal(mean(dfN$V2), 0.533, tol = 0.5) + + + # Models + fit <- rstanarm::stan_glm( + Sepal.Length ~ Sepal.Width, + data = iris, + seed = 666, + algorithm = "meanfield" + ) + + std <- standardize(fit, method = "posterior") + testthat::expect_equal(mean(std), -0.24, tol = 0.02) + + std <- standardize(fit, method = "sample") + testthat::expect_equal(mean(std), 1.34, tol = 0.02) + + fit <- lm( + Sepal.Length ~ Sepal.Width, + data = iris + ) + + std <- standardize(fit, method = "posthoc") + testthat::expect_equal(mean(std$Coef_std), -0.059, tol = 0.01) +}) + + + + + + +test_that("values.psychobject", { + output <- list(values = 1) + class(output) <- c("psychobject", "list") + values <- values(output) + expect_equal(values, 1) +}) + + + + + + + + +test_that("analyze.fa", { + library(psycho) + library(psych) + + x <- psych::fa(psych::Thurstone.33, 2) + + results <- analyze(x) + testthat::expect_equal(nrow(summary(results)), 9) + + cfa_model <- get_cfa_model(results$values$loadings, treshold = 0.3) + testthat::expect_equal(length(cfa_model), 1) +}) diff --git a/tests/testthat/test-dprime.R b/tests/testthat/test-dprime.R deleted file mode 100644 index cd952a3..0000000 --- a/tests/testthat/test-dprime.R +++ /dev/null @@ -1,17 +0,0 @@ -context("dprime") - -test_that("Correct Value", { - testthat::expect_equal(dprime(9, 2, 1, 7)$dprime, 1.65, tolerance = 0.1) - testthat::expect_equal(dprime(1, 9, 1, 0)$dprime, -1.49, tolerance = 0.1) - - df <- data.frame( - Participant = c("A", "B", "C"), - n_hit = c(1, 2, 5), - n_fa = c(6, 8, 1) - ) - - indices <- dprime(n_hit = df$n_hit, n_fa = df$n_fa, n_targets = 10, n_distractors = 10, adjusted = F) - testthat::expect_equal(indices$dprime[1], -1.53, tolerance = 0.1) - - testthat::expect_equal(dprime(5, 0, n_targets = 10, n_distractors = 8, adjusted = FALSE)$aprime, 0.875, tolerance = 0.1) -}) diff --git a/tests/testthat/test-find_best_model.stanreg.R b/tests/testthat/test-find_best_model.stanreg.R deleted file mode 100644 index 564816f..0000000 --- a/tests/testthat/test-find_best_model.stanreg.R +++ /dev/null @@ -1,21 +0,0 @@ -context("find_best_model.stanreg") - -test_that("Correct", { - testthat::expect_equal(1, 1) - - # The following fails for some reasons - - # data <- standardize(attitude) - # fit <- rstanarm::stan_glm(rating ~ advance + privileges, - # chains = 1, iter = 500, - # data=data, - # seed=666) - # - # best <- find_best_model(fit, K=2) - # best_formula <- best$formula - # testthat::expect_equal(best_formula, "rating ~ privileges") - # - # best <- find_best_model(fit, K=0) - # best_formula <- best$formula - # testthat::expect_equal(best_formula, "rating ~ privileges") -}) diff --git a/tests/testthat/test-find_combinations.formula.R b/tests/testthat/test-find_combinations.formula.R deleted file mode 100644 index 0517d6d..0000000 --- a/tests/testthat/test-find_combinations.formula.R +++ /dev/null @@ -1,7 +0,0 @@ -context("find_combinations.formula") - -test_that("Correct", { - f <- as.formula("Y ~ A + B + C + D + (1|E)") - combinations <- find_combinations(f) - testthat::expect_equal(length(combinations), 32) -}) diff --git a/tests/testthat/test-find_matching_string.R b/tests/testthat/test-find_matching_string.R deleted file mode 100644 index b497bbb..0000000 --- a/tests/testthat/test-find_matching_string.R +++ /dev/null @@ -1,5 +0,0 @@ -context("find_matching_string") - -test_that("Correct", { - testthat::expect_equal(find_matching_string("Hwo rea ouy", c("How are you", "Not this word", "Nice to meet you")), "How are you") -}) diff --git a/tests/testthat/test-find_random_effects.R b/tests/testthat/test-find_random_effects.R deleted file mode 100644 index c941c59..0000000 --- a/tests/testthat/test-find_random_effects.R +++ /dev/null @@ -1,7 +0,0 @@ -context("find_random_effects") - -test_that("Correct", { - f <- as.formula("Y ~ A + B + C + D + (1|E)") - rf <- psycho::find_random_effects(f) - testthat::expect_equal(rf, "(1|E)") -}) diff --git a/tests/testthat/test-find_season.R b/tests/testthat/test-find_season.R deleted file mode 100644 index 45564a9..0000000 --- a/tests/testthat/test-find_season.R +++ /dev/null @@ -1,7 +0,0 @@ -context("find_season") - -test_that("Correct date", { - dates <- c("2017-02-15", "2017-05-15", "2017-08-15", "2017-11-15") - dates <- find_season(dates) - expect_equal(as.character(dates[1]), "Winter") -}) diff --git a/tests/testthat/test-formatting.R b/tests/testthat/test-formatting.R deleted file mode 100644 index 0bdefcb..0000000 --- a/tests/testthat/test-formatting.R +++ /dev/null @@ -1,20 +0,0 @@ -context("formatting") - -test_that("Formatting works as expected", { - testthat::expect_equal(format_digit(0.0008), "0") - testthat::expect_equal(format_digit(0.00000), "0") - testthat::expect_equal(format_digit(0.005887), "0.0059") - testthat::expect_equal(format_digit(0.0405), "0.040") - testthat::expect_equal(format_digit(-0.005887), "-0.0059") - testthat::expect_equal(format_digit(-0.0405), "-0.040") - testthat::expect_equal(format_digit(0.405), "0.40") - testthat::expect_equal(format_digit(1.1587), "1.16") - testthat::expect_equal(format_digit(12), "12") - testthat::expect_equal(format_digit(1.101), "1.10") - testthat::expect_equal(format_digit(9e+10), "Inf.") - - testthat::expect_equal(format_p(0.00000), "< .001***") - testthat::expect_equal(format_p(0.00000, stars = FALSE), "< .001") - - testthat::expect_equal(format_formula(paste("A", "~ B")), "A ~ B") -}) diff --git a/tests/testthat/test-get_R2.R b/tests/testthat/test-get_R2.R deleted file mode 100644 index 7619ae6..0000000 --- a/tests/testthat/test-get_R2.R +++ /dev/null @@ -1,19 +0,0 @@ -context("get_R2") - -test_that("If it works.", { - # Fit - library(psycho) - - fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) - testthat::expect_equal(psycho::get_R2(fit)$R2, 0.08, tol = 0.01) - - fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") - testthat::expect_equal(psycho::get_R2(fit), 0.025, tol = 0.01) - - fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), data = psycho::affective) - testthat::expect_equal(psycho::get_R2(fit)$R2m, 0.08, tol = 0.01) - testthat::expect_equal(psycho::get_R2(fit, method = "tjur")$R2m, 0.081, tol = 0.01) - - fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = na.omit(psycho::affective), family = "binomial") - testthat::expect_equal(psycho::get_R2(fit)$R2m, 0.037, tol = 0.01) -}) diff --git a/tests/testthat/test-get_contrasts.R b/tests/testthat/test-get_contrasts.R deleted file mode 100644 index 8c1c5c7..0000000 --- a/tests/testthat/test-get_contrasts.R +++ /dev/null @@ -1,34 +0,0 @@ -context("get_contrasts") - -test_that("If it works.", { - # rstanarm - require(rstanarm) - - df <- psycho::affective - fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data = df) - - contrasts <- psycho::get_contrasts(fit, "Salary") - testthat::expect_equal(mean(contrasts$Median), -0.134, tolerance = 0.05) - - # lmerTest - require(lmerTest) - - fit <- lmerTest::lmer(Adjusting ~ Birth_Season + (1 | Salary), data = psycho::affective) - - contrasts <- get_contrasts(fit) - testthat::expect_equal(mean(contrasts$Difference), -0.218, tolerance = 0.05) - - # glmer - require(lme4) - - fit <- lme4::glmer(Sex ~ Birth_Season + (1 | Salary), data = psycho::affective, family = "binomial") - - contrasts <- get_contrasts(fit, adjust = "bonf") - testthat::expect_equal(mean(contrasts$Difference), -0.0734, tolerance = 0.05) - - # glm - fit <- glm(Sex ~ Birth_Season, data = psycho::affective, family = "binomial") - - contrasts <- get_contrasts(fit) - testthat::expect_equal(mean(contrasts$Difference), -0.0458, tolerance = 0.05) -}) diff --git a/tests/testthat/test-get_info.R b/tests/testthat/test-get_info.R deleted file mode 100644 index 77e6d34..0000000 --- a/tests/testthat/test-get_info.R +++ /dev/null @@ -1,28 +0,0 @@ -context("get_info") - -test_that("Correct Value", { - fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") - info <- get_info(fit) - testthat::expect_equal(info$outcome, "vs") - - fit <- lme4::lmer(hp ~ wt + (1 | gear), data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") - - fit <- glm(vs ~ wt, data = mtcars, family = "binomial") - info <- get_info(fit) - testthat::expect_equal(info$outcome, "vs") - - fit <- lm(hp ~ wt, data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") - - fit <- rstanarm::stan_glm(hp ~ wt, data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") - - outcome <- "hp" - fit <- lm(paste(outcome, " ~ wt"), data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") -}) diff --git a/tests/testthat/test-get_means.R b/tests/testthat/test-get_means.R deleted file mode 100644 index a6e3943..0000000 --- a/tests/testthat/test-get_means.R +++ /dev/null @@ -1,36 +0,0 @@ -context("get_means") - -test_that("If it works.", { - # rstanarm - require(rstanarm) - - df <- psycho::affective - fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data = df) - - means <- psycho::get_means(fit, "Salary") - testthat::expect_equal(mean(means$Median), 4.876, tolerance = 0.05) - - - # lmerTest - require(lmerTest) - - fit <- lmerTest::lmer(Adjusting ~ Birth_Season + (1 | Salary), data = psycho::affective) - - means <- get_means(fit, formula = "Birth_Season") - testthat::expect_equal(mean(means$Mean), 3.860, tolerance = 0.05) - - - # glmer - require(lme4) - - fit <- lme4::glmer(Sex ~ Birth_Season + (1 | Salary), data = psycho::affective, family = "binomial") - - means <- get_means(fit, formula = "Birth_Season") - testthat::expect_equal(mean(means$Mean), -1.221759, tolerance = 0.05) - - # glm - fit <- glm(Sex ~ Birth_Season, data = psycho::affective, family = "binomial") - - means <- get_means(fit, formula = "Birth_Season") - testthat::expect_equal(mean(means$Mean), -1.413, tolerance = 0.05) -}) diff --git a/tests/testthat/test-get_predicted.R b/tests/testthat/test-get_predicted.R deleted file mode 100644 index c99d4a5..0000000 --- a/tests/testthat/test-get_predicted.R +++ /dev/null @@ -1,100 +0,0 @@ -context("get_predicted") - -test_that("If it works.", { - - - - # Rstanarm ---------------------------------------------------------------- - library(psycho) - require(rstanarm) - - - fit <- rstanarm::stan_glm( - vs ~ mpg, - data = mtcars, - family = binomial(link = "logit"), - seed = 666 - ) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$vs, data$vs_Median)$estimate) - testthat::expect_equal(r, 0.68, tolerance = 0.2) - - - - - fit <- rstanarm::stan_glm( - cyl ~ mpg, - data = mtcars, - seed = 666 - ) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$cyl, data$cyl_Median)$estimate) - testthat::expect_equal(r, 0.85, tolerance = 0.02) - - - - fit <- rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width + Species, - data = iris, - seed = 666 - ) - data <- psycho::get_predicted(fit, posterior_predict = TRUE) - r <- as.numeric(cor.test(data$Sepal.Length, data$Sepal.Length_Median)$estimate) - testthat::expect_equal(r, 0.84, tolerance = 0.02) - - - # Actual test ------------------------------------------------------------- - - df <- psycho::affective - fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, data = df) - ref_grid <- emmeans::ref_grid(fit, at = list( - Tolerating = seq(min(df$Tolerating), - max(df$Tolerating), - length.out = 10 - ) - )) - - predicted <- psycho::get_predicted(fit, newdata = ref_grid) - testthat::expect_equal(mean(predicted$Life_Satisfaction_Median), 4.77, tolerance = 0.05) - - predicted <- psycho::get_predicted(fit, newdata = ref_grid, keep_iterations = TRUE) - testthat::expect_equal(length(predicted), 4004) - - - - - - - - # GLM and LM -------------------------------------------------------------- - - fit <- glm(vs ~ mpg, data = mtcars, family = binomial(link = "logit")) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$vs, data$vs_Predicted)$estimate) - testthat::expect_equal(r, 0.68, tolerance = 0.2) - - - fit <- lm(cyl ~ mpg, data = mtcars) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(mtcars$cyl, data$cyl_Predicted)$estimate) - testthat::expect_equal(r, 0.85, tolerance = 0.02) - - # glmerMod ---------------------------------------------------------------- - library(lme4) - - fit <- lme4::glmer(vs ~ mpg + (1 | cyl), data = mtcars, family = binomial(link = "logit")) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$vs, data$vs_Predicted)$estimate) - testthat::expect_equal(r, 0.79, tolerance = 0.02) - - fit <- lme4::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$Tolerating, data$Tolerating_Predicted)$estimate) - testthat::expect_equal(r, 0.3, tolerance = 0.02) - - library(lmerTest) - fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$Tolerating, data$Tolerating_Predicted)$estimate) - testthat::expect_equal(r, 0.3, tolerance = 0.02) -}) diff --git a/tests/testthat/test-hdi.R b/tests/testthat/test-hdi.R deleted file mode 100644 index dd0cd3c..0000000 --- a/tests/testthat/test-hdi.R +++ /dev/null @@ -1,10 +0,0 @@ -context("hdi") - -test_that("Correct Value", { - x <- attitude$rating - results <- psycho::HDI(x, 0.95) - - testthat::expect_equal(results$values$HDImin, 40) - testthat::expect_equal(length(plot(results)), 9) - testthat::expect_equal(psycho::HDI(x, 95)$values$HDImin, 40) -}) diff --git a/tests/testthat/test-interpret_R2.R b/tests/testthat/test-interpret_R2.R deleted file mode 100644 index 2f966b8..0000000 --- a/tests/testthat/test-interpret_R2.R +++ /dev/null @@ -1,11 +0,0 @@ -context("interpret_R2") - -test_that("Correct Value", { - testthat::expect_equal(psycho::interpret_R2(0.2), "medium") - testthat::expect_equal(psycho::interpret_R2(0.2, rules = "chin1998"), "small") - testthat::expect_equal(psycho::interpret_R2(0.2, rules = "hair2013"), "very small") - testthat::expect_true(is.na(psycho::interpret_R2(-5))) - - testthat::expect_equal(psycho::interpret_R2_posterior(c(0.2, 0.2, 0.2))$values$medium, 1) - testthat::expect_equal(psycho::interpret_R2_posterior(c(0.1, 0.2, 0.3, 0.4))$values$large, 0.5) -}) diff --git a/tests/testthat/test-interpret_RMSEA.R b/tests/testthat/test-interpret_RMSEA.R deleted file mode 100644 index 7860351..0000000 --- a/tests/testthat/test-interpret_RMSEA.R +++ /dev/null @@ -1,7 +0,0 @@ -context("interpret_RMSEA") - -test_that("Correct Value", { - testthat::expect_equal(psycho::interpret_RMSEA(0.04), "good") - testthat::expect_equal(psycho::interpret_RMSEA(0.05), "acceptable") - testthat::expect_equal(psycho::interpret_RMSEA(0.08), "poor") -}) diff --git a/tests/testthat/test-interpret_bf.R b/tests/testthat/test-interpret_bf.R deleted file mode 100644 index 54fa9b1..0000000 --- a/tests/testthat/test-interpret_bf.R +++ /dev/null @@ -1,7 +0,0 @@ -context("interpret_bf") - -test_that("Correct Value", { - testthat::expect_equal(psycho::interpret_bf(3), "moderate evidence (BF = 3) in favour of") - testthat::expect_equal(psycho::interpret_bf(1 / 3), "moderate evidence (BF = 3) against") - testthat::expect_equal(psycho::interpret_bf(1 / 3, rules = "raftery1995"), "positive evidence (BF = 3) against") -}) diff --git a/tests/testthat/test-interpret_d.R b/tests/testthat/test-interpret_d.R deleted file mode 100644 index 1859277..0000000 --- a/tests/testthat/test-interpret_d.R +++ /dev/null @@ -1,8 +0,0 @@ -context("interpret_d") - -test_that("Correct Value", { - testthat::expect_equal(psycho::interpret_d(0), "very small") - testthat::expect_equal(psycho::interpret_d(0, rules = "sawilowsky2009"), "tiny") - - testthat::expect_equal(psycho::interpret_d_posterior(c(0.1, 0.1, 0.1, 0.1))$values$large, 0) -}) diff --git a/tests/testthat/test-interpret_odds.R b/tests/testthat/test-interpret_odds.R deleted file mode 100644 index 234a2fc..0000000 --- a/tests/testthat/test-interpret_odds.R +++ /dev/null @@ -1,10 +0,0 @@ -context("interpret_odds") - -test_that("Correct Value", { - testthat::expect_equal(psycho::interpret_odds(0), "very small") - testthat::expect_equal(psycho::interpret_odds(0, log = TRUE), "very small") - testthat::expect_equal(psycho::interpret_odds(5, log = TRUE), "large") - testthat::expect_equal(psycho::interpret_odds(5, log = TRUE, rules = "cohen1988"), "large") - - testthat::expect_equal(psycho::interpret_odds_posterior(c(5, 5, 5, 5))$values$large, 0) -}) diff --git a/tests/testthat/test-interpret_r.R b/tests/testthat/test-interpret_r.R deleted file mode 100644 index fefaad4..0000000 --- a/tests/testthat/test-interpret_r.R +++ /dev/null @@ -1,6 +0,0 @@ -context("interpret_r") - -test_that("Correct Value", { - testthat::expect_equal(psycho::interpret_r(0), "very small, and negative") - testthat::expect_equal(psycho::interpret_r(0, rules = "evans1996"), "very weak, and negative") -}) diff --git a/tests/testthat/test-is.mixed.stanreg.R b/tests/testthat/test-is.mixed.stanreg.R deleted file mode 100644 index 4c27eb9..0000000 --- a/tests/testthat/test-is.mixed.stanreg.R +++ /dev/null @@ -1,9 +0,0 @@ -context("is.mixed.stanreg") - -test_that("Correct Value", { - library(rstanarm) - fit <- rstanarm::stan_glm(Sepal.Length ~ Petal.Length, data = iris, iter = 100) - testthat::expect_equal(is.mixed(fit), FALSE) - fit <- rstanarm::stan_lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris, iter = 100) - testthat::expect_equal(is.mixed(fit), TRUE) -}) diff --git a/tests/testthat/test-is.psychobject.R b/tests/testthat/test-is.psychobject.R deleted file mode 100644 index 422645f..0000000 --- a/tests/testthat/test-is.psychobject.R +++ /dev/null @@ -1,7 +0,0 @@ -context("is.psychobject") - -test_that("is.psychobject", { - df <- attitude - results <- psycho::correlation(df) - testthat::expect_true(psycho::is.psychobject(results)) -}) diff --git a/tests/testthat/test-is.standardized.R b/tests/testthat/test-is.standardized.R deleted file mode 100644 index ece95ae..0000000 --- a/tests/testthat/test-is.standardized.R +++ /dev/null @@ -1,8 +0,0 @@ -context("is.standardized") - -test_that("Correct Value", { - df <- psycho::affective - testthat::expect_equal(is.standardized(df), F) - df <- psycho::standardize(df) - testthat::expect_equal(is.standardized(df), T) -}) diff --git a/tests/testthat/test-mellenbergh.test.R b/tests/testthat/test-mellenbergh.test.R deleted file mode 100644 index b094bcd..0000000 --- a/tests/testthat/test-mellenbergh.test.R +++ /dev/null @@ -1,25 +0,0 @@ -context("mellenbergh.test") - -test_that("Correct Value", { - x <- mellenbergh.test( - t0 = 4, - t1 = 12, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$z, 1.90, tol = 0.2) - - - x <- mellenbergh.test( - t0 = 4, - t1 = 12, - controls = 2.54 - ) - - testthat::expect_equal(x$values$z, 2.22, tol = 0.2) - - x <- mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) - testthat::expect_equal(x$values$z, 1.90, tol = 0.1) - x <- mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) - testthat::expect_equal(x$values$z, -1.63, tol = 0.1) -}) diff --git a/tests/testthat/test-model_to_priors.R b/tests/testthat/test-model_to_priors.R deleted file mode 100644 index 2a891a4..0000000 --- a/tests/testthat/test-model_to_priors.R +++ /dev/null @@ -1,7 +0,0 @@ -context("model_to_priors") - -test_that("Correct", { - fit <- rstanarm::stan_glm(Sepal.Length ~ Petal.Width, data = iris) - priors <- psycho::model_to_priors(fit) - testthat::expect_equal(length(priors), 3) -}) diff --git a/tests/testthat/test-n_factors.R b/tests/testthat/test-n_factors.R deleted file mode 100644 index 1071afe..0000000 --- a/tests/testthat/test-n_factors.R +++ /dev/null @@ -1,11 +0,0 @@ -context("n_factors") - -test_that("Correct Value", { - results <- attitude %>% - select_if(is.numeric) %>% - psycho::n_factors() - - testthat::expect_equal(nrow(summary(results)), 7) - testthat::expect_equal(nrow(psycho::values(results)$methods), 9) - testthat::expect_equal(length(plot(results)), 9) -}) diff --git a/tests/testthat/test-odds_to_probs.R b/tests/testthat/test-odds_to_probs.R deleted file mode 100644 index 911cdcc..0000000 --- a/tests/testthat/test-odds_to_probs.R +++ /dev/null @@ -1,15 +0,0 @@ -context("odds_to_probs") - -test_that("Correct", { - testthat::expect_equal(odds_to_probs(-1.6), 0.17, tolerance = 0.01) - testthat::expect_equal(odds_to_probs(-1.6, log = F), 2.66, tolerance = 0.01) - - testthat::expect_equal( - ncol(odds_to_probs( - psycho::affective, - subset = c("Life_Satisfaction"), - except = c("Sex") - )), - 8 - ) -}) diff --git a/tests/testthat/test-overlap.R b/tests/testthat/test-overlap.R deleted file mode 100644 index 44a8c5e..0000000 --- a/tests/testthat/test-overlap.R +++ /dev/null @@ -1,7 +0,0 @@ -context("overlap") - -test_that("Correct", { - x <- rnorm(1000, 1, 0.5) - y <- rnorm(1000, 0, 1) - testthat::expect_equal(overlap(x, y), 0.43, tolerance = 0.1) -}) diff --git a/tests/testthat/test-plot.psychobject.R b/tests/testthat/test-plot.psychobject.R deleted file mode 100644 index 170c79b..0000000 --- a/tests/testthat/test-plot.psychobject.R +++ /dev/null @@ -1,8 +0,0 @@ -context("plot.psychobject") - -test_that("It works", { - output <- list(plot = 1) - class(output) <- c("psychobject", "list") - plot <- plot(output) - expect_equal(plot, 1) -}) diff --git a/tests/testthat/test-power_analysis.R b/tests/testthat/test-power_analysis.R deleted file mode 100644 index 15e8e63..0000000 --- a/tests/testthat/test-power_analysis.R +++ /dev/null @@ -1,8 +0,0 @@ -context("power_analysis") - -test_that("Correct", { - fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) - results <- psycho::power_analysis(fit, n_max = 300, n_min = 150, step = 50, n_batch = 1) - - testthat::expect_equal(nrow(results), 8, tolerance = 0.01) -}) diff --git a/tests/testthat/test-print.psychobject.R b/tests/testthat/test-print.psychobject.R deleted file mode 100644 index 15b692a..0000000 --- a/tests/testthat/test-print.psychobject.R +++ /dev/null @@ -1,8 +0,0 @@ -context("print.psychobject") - -test_that("It works", { - output <- list(text = 1) - class(output) <- c("psychobject", "list") - text <- print(output) - expect_equal(text, 1) -}) diff --git a/tests/testthat/test-probs_to_odds.R b/tests/testthat/test-probs_to_odds.R deleted file mode 100644 index c84c351..0000000 --- a/tests/testthat/test-probs_to_odds.R +++ /dev/null @@ -1,6 +0,0 @@ -context("probs_to_odds") - -test_that("Correct", { - testthat::expect_equal(probs_to_odds(0.75), 3, tolerance = 0.01) - testthat::expect_equal(probs_to_odds(0.75, log = TRUE), 1.098, tolerance = 0.01) -}) diff --git a/tests/testthat/test-refdata.R b/tests/testthat/test-refdata.R deleted file mode 100644 index 4e7864e..0000000 --- a/tests/testthat/test-refdata.R +++ /dev/null @@ -1,9 +0,0 @@ -context("refdata") - -test_that("If it works.", { - testthat::expect_equal(nrow(psycho::refdata(psycho::affective, target = "Sex")), 2) - testthat::expect_equal(nrow(psycho::refdata(iris, length.out = 2)), 48) - testthat::expect_equal(nrow(psycho::refdata(iris, target = "Sepal.Length", length.out = 2, factors = "combinations")), 6) - testthat::expect_equal(nrow(psycho::refdata(iris, target = "Species", length.out = 2, factors = "combinations")), 3) - testthat::expect_equal(nrow(psycho::refdata(iris, target = "Species", length.out = 2, numerics = 0)), 3) -}) diff --git a/tests/testthat/test-remove_empty_cols.R b/tests/testthat/test-remove_empty_cols.R deleted file mode 100644 index 17fb0de..0000000 --- a/tests/testthat/test-remove_empty_cols.R +++ /dev/null @@ -1,11 +0,0 @@ -context("remove_empty_cols") - -test_that("Correct", { - df <- data.frame( - A = c(1, 2, 3), - B = c(1, 2, 3) - ) - df$C <- NA - - testthat::expect_equal(ncol(psycho::remove_empty_cols(df)), 2) -}) diff --git a/tests/testthat/test-rnorm_perfect.R b/tests/testthat/test-rnorm_perfect.R deleted file mode 100644 index 932d931..0000000 --- a/tests/testthat/test-rnorm_perfect.R +++ /dev/null @@ -1,9 +0,0 @@ -context("overlap") - -test_that("Correct", { - x <- psycho::rnorm_perfect(10, 0, 1) - testthat::expect_equal(mean(x), 0, tolerance = 0.02) - - x <- psycho::rnorm_perfect(10, 0, 1, method = "average") - testthat::expect_equal(mean(x), 0, tolerance = 0.05) -}) diff --git a/tests/testthat/test-standardize.R b/tests/testthat/test-standardize.R deleted file mode 100644 index 3050474..0000000 --- a/tests/testthat/test-standardize.R +++ /dev/null @@ -1,63 +0,0 @@ -context("standardize") - -test_that("Correct Value", { - library(psycho) - - set.seed(666) - df <- data.frame( - Participant = as.factor(rep(1:25, each = 4)), - Condition = base::rep_len(c("A", "B", "C", "D"), 100), - V1 = rnorm(100, 30, .2), - V2 = runif(100, 3, 5), - V3 = rnorm(100, 100, 10) - ) - - # Deactivate all this for CRAN - - # dfZ <- standardize(df) - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfZ <- standardize(df, except = "V3") - # testthat::expect_equal(mean(dfZ$V2), 0, tol = 0.01) - # - # dfZ <- standardize(df, except = c("V1", "V2")) - # testthat::expect_equal(mean(dfZ$V3), 0, tol = 0.01) - # - # dfZ <- standardize(df$V1) - # testthat::expect_equal(mean(dfZ), 0, tol = 0.01) - # - # dfZ <- standardize(df, subset = c("V1", "V2")) - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfZ <- standardize(df, subset = "V1", except = "V3") - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfZ <- standardize(dplyr::group_by(df, Participant)) - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfN <- standardize(df, except = "V3", normalize = TRUE) - # testthat::expect_equal(mean(dfN$V2), 0.533, tol = 0.5) - - - # Models - fit <- rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width, - data = iris, - seed = 666, - algorithm = "meanfield" - ) - - std <- standardize(fit, method = "posterior") - testthat::expect_equal(mean(std), -0.24, tol = 0.02) - - std <- standardize(fit, method = "sample") - testthat::expect_equal(mean(std), 1.34, tol = 0.02) - - fit <- lm( - Sepal.Length ~ Sepal.Width, - data = iris - ) - - std <- standardize(fit, method = "posthoc") - testthat::expect_equal(mean(std$Coef_std), -0.059, tol = 0.01) -}) diff --git a/tests/testthat/test-values.psychobject.R b/tests/testthat/test-values.psychobject.R deleted file mode 100644 index 32bb929..0000000 --- a/tests/testthat/test-values.psychobject.R +++ /dev/null @@ -1,8 +0,0 @@ -context("values.psychobject") - -test_that("It works", { - output <- list(values = 1) - class(output) <- c("psychobject", "list") - values <- values(output) - expect_equal(values, 1) -}) diff --git a/vignettes/bayesian.Rmd b/vignettes/bayesian.Rmd index 295d3c9..7ee9325 100644 --- a/vignettes/bayesian.Rmd +++ b/vignettes/bayesian.Rmd @@ -25,669 +25,20 @@ editor_options: ------ -```{r, echo=F, message=FALSE, warning=FALSE} -library(knitr) -library(rstanarm) -library(emmeans) -library(dplyr) -library(tidyr) -library(ggplot2) -library(psycho) -options(mc.cores=1) -``` - - -## The Bayesian Framework - -### Why use the Bayesian Framework? - -In short, because it's: - -- Better -- Simpler -- Superior -- Preferable -- More appropriate -- More desirable -- More useful -- More valuable - -##### **From Makowski et al. (*under review*):** - -> Reasons to prefer this approach are reliability, better accuracy in noisy data, better estimation for small samples, less prone to type I error, the possibility of introducing prior knowledge into the analysis and, critically, results intuitiveness and their straightforward interpretation (Andrews & Baguley, 2013; Etz & Vandekerckhove, 2016; Kruschke, 2010; Kruschke, Aguinis, & Joo, 2012; Wagenmakers et al., 2018). Indeed, in the frequentist view, the effects are fixed (but unknown) and data are random, while the Bayesian inference calculates the probability of different effect values (called the **"posterior" distribution**) given the observed data. Bayesian’s uncertainty can be summarized, for example, by giving a range of values on the posterior distribution that includes 95% of the probability (the 95% *Credible Interval*). To illustrate the difference, the Bayesian framework allows to say "*given the observed data, the effect has 95% probability of falling within this range*", while the Frequentist less straightforward alternative would be "*there is a 95% probability that when computing a confidence interval from data of this sort, the effect falls within this range*". In general, the frequentist approach has been associated with the focus on null hypothesis testing, and the misuse of *p* values has been shown to critically contribute to the reproducibility crisis of psychological science (Chambers, Feredoes, Muthukumaraswamy, Suresh, & Etchells, 2014; Szucs & Ioannidis, 2016). There is a general agreement that the generalization of the Bayesian approach is a way of overcoming these issues (Benjamin et al., 2018; Etz & Vandekerckhove, 2016). - -### What is the Bayesian Framework? - -Once we agreed that the Bayesian framework is the right way to go, you might wonder what is the Bayesian framework. **What's all the fuss about?** - -Omitting the maths behind it, let's just say that: - -- The frequentist guy tries to estimate "the real effect". The "real" value of the correlation between X and Y. It returns a "point-estimate" (*i.e.*, a single value) of the "real" correlation (*e.g.*, r = 0.42), considering that the data is sampled at random from a "parent", usually normal distribution of data. -- **The Bayesian master assumes no such thing**. The data are what they are. Based on this observed data (and eventually from its expectations), the Bayesian sampling algorithm will return a probability distribution of the effect that is compatible with the observed data. For the correlation between X and Y, it will return a distribution that says "the most probable effect is 0.42, but this data is also compatible with correlations of 0.12 or 0.74". -- To characterize our effects, **no need of p values** or other mysterious indices. We simply describe the posterior distribution (*i.e.*, the distribution of the effect). We can present the median (better than the mean, as it actually means that the effect has 50% of chance of being higher and 50% of chance of being lower), the MAD (a median-based, robust equivalent of SD) and other stuff such as the 90% HDI, called here *credible interval*. - - -### The "Posterior" distribution - -```{r message=FALSE, warning=FALSE, include=FALSE} -X <- psycho::standardize(psycho::affective$Concealing) -Y <- psycho::standardize(psycho::affective$Life_Satisfaction) -r <- cor.test(X, Y)$estimate -p <- cor.test(X, Y)$p.value -fit <- rstanarm::stan_glm(Y ~ X, seed=666, data=data.frame(Y,X)) -values <- values(analyze(fit)) -posterior <- values$effects$X$posterior -density <- density(posterior, n = length(posterior)) -hdi <- HDI(posterior, 0.90) -mpe <- mpe(posterior)$MPE -``` - -Let's imagine two numeric variables, Y and X. The correlation between them is r = `r psycho::format_digit(r)` (p < .05). A Bayesian analysis would return the probability of distribution of this effect (the **posterior**), that we can characterize using several indices (centrality (**median** or mean), dispersion (SD or Median Absolute Deviation - **MAD**), etc.). Let's plot the posterior distribution of the possible correlation values that are compatible with our data. - -```{r echo=FALSE, message=FALSE, warning=FALSE, fig.width=7, fig.height=4.5, fig.align='center', fig.cap="Posterior probability distribution of the correlation between X and Y"} -ggplot(data.frame(x = density$x, y = density$y), aes(x=x, y=y)) + - xlab("\nPosterior Distribution of Correlation") + - ylab("Density") + - annotate("rect", xmin = hdi$values$HDImin, xmax=hdi$values$HDImax, ymin = 0, ymax=round(max(density$y)), fill="#2196F3", alpha = .5) + - geom_segment(aes(xend = x, yend = 0, colour = x), alpha=0.8) + - scale_color_gradientn(colours = c("#E91E63", "#E91E63", "#4CAF50", "#4CAF50"), - values=c(0, 0.4999, 0.5, 1), - guide=F, - limits = c(-1.5, 1.5)) + - # r - geom_vline(xintercept=r, color="#4CAF50") + - annotate("segment", x = r+0.05, xend = r, y = 10, yend = 10, size=0.1, arrow=arrow(type="closed", length = unit(0.10, "inches")), color="#4CAF50") + - annotate("text", x = r+0.055, y = 10, label = "Frequentist r Coefficient" , size=4 , fontface="bold", hjust = 0, color="#4CAF50") + - # median - geom_vline(xintercept=median(posterior)) + - annotate("segment", x = median(posterior)+0.05, xend = median(posterior), y = 8, yend = 8, colour = "black", size=0.1, arrow=arrow(type="closed", length = unit(0.10, "inches"))) + - annotate("text", x = median(posterior)+0.055, y = 8, label = "Posterior's Median" , size=4 , fontface="bold", hjust = 0) + - # # mean - # geom_vline(xintercept=mean(posterior), color="#2196F3") + - # annotate("segment", x = mean(posterior)+0.03, xend = r, y = 6, yend = 6, size=0.1, arrow=arrow(type="closed", length = unit(0.10, "inches")), color="#2196F3") + - # annotate("text", x = mean(posterior)+0.035, y = 6, label = "mean" , size=4 , fontface="bold", hjust = 0, color="#2196F3") - annotate("segment", x = hdi$values$HDImin, xend = hdi$values$HDImax, y = 3, yend = 3, size=0.3, arrow=arrow(type="closed", ends="both", length = unit(0.10, "inches")), color="#2196F3") + - annotate("text", x = -0.01, y = 3, label = "90% Credible Interval" , size=4 , fontface="bold", hjust = 0, color="#2196F3") -``` - -In this example (based on real data): - -- The **median of the posterior distribution is really close to the *r* coefficient obtained through a "normal" correlation analysis**, appearing as a good point-estimate of the correlation. Moreover, and unlike the frequentist estimate, the median has an intuitive meaning (as it cuts the distribution in two equal parts): the "true" effect has 50% of chance of being higher and 50% of chance of being lower. -- We can also compute the **90% *credible* interval**, which shows where the true effect can fall with a probability of 90% (better than 95% CI, see *Kruschke, 2015*). -- Finally, we can also compute the **MPE**, *i.e.*, the maximum probability of effect, which is the probability that the effect is in the median's direction (*i.e.*, negative in this example): the area in red. It interesting to note that the probability that the effect is opposite ((100 - MPE) / 100, here (100-`r mpe`) / 100 = `r format_digit((100-mpe)/100)`) is relatively close to the actual **p value** obtained through frequentist correlation (p = `r format_digit(p)`). - -**Now that you're familiar with posterior distributions, the core difference of the Bayesian framework, let's practice!** - -## The affective Dataset - -Let's start by taking a look at the dataset included within the `psycho` package. - -```{r, echo=T, message=FALSE, warning=FALSE, results='hide'} -library(rstanarm) -library(dplyr) -library(ggplot2) -library(psycho) - -df <- psycho::affective -summary(df) -``` - -```{r echo=FALSE, message=FALSE, warning=FALSE} -summary(df) -``` - -The data include **5 continuous variables** (age, life satisfaction and 3 affective styles) and **3 factors** (sex, salary and season of birth). - - - -## Simple Regression (*Correlation*) - -Let's start with something simple : a **correlation**. To simplify, a (Pearson's) correlation is pretty much nothing more than a simple linear regression (with standardized variables). Let's see if there's a linear relationship between **Life Satisfaction** and the tendency of **Tolerating** our emotions using a Bayesian linear regression model. - -### Model Exploration - -```{r, message=FALSE, results="hide"} -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, data=df) -``` - - - - -Let's check the results: -```{r, message=FALSE, results="hide"} -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -knitr::kable(summary(results, round = 2)) -``` - -For each parameter of the model, the summary shows: - -- the **median** of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models). -- the **Median Absolute Deviation (MAD)**, a robust measure of dispertion (could be seen as a robust version of SD). -- the **Credible Interval (CI)** (by default, the 90\% CI; see Kruschke, 2018), representing a range of possible parameter values. -- the **Maximum Probability of Effect (MPE)**, the probability that the effect is positive or negative (depending on the median’s direction). -- the **Overlap (O)**, the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution of same uncertainty (width). - -It also returns the (unadjusted) R2 (which represents the *percentage of variance of the outcome explained by the model*). In the Bayesian framework, the R2 is also estimated with probabilities. As such, characteristics of its posterior distribution are returned. - - - -We can also print a formatted version: -```{r echo=TRUE, message=FALSE, warning=FALSE} -print(results) -``` - -Note that the `print()` returns also additional info, such as the 100\% CI of the R2 and, for each parameter, the limits of the range defined by the MPE. - - - -### Interpretation - - -For now, omit the part dedicated to priors. We'll see it in the next chapters. Let's rather interpret the part related to effects. - -> Full Bayesian mixed linear models are fitted using the rstanarm R wrapper for the stan probabilistic language (Gabry & Goodrich, 2016). Bayesian inference was done using Markov Chain Monte Carlo (MCMC) sampling. The prior distributions of all effects were set as weakly informative (mean = 0, SD = `r psycho::format_digit(results$values$effects$Tolerating$prior_adjusted_scale)`), meaning that we did not expect effects different from null in any particular direction. For each model and each coefficient, we will present several characteristics of the posterior distribution, such as its median (a robust estimate comparable to the beta from frequentist linear models), MAD (median absolute deviation, a robust equivalent of standard deviation) and the 90% credible interval. Instead of the *p value* as an index of effect existence, we also computed the maximum probability of effect (MPE), *i.e.*, the maximum probability that the effect is different from 0 in the median’s direction. For our analyses, we will consider an effect as inconsistent (*i.e.*, not probable enough) if its MPE is lower than 90% (however, **beware not to fall in a *p* value-like obsession**). - - -The current model explains about `r psycho::format_digit(results$values$effects$R2$median*100)`% of life satisfaction variance. Within this model, a positive linear relationship between life satisfaction and tolerating exists with high probability (Median = `r psycho::format_digit(results$values$effects$Tolerating$median)`, MAD = `r psycho::format_digit(results$values$effects$Tolerating$mad)`, 90% CI [`r paste(psycho::format_digit(results$values$effects$Tolerating$CI_values), collapse = ', ')`], MPE = `r psycho::format_digit(results$values$effects$Tolerating$MPE)`%). - -### Model Visualization - -To visualize the model, the most neat way is to extract a "reference grid" (*i.e.*, a theorethical dataframe with balanced data). - -```{r echo=T, message=FALSE, warning=FALSE} -refgrid <- df %>% - select(Tolerating) %>% - psycho::refdata(length.out=10) - -predicted <- psycho::get_predicted(fit, newdata=refgrid) -``` -```{r echo=T, message=FALSE, warning=FALSE, results='hide'} -predicted -``` - - -```{r echo=FALSE, message=FALSE, warning=FALSE} -kable(predicted) -``` - -Our refgrid is made of equally spaced (balanced) predictor values. It also include the median of the posterior prediction, as well as 90% credible intervals. Now, we can plot it as follows: - -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA} -ggplot(predicted, aes(x=Tolerating, y=Life_Satisfaction_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Life_Satisfaction_CI_5, - ymax=Life_Satisfaction_CI_95), - alpha=0.1) -``` - - -## Regression with Categorical Predictor (*ANOVA*) - -When the predictor is categorical, simplifying the model is called running an ANOVA. Let's do it by answering the following question: does the level of **life satisfaction** depend on the salary? - -### Model Exploration - -```{r, message=FALSE, results="hide"} -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data=df) -``` -Let's check the results: -```{r, message=FALSE, warning=FALSE} -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -print(results) -``` - -### Post-hoc / Contrasts / Comparisons - -What interest us is the pairwise comparison between the groups. The `get_contrasts` function computes the estimated marginal means (least-squares means), *i.e.*, the means of each group estimated by the model, as well as the contrasts. - - -We can see the estimated means (in fact, the median of the posterior distribution of the estimated means) like that: -```{r echo=T, message=FALSE, warning=FALSE, results='hide'} -psycho::get_means(fit) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -kable(psycho::get_means(fit), digits=2) -``` - - -And the contrasts comparisons like that: -```{r echo=T, message=FALSE, warning=FALSE, results='hide'} -psycho::get_contrasts(fit) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -kable(psycho::get_contrasts(fit), digits=2) -``` - -As we can see, the only probable difference (MPE > 90%) is between **Salary <1000** and **Salary 2000+**. - -### Model Visualization - -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA} -psycho::get_means(fit) %>% - ggplot(aes(x=Level, y=Median, group=1)) + - geom_line() + - geom_pointrange(aes(ymin=CI_lower, ymax=CI_higher)) + - ylab("Life Satisfaction") + - xlab("Salary") -``` - - -## Logistic Regressions - -Let's see if we can **predict the sex** with the tendency to flexibly *adjust* our emotional reactions. As the Sex is a binary factor (with two modalities), we have to fit a logistic model. - -### Model Exploration - -```{r, message=FALSE, results="hide"} -# Let's fit our model -fit <- rstanarm::stan_glm(Sex ~ Adjusting, data=df, family = "binomial") -``` - - - -First, let's check our model: -```{r, message=FALSE, results="hide"} -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -knitr::kable(summary(results, round = 2)) -``` - -It appears that the link between adjusting and the sex is highly probable (MPE > 90%). But in what direction? To know that, we have to find out what is the intercept (the reference level). - - -```{r echo=FALSE, message=FALSE, warning=FALSE} -levels(df$Sex) -``` -As **female** is the first level, it means that it is the intercept. Based on our model, an increase of 1 on the scale of **adjusting** will increase the probability (expressed in log odds ratios) of being a **male**. - -### Model Visualization - -To visualize this type of model, we have to derive a reference grid. - -```{r echo=T, message=FALSE, warning=FALSE} -refgrid <- df %>% - select(Adjusting) %>% - psycho::refdata(length.out=10) - -predicted <- psycho::get_predicted(fit, newdata=refgrid) -``` - -Note that `get_predicted` automatically transformed log odds ratios (the values in which the model is expressed) to probabilities, easier to apprehend. - -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA} -ggplot(predicted, aes(x=Adjusting, y=Sex_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Sex_CI_5, - ymax=Sex_CI_95), - alpha=0.1) + - ylab("Probability of being a male") -``` - -We can nicely see the non-linear relationship between adjusting and the probability of being a male. - -## Multiple Regressions and MANOVAs / ANCOVAs - -Let's create models a bit more complex, mixing factors with numeric predictors, to see if the **life satisfaction** is related to the tendency to suppress, **conceal** the emotional reactions, and does this relationship depends on the **sex**. - -### Model Exploration - -```{r, message=FALSE, results="hide"} -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Concealing * Sex, data=df) -``` - - - -Let's check our model: -```{r, message=FALSE, results="hide"} -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -kable(summary(results, round = 2)) -``` - -Again, it is important to notice that the intercept (the baseline) corresponds here to **Concealing = 0** and **Sex = F**. As we can see next, there is, with high probability, a negative linear relationship between concealing (*for females only*) and life satisfaction. Also, at the (theorethical) intercept (when concealing = 0), the males have a lower life satisfaction. Finally, the interaction is also probable. This means that when the participant is a male, the relationship between concealing and life satisfaction is significantly different (increased by 0.17. In other words, we could say that the relationship is of -0.10+0.17=0.07 in men). - -### Model Visualization - -How to represent this type of models? Again, we have to generate a reference grid. - -```{r echo=T, message=FALSE, warning=FALSE, results="hide"} -refgrid <- df %>% - select(Concealing, Sex) %>% - psycho::refdata(length.out=10) - -predicted <- psycho::get_predicted(fit, newdata=refgrid) -predicted -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -kable(predicted) -``` - -As we can see, the reference grid is balanced in terms of factors and numeric predictors. Now, to plot this becomes very easy! - - -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA} -ggplot(predicted, aes(x=Concealing, y=Life_Satisfaction_Median, fill=Sex)) + - geom_line(aes(colour=Sex)) + - geom_ribbon(aes(fill=Sex, - ymin=Life_Satisfaction_CI_5, - ymax=Life_Satisfaction_CI_95), - alpha=0.1) + - ylab("Life Satisfaction") -``` - -We can see that the error for the males is larger, due to less observations. - - - -## Mixed Models - - -### Why use mixed-models? - -- **From Makowski et al. (*under review*):** - -> The Mixed modelling framework allows estimated effects to vary by group at lower levels while estimating population-level effects through the specification of fixed (explanatory variables) and random (variance components) effects. Outperforming traditional procedures such as repeated measures ANOVA (Kristensen & Hansen, 2004), these models are particularly suited to cases in which experimental stimuli are heterogeneous (e.g., images) as the item-related variance, in addition to the variance induced by participants, can be accounted for (Baayen, Davidson, & Bates, 2008; Magezi, 2015). Moreover, mixed models can handle unbalanced data, nested designs, crossed random effects and missing data. - -As for how to run this type of analyses, it is quite easy. Indeed, all what has been said previously remains the same for mixed models. Except that there are random effects (specified by putting `+ (1|random_term)` in the formula). For example, we might want to consider the **salary** as a random effect (to "**adjust**" (*so to speak*) for the fact that the data is structured in two groups). Let's explore the relationship between the tendency to **conceal** emotions and **age** (*adjusted* for **salary**). - -### Model Exploration - -```{r eval=FALSE, message=FALSE, warning=FALSE, eval=FALSE} -# Let's fit our model (it takes more time) -fit <- rstanarm::stan_lmer(Concealing ~ Age + (1|Salary), data=df) -``` -```{r message=FALSE, warning=FALSE, include=FALSE, results="hide"} -# Let's fit our model (it takes more time) -fit <- rstanarm::stan_lmer(Concealing ~ Age + (1|Salary), data=df, iter=500, chains=2, seed=666) -``` - -Let's check our model: -```{r, message=FALSE, results="hide"} -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -kable(summary(results, round = 2)) -``` - -As we can see, the linear relationship has only a moderate probability of being different from 0. - -### Model Visualization - - -```{r echo=T, message=FALSE, warning=FALSE} -refgrid <- df %>% - select(Age) %>% - psycho::refdata(length.out=10) - -# We name the predicted dataframe by adding '_linear' to keep it for further comparison (see next part) -predicted_linear <- psycho::get_predicted(fit, newdata=refgrid) -``` -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA} -ggplot(predicted_linear, aes(x=Age, y=Concealing_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - alpha=0.1) -``` - -## Polynomial Transformations - -Relationships in the real world are often non-linear. For example, based on the previous relationship between **concealing** and **age**, we could try modelling a polynomial (second order) transformation to the predictor. - -### Model Exploration - -```{r message=FALSE, warning=FALSE, include=FALSE, results="hide"} -# Let's fit our model (it takes more time) -fit <- rstanarm::stan_lmer(Concealing ~ poly(Age, 2, raw=TRUE) + (1|Salary), data=df, iter=500, chains=2) -``` - -Let's check our model: -```{r, message=FALSE, results="hide"} -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) -``` -```{r echo=FALSE, message=FALSE, warning=FALSE} -knitr::kable(summary(results, round = 2)) -``` - -As we can see, both the linear relationship and the second order curvature are highly probable. However, when setting `raw=TRUE` in the formula, the coefficients become unintepretable. So let's visualize them. - -### Model Visualization - -The model visualization routine is similar to the previous ones. - -```{r echo=T, message=FALSE, warning=FALSE} -refgrid <- df %>% - select(Age) %>% - psycho::refdata(length.out=20) - -predicted_poly <- psycho::get_predicted(fit, newdata=refgrid) -``` -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA} -ggplot(predicted_poly, aes(x=Age, y=Concealing_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - alpha=0.1) -``` - -As we can see, adding the polynomial degree changes the relationship. Since the model is here very simple, we can add on the plot the actual points (however, they do not take into account the random effects and such), as well as plot the two models. Also, let's make it "dynamic" using `plotly`. - -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA, message=FALSE, warning=FALSE} -p <- ggplot() + - # Linear model - geom_line(data=predicted_linear, - aes(x=Age, y=Concealing_Median), - colour="blue", - size=1) + - geom_ribbon(data=predicted_linear, - aes(x=Age, - ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - alpha=0.1, - fill="blue") + - # Polynormial Model - geom_line(data=predicted_poly, - aes(x=Age, y=Concealing_Median), - colour="red", - size=1) + - geom_ribbon(data=predicted_poly, - aes(x=Age, - ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - fill="red", - alpha=0.1) + - # Actual data - geom_point(data=df, aes(x=Age, y=Concealing)) - -library(plotly) # To create interactive plots -ggplotly(p) # To transform a ggplot into an interactive plot -``` - - -**It's good to take a few steps back and look at the bigger picture :)** - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + - - - - - - - - -## Piors Specification - -One of the interesting aspect of the Bayesian framework is the possibility of adding prior expectations about the effect, to help model fitting and increase accuracy in noisy data or small samples. - - -### Weakly informative priors - -As you might have notice, we didn't specify any priors in the previous analyses. In fact, we let the algorithm define and set *weakly informative priors*, designed to provide moderate regularization and help stabilize computation, without biasing the effect direction. For example, a wealky informative prior, for a standardized predictor (with mean = 0 and SD = 1) could be a normal distribution with mean = 0 and SD = 1. This means that the effect of this predictor is expected to be equally probable in any direction (as the distribution is symmetric around 0), with probability being higher close to 0 and lower far from 0. - -While this prior doesn't bias the direction of the Bayesian (MCMC) sampling, it suggests that having an effect of 100 (*i.e.*, located at 100 SD of the mean as our variables are standardized) is highly unprobable, and that an effect close to 0 is more probable. - -To better play with priors, let's start by standardizing our dataframe. - - -```{r, message=FALSE, results="hide"} -# Standardize (scale and center) the numeric variables -dfZ <- psycho::standardize(df) -``` - -Then, we can explicitly specify a weakly informative prior for all effects of the model. - -```{r, message=FALSE, results="hide"} -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, - data=dfZ, - prior=normal(location = 0, # Mean - scale = 1, # SD - autoscale=FALSE)) # Don't adjust scale automatically -``` - -Let's plot the prior (the expectation) against the posterior (the estimated effect) distribution. - -```{r, message=FALSE, results="hide"} -results <- psycho::analyze(fit) - -# Extract the posterior -posterior <- results$values$effects$Tolerating$posterior - -# Create a posterior with the prior and posterior distribution and plot them. -data.frame(posterior = posterior, - prior = rnorm(length(posterior), 0, 1)) %>% - ggplot() + - geom_density(aes(x=posterior), fill="lightblue", alpha=0.5) + - geom_density(aes(x=prior), fill="blue", alpha=0.5) + - scale_y_sqrt() # Change the Y axis so the plot is less ugly -``` - - -This plot is rather ugly, because our posterior is very precise (due to the large sample) compared to the prior. - -### Informative priors - -Although the default priors tend to work well, prudent use of more informative priors is encouraged. It is important to underline that setting informative priors (**if realistic**), does not overbias the analysis. In other words, is only "directs" the sampling: if the data are highly informative about the parameter values (enough to overwhelm the prior), a prudent informative prior (even if oppositive to the observed effect) will yield similar results to a non-informative prior. **In other words, you can't change the results dramatically by tweaking the priors**. But as the amount of data and/or the signal-to-noise ratio decrease, using a more informative prior becomes increasingly important. Of course, if you see someone using a prior with mean = 42 and SD = 0.0001, you should look at his results with caution... - -Anyway, see the [official rstanarm documentation](https://CRAN.R-project.org/package=rstanarm/vignettes/priors.html) for details. - - - - - - - - -## Advanced Visualization - -### Plot all iterations - -As Bayesian models usually generate a lot of samples (*iterations*), one could want to plot them as well, instead (or along) the posterior "summary". This can be done quite easily by extracting all the iterations in `get_predicted`. - -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='hide', fig.align='center', comment=NA, message=FALSE, warning=FALSE} -# Fit the model -fit <- rstanarm::stan_glm(Sex ~ Adjusting, data=df, family = "binomial") -``` -```{r, fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA, message=FALSE, warning=FALSE} -# Generate a new refgrid -refgrid <- df %>% - select(Adjusting) %>% - psycho::refdata(length.out=10) - -# Get predictions and keep iterations -predicted <- psycho::get_predicted(fit, newdata=refgrid, keep_iterations=TRUE) - -# Reshape this dataframe to have iterations as factor -predicted <- predicted %>% - tidyr::gather(Iteration, Iteration_Value, starts_with("iter")) - -# Plot iterations as well as the median prediction -ggplot(predicted, aes(x=Adjusting)) + - geom_line(aes(y=Iteration_Value, group=Iteration), size=0.3, alpha=0.01) + - geom_line(aes(y=Sex_Median), size=1) + - ylab("Male Probability\n") -``` - - - - -## Credits -This package helped you? Don't forget to cite the various packages you used :) -You can cite `psycho` as follows: -- Makowski, (2018). *The psycho Package: An Efficient and Publishing-Oriented Workflow for Psychological Science*. Journal of Open Source Software, 3(22), 470. https://doi.org/10.21105/joss.00470 -## Contribution +# The Bayesian Framework -Improve this vignette by modifying [this](https://github.com/neuropsychology/psycho.R/blob/master/vignettes/bayesian.Rmd) file! +The vignette was updated and is available [here](https://easystats.github.io/bayestestR/articles/bayestestR.html). diff --git a/vignettes/bayesian.html b/vignettes/bayesian.html index d8b1e20..fb31cbb 100644 --- a/vignettes/bayesian.html +++ b/vignettes/bayesian.html @@ -12,80 +12,12 @@ - + Bayesian Analysis in Psychology - - - - - - - - - - - - + @@ -110,1063 +224,33 @@

Bayesian Analysis in Psychology

Dominique Makowski

-

2019-01-04

+

2019-03-29

Abstract

-

Why use frequentist methods when you can use, in an even simpler way, the Bayesian framework? Throughout this tutorial, we will explore many of the analyses you might want to do with your data.

+Why use frequentist methods when you can use, in an even simpler way, the Bayesian framework? Throughout this tutorial, we will explore many of the analyses you might want to do with your data.
-
-

The Bayesian Framework

-
-

Why use the Bayesian Framework?

-

In short, because it’s:

-
    -
  • Better
    • -
  • Simpler
    • -
  • Superior
    • -
  • Preferable
    • -
  • More appropriate
    • -
  • More desirable
    • -
  • More useful
    • -
  • More valuable
    • -
-
-
From Makowski et al. (under review):
-
-

Reasons to prefer this approach are reliability, better accuracy in noisy data, better estimation for small samples, less prone to type I error, the possibility of introducing prior knowledge into the analysis and, critically, results intuitiveness and their straightforward interpretation (Andrews & Baguley, 2013; Etz & Vandekerckhove, 2016; Kruschke, 2010; Kruschke, Aguinis, & Joo, 2012; Wagenmakers et al., 2018). Indeed, in the frequentist view, the effects are fixed (but unknown) and data are random, while the Bayesian inference calculates the probability of different effect values (called the “posterior” distribution) given the observed data. Bayesian’s uncertainty can be summarized, for example, by giving a range of values on the posterior distribution that includes 95% of the probability (the 95% Credible Interval). To illustrate the difference, the Bayesian framework allows to say “given the observed data, the effect has 95% probability of falling within this range”, while the Frequentist less straightforward alternative would be “there is a 95% probability that when computing a confidence interval from data of this sort, the effect falls within this range”. In general, the frequentist approach has been associated with the focus on null hypothesis testing, and the misuse of p values has been shown to critically contribute to the reproducibility crisis of psychological science (Chambers, Feredoes, Muthukumaraswamy, Suresh, & Etchells, 2014; Szucs & Ioannidis, 2016). There is a general agreement that the generalization of the Bayesian approach is a way of overcoming these issues (Benjamin et al., 2018; Etz & Vandekerckhove, 2016).

-
-
-
-
-

What is the Bayesian Framework?

-

Once we agreed that the Bayesian framework is the right way to go, you might wonder what is the Bayesian framework. What’s all the fuss about?

-

Omitting the maths behind it, let’s just say that:

-
    -
  • The frequentist guy tries to estimate “the real effect”. The “real” value of the correlation between X and Y. It returns a “point-estimate” (i.e., a single value) of the “real” correlation (e.g., r = 0.42), considering that the data is sampled at random from a “parent”, usually normal distribution of data.
    • -
  • The Bayesian master assumes no such thing. The data are what they are. Based on this observed data (and eventually from its expectations), the Bayesian sampling algorithm will return a probability distribution of the effect that is compatible with the observed data. For the correlation between X and Y, it will return a distribution that says “the most probable effect is 0.42, but this data is also compatible with correlations of 0.12 or 0.74”.
    • -
  • To characterize our effects, no need of p values or other mysterious indices. We simply describe the posterior distribution (i.e., the distribution of the effect). We can present the median (better than the mean, as it actually means that the effect has 50% of chance of being higher and 50% of chance of being lower), the MAD (a median-based, robust equivalent of SD) and other stuff such as the 90% HDI, called here credible interval.
    • -
-
-
-

The “Posterior” distribution

-

Let’s imagine two numeric variables, Y and X. The correlation between them is r = -0.063 (p < .05). A Bayesian analysis would return the probability of distribution of this effect (the posterior), that we can characterize using several indices (centrality (median or mean), dispersion (SD or Median Absolute Deviation - MAD), etc.). Let’s plot the posterior distribution of the possible correlation values that are compatible with our data.

-
-Posterior probability distribution of the correlation between X and Y -

-Posterior probability distribution of the correlation between X and Y -

-
-

In this example (based on real data):

-
    -
  • The median of the posterior distribution is really close to the r coefficient obtained through a “normal” correlation analysis, appearing as a good point-estimate of the correlation. Moreover, and unlike the frequentist estimate, the median has an intuitive meaning (as it cuts the distribution in two equal parts): the “true” effect has 50% of chance of being higher and 50% of chance of being lower.
    • -
  • We can also compute the 90% credible interval, which shows where the true effect can fall with a probability of 90% (better than 95% CI, see Kruschke, 2015).
    • -
  • Finally, we can also compute the MPE, i.e., the maximum probability of effect, which is the probability that the effect is in the median’s direction (i.e., negative in this example): the area in red. It interesting to note that the probability that the effect is opposite ((100 - MPE) / 100, here (100-98.85) / 100 = 0.012) is relatively close to the actual p value obtained through frequentist correlation (p = 0.025).
    • -
-

Now that you’re familiar with posterior distributions, the core difference of the Bayesian framework, let’s practice!

-
-
-
-

The affective Dataset

-

Let’s start by taking a look at the dataset included within the psycho package.

-
library(rstanarm)
-library(dplyr)
-library(ggplot2)
-library(psycho)
-
-df <- psycho::affective
-summary(df)
-
##  Sex           Age        Birth_Season   Salary    Life_Satisfaction
-##  F:1000   Min.   :18.00   Fall  :288   <1000:514   Min.   :1.000    
-##  M: 251   1st Qu.:21.16   Spring:348   <2000:223   1st Qu.:4.000    
-##           Median :22.97   Summer:332   2000+:128   Median :5.000    
-##           Mean   :26.91   Winter:283   NA's :386   Mean   :4.847    
-##           3rd Qu.:27.54                            3rd Qu.:6.000    
-##           Max.   :80.14                            Max.   :7.000    
-##    Concealing      Adjusting       Tolerating   
-##  Min.   :0.000   Min.   :0.000   Min.   :0.500  
-##  1st Qu.:2.750   1st Qu.:2.750   1st Qu.:3.500  
-##  Median :3.750   Median :3.750   Median :4.250  
-##  Mean   :3.743   Mean   :3.802   Mean   :4.157  
-##  3rd Qu.:4.750   3rd Qu.:5.000   3rd Qu.:5.000  
-##  Max.   :7.000   Max.   :6.750   Max.   :7.000
-

The data include 5 continuous variables (age, life satisfaction and 3 affective styles) and 3 factors (sex, salary and season of birth).

-
-
-

Simple Regression (Correlation)

-

Let’s start with something simple : a correlation. To simplify, a (Pearson’s) correlation is pretty much nothing more than a simple linear regression (with standardized variables). Let’s see if there’s a linear relationship between Life Satisfaction and the tendency of Tolerating our emotions using a Bayesian linear regression model.

-
-

Model Exploration

-
# Let's fit our model
-fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, data=df)
-

Let’s check the results:

-
# Format the results using analyze()
-results <- psycho::analyze(fit)
-
-# We can extract a formatted summary table
-summary(results, round = 2)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
VariableMedianMADCI_lowerCI_higherMPEOverlap
R20.020.010.010.04NANA
(Intercept)4.060.153.814.29NANA
Tolerating0.190.030.130.241000.56
-

For each parameter of the model, the summary shows:

-
    -
  • the median of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models).
    • -
  • the Median Absolute Deviation (MAD), a robust measure of dispertion (could be seen as a robust version of SD).
    • -
  • the Credible Interval (CI) (by default, the 90% CI; see Kruschke, 2018), representing a range of possible parameter values.
    • -
  • the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).
    • -
  • the Overlap (O), the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution of same uncertainty (width).
    • -
-

It also returns the (unadjusted) R2 (which represents the percentage of variance of the outcome explained by the model). In the Bayesian framework, the R2 is also estimated with probabilities. As such, characteristics of its posterior distribution are returned.

-

We can also print a formatted version:

-
print(results)
-
## We fitted a Markov Chain Monte Carlo gaussian (link = identity) model (4 chains, each with iter = 2000; warmup = 1000; thin = 1; post-warmup = 1000) to predict Life_Satisfaction (formula = Life_Satisfaction ~ Tolerating). The model's priors were set as follows: 
-## 
-##   ~ normal (location = (0), scale = (3.11))
-## 
-## 
-## The model has an explanatory power (R2) of about 2.33% (MAD = 0.0081, 90% CI [0.011, 0.037], adj. R2 = 0.020). The intercept is at 4.06 (MAD = 0.15, 90% CI [3.81, 4.29]). Within this model:
-## 
-##   - The effect of Tolerating has a probability of 100% of being positive (Median = 0.19, MAD = 0.034, 90% CI [0.13, 0.24], Overlap = 0.56%).
-

Note that the print() returns also additional info, such as the 100% CI of the R2 and, for each parameter, the limits of the range defined by the MPE.

-
-
-

Interpretation

-

For now, omit the part dedicated to priors. We’ll see it in the next chapters. Let’s rather interpret the part related to effects.

-
-

Full Bayesian mixed linear models are fitted using the rstanarm R wrapper for the stan probabilistic language (Gabry & Goodrich, 2016). Bayesian inference was done using Markov Chain Monte Carlo (MCMC) sampling. The prior distributions of all effects were set as weakly informative (mean = 0, SD = 3.11), meaning that we did not expect effects different from null in any particular direction. For each model and each coefficient, we will present several characteristics of the posterior distribution, such as its median (a robust estimate comparable to the beta from frequentist linear models), MAD (median absolute deviation, a robust equivalent of standard deviation) and the 90% credible interval. Instead of the p value as an index of effect existence, we also computed the maximum probability of effect (MPE), i.e., the maximum probability that the effect is different from 0 in the median’s direction. For our analyses, we will consider an effect as inconsistent (i.e., not probable enough) if its MPE is lower than 90% (however, beware not to fall in a p value-like obsession).

-
-

The current model explains about 2.33% of life satisfaction variance. Within this model, a positive linear relationship between life satisfaction and tolerating exists with high probability (Median = 0.19, MAD = 0.034, 90% CI [0.13, 0.24], MPE = 100%).

-
-
-

Model Visualization

-

To visualize the model, the most neat way is to extract a “reference grid” (i.e., a theorethical dataframe with balanced data).

-
refgrid <- df %>% 
-  select(Tolerating) %>% 
-  psycho::refdata(length.out=10)
-
-predicted <- psycho::get_predicted(fit, newdata=refgrid)
-
predicted
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ToleratingLife_Satisfaction_MedianLife_Satisfaction_CI_5Life_Satisfaction_CI_95
0.5000004.1505373.9402774.363126
1.2222224.2885864.1250504.472999
1.9444444.4256924.2979484.573175
2.6666674.5636254.4684214.679439
3.3888894.7011184.6225574.779236
4.1111114.8384044.7747364.906067
4.8333334.9747824.8961125.048871
5.5555565.1110335.0110435.218134
6.2777785.2491755.1126855.389029
7.0000005.3862005.2083925.558411
-

Our refgrid is made of equally spaced (balanced) predictor values. It also include the median of the posterior prediction, as well as 90% credible intervals. Now, we can plot it as follows:

-
ggplot(predicted, aes(x=Tolerating, y=Life_Satisfaction_Median)) +
-  geom_line() +
-  geom_ribbon(aes(ymin=Life_Satisfaction_CI_5, 
-                  ymax=Life_Satisfaction_CI_95), 
-              alpha=0.1)
-

-
-
-
-

Regression with Categorical Predictor (ANOVA)

-

When the predictor is categorical, simplifying the model is called running an ANOVA. Let’s do it by answering the following question: does the level of life satisfaction depend on the salary?

-
-

Model Exploration

-
# Let's fit our model
-fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data=df)
-

Let’s check the results:

-
# Format the results using analyze()
-results <- psycho::analyze(fit)
-
-# We can extract a formatted summary table
-print(results)
-
## We fitted a Markov Chain Monte Carlo gaussian (link = identity) model (4 chains, each with iter = 2000; warmup = 1000; thin = 1; post-warmup = 1000) to predict Life_Satisfaction (formula = Life_Satisfaction ~ Salary). The model's priors were set as follows: 
-## 
-##   ~ normal (location = (0, 0), scale = (3.61, 3.61))
-## 
-## 
-## The model has an explanatory power (R2) of about 0.43% (MAD = 0.0038, 90% CI [0, 0.011]). The intercept is at 4.76 (MAD = 0.065, 90% CI [4.66, 4.87]). Within this model:
-## 
-##   - The effect of Salary<2000 has a probability of 87.20% of being positive (Median = 0.13, MAD = 0.11, 90% CI [-0.064, 0.31], Overlap = 57.86%).
-##   - The effect of Salary2000+ has a probability of 92.97% of being positive (Median = 0.20, MAD = 0.14, 90% CI [-0.024, 0.45], Overlap = 47.21%).
-
-
-

Post-hoc / Contrasts / Comparisons

-

What interest us is the pairwise comparison between the groups. The get_contrasts function computes the estimated marginal means (least-squares means), i.e., the means of each group estimated by the model, as well as the contrasts.

-

We can see the estimated means (in fact, the median of the posterior distribution of the estimated means) like that:

-
psycho::get_means(fit)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
LevelMedianMADCI_lowerCI_higher
Salary <10004.760.064.664.87
Salary <20004.890.094.735.04
Salary 2000+4.970.124.775.18
-

And the contrasts comparisons like that:

-
psycho::get_contrasts(fit)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ContrastMedianMADCI_lowerCI_higherMPE
<1000 - <2000-0.130.11-0.310.0687.20
<1000 - 2000+-0.200.14-0.450.0292.97
<2000 - 2000+-0.080.16-0.330.1969.47
-

As we can see, the only probable difference (MPE > 90%) is between Salary <1000 and Salary 2000+.

-
-
-

Model Visualization

-
psycho::get_means(fit) %>% 
-  ggplot(aes(x=Level, y=Median, group=1)) +
-  geom_line() +
-  geom_pointrange(aes(ymin=CI_lower, ymax=CI_higher)) +
-  ylab("Life Satisfaction") +
-  xlab("Salary")
-

-
-
-
-

Logistic Regressions

-

Let’s see if we can predict the sex with the tendency to flexibly adjust our emotional reactions. As the Sex is a binary factor (with two modalities), we have to fit a logistic model.

-
-

Model Exploration

-
# Let's fit our model
-fit <- rstanarm::stan_glm(Sex ~ Adjusting, data=df, family = "binomial")
-

First, let’s check our model:

-
# Format the results using analyze()
-results <- psycho::analyze(fit)
-
-# We can extract a formatted summary table
-summary(results, round = 2)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
VariableMedianMADCI_lowerCI_higherMPEOverlap
R20.010.010.000.02NANA
(Intercept)-2.190.22-2.57-1.86NANA
Adjusting0.210.050.130.291004.55
-

It appears that the link between adjusting and the sex is highly probable (MPE > 90%). But in what direction? To know that, we have to find out what is the intercept (the reference level).

-
## [1] "F" "M"
-

As female is the first level, it means that it is the intercept. Based on our model, an increase of 1 on the scale of adjusting will increase the probability (expressed in log odds ratios) of being a male.

-
-
-

Model Visualization

-

To visualize this type of model, we have to derive a reference grid.

-
refgrid <- df %>% 
-  select(Adjusting) %>% 
-  psycho::refdata(length.out=10)
-  
-predicted <- psycho::get_predicted(fit, newdata=refgrid)
-

Note that get_predicted automatically transformed log odds ratios (the values in which the model is expressed) to probabilities, easier to apprehend.

-
ggplot(predicted, aes(x=Adjusting, y=Sex_Median)) +
-  geom_line() +
-  geom_ribbon(aes(ymin=Sex_CI_5, 
-                  ymax=Sex_CI_95), 
-              alpha=0.1) +
-  ylab("Probability of being a male")
-

-

We can nicely see the non-linear relationship between adjusting and the probability of being a male.

-
-
-
-

Multiple Regressions and MANOVAs / ANCOVAs

-

Let’s create models a bit more complex, mixing factors with numeric predictors, to see if the life satisfaction is related to the tendency to suppress, conceal the emotional reactions, and does this relationship depends on the sex.

-
-

Model Exploration

-
# Let's fit our model
-fit <- rstanarm::stan_glm(Life_Satisfaction ~ Concealing * Sex, data=df)
-

Let’s check our model:

-
# Format the results using analyze()
-results <- psycho::analyze(fit)
-
-# We can extract a formatted summary table
-summary(results, round = 2)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
VariableMedianMADCI_lowerCI_higherMPEOverlap
R20.010.010.000.02NANA
(Intercept)5.190.124.995.38NANA
Concealing-0.100.03-0.15-0.0599.9212.24
SexM-0.660.32-1.18-0.1497.8530.62
Concealing:SexM0.180.070.060.3099.3022.54
-

Again, it is important to notice that the intercept (the baseline) corresponds here to Concealing = 0 and Sex = F. As we can see next, there is, with high probability, a negative linear relationship between concealing (for females only) and life satisfaction. Also, at the (theorethical) intercept (when concealing = 0), the males have a lower life satisfaction. Finally, the interaction is also probable. This means that when the participant is a male, the relationship between concealing and life satisfaction is significantly different (increased by 0.17. In other words, we could say that the relationship is of -0.10+0.17=0.07 in men).

-
-
-

Model Visualization

-

How to represent this type of models? Again, we have to generate a reference grid.

-
refgrid <- df %>% 
-  select(Concealing, Sex) %>% 
-  psycho::refdata(length.out=10)
-
-predicted <- psycho::get_predicted(fit, newdata=refgrid)
-predicted
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ConcealingSexLife_Satisfaction_MedianLife_Satisfaction_CI_5Life_Satisfaction_CI_95
0.0000000F5.1932624.9897205.380699
0.7777778F5.1160954.9488245.270473
1.5555556F5.0399904.9169705.171776
2.3333333F4.9632714.8650785.060558
3.1111111F4.8862014.8058874.961358
3.8888889F4.8105454.7349504.883014
4.6666667F4.7342414.6428484.821253
5.4444444F4.6582034.5361444.770149
6.2222222F4.5809204.4303094.732424
7.0000000F4.5046364.3244044.696584
0.0000000M4.5328484.0774985.036241
0.7777778M4.5972974.2128525.014122
1.5555556M4.6610104.3495935.003251
2.3333333M4.7203904.4755124.991639
3.1111111M4.7821094.5845314.975721
3.8888889M4.8439984.6884884.998955
4.6666667M4.9104814.7526295.060641
5.4444444M4.9725134.7813635.174310
6.2222222M5.0358474.8004005.315524
7.0000000M5.1006494.7680705.424739
-

As we can see, the reference grid is balanced in terms of factors and numeric predictors. Now, to plot this becomes very easy!

-
ggplot(predicted, aes(x=Concealing, y=Life_Satisfaction_Median, fill=Sex)) +
-  geom_line(aes(colour=Sex)) +
-  geom_ribbon(aes(fill=Sex,
-                  ymin=Life_Satisfaction_CI_5, 
-                  ymax=Life_Satisfaction_CI_95), 
-              alpha=0.1) +
-  ylab("Life Satisfaction")
-

-

We can see that the error for the males is larger, due to less observations.

-
-
-
-

Mixed Models

-
-

Why use mixed-models?

-
    -
  • From Makowski et al. (under review):
    • -
-
-

The Mixed modelling framework allows estimated effects to vary by group at lower levels while estimating population-level effects through the specification of fixed (explanatory variables) and random (variance components) effects. Outperforming traditional procedures such as repeated measures ANOVA (Kristensen & Hansen, 2004), these models are particularly suited to cases in which experimental stimuli are heterogeneous (e.g., images) as the item-related variance, in addition to the variance induced by participants, can be accounted for (Baayen, Davidson, & Bates, 2008; Magezi, 2015). Moreover, mixed models can handle unbalanced data, nested designs, crossed random effects and missing data.

-
-

As for how to run this type of analyses, it is quite easy. Indeed, all what has been said previously remains the same for mixed models. Except that there are random effects (specified by putting + (1|random_term) in the formula). For example, we might want to consider the salary as a random effect (to “adjust” (so to speak) for the fact that the data is structured in two groups). Let’s explore the relationship between the tendency to conceal emotions and age (adjusted for salary).

-
-
-

Model Exploration

-
# Let's fit our model (it takes more time)
-fit <- rstanarm::stan_lmer(Concealing ~ Age + (1|Salary), data=df)
-

Let’s check our model:

-
# Format the results using analyze()
-results <- psycho::analyze(fit)
-
## Warning in R2_LOO_Adjusted(fit): Something went wrong in the Loo-adjusted
-## R2 computation.
-
# We can extract a formatted summary table
-summary(results, round = 2)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
VariableMedianMADCI_lowerCI_higherMPEOverlap
R20.000.000.000.01NANA
(Intercept)3.950.173.614.25NANA
Age-0.010.00-0.020.0091.246.61
-

As we can see, the linear relationship has only a moderate probability of being different from 0.

-
-
-

Model Visualization

-
refgrid <- df %>% 
-  select(Age) %>% 
-  psycho::refdata(length.out=10)
-
-# We name the predicted dataframe by adding '_linear' to keep it for further comparison (see next part)
-predicted_linear <- psycho::get_predicted(fit, newdata=refgrid)
-
ggplot(predicted_linear, aes(x=Age, y=Concealing_Median)) +
-  geom_line() +
-  geom_ribbon(aes(ymin=Concealing_CI_5, 
-                  ymax=Concealing_CI_95), 
-              alpha=0.1)
-

-
-
-
-

Polynomial Transformations

-

Relationships in the real world are often non-linear. For example, based on the previous relationship between concealing and age, we could try modelling a polynomial (second order) transformation to the predictor.

-
-

Model Exploration

-

Let’s check our model:

-
# Format the results using analyze()
-results <- psycho::analyze(fit)
-
## Warning in R2_LOO_Adjusted(fit): Something went wrong in the Loo-adjusted
-## R2 computation.
-
# We can extract a formatted summary table
-summary(results, round = 2)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
VariableMedianMADCI_lowerCI_higherMPEOverlap
R20.010.010.000.02NANA
(Intercept)5.020.564.125.93NANA
poly(Age, 2, raw = TRUE)1-0.070.03-0.12-0.0299.426.52
poly(Age, 2, raw = TRUE)20.000.000.000.0098.079.65
-

As we can see, both the linear relationship and the second order curvature are highly probable. However, when setting raw=TRUE in the formula, the coefficients become unintepretable. So let’s visualize them.

-
-
-

Model Visualization

-

The model visualization routine is similar to the previous ones.

-
refgrid <- df %>% 
-  select(Age) %>% 
-  psycho::refdata(length.out=20)
-
-predicted_poly <- psycho::get_predicted(fit, newdata=refgrid)
-
ggplot(predicted_poly, aes(x=Age, y=Concealing_Median)) +
-  geom_line() +
-  geom_ribbon(aes(ymin=Concealing_CI_5, 
-                  ymax=Concealing_CI_95), 
-              alpha=0.1)
-

-

As we can see, adding the polynomial degree changes the relationship. Since the model is here very simple, we can add on the plot the actual points (however, they do not take into account the random effects and such), as well as plot the two models. Also, let’s make it “dynamic” using plotly.

-
p <- ggplot() +
-  # Linear model
-  geom_line(data=predicted_linear, 
-            aes(x=Age, y=Concealing_Median),
-            colour="blue",
-            size=1) +
-  geom_ribbon(data=predicted_linear, 
-              aes(x=Age,
-                  ymin=Concealing_CI_5,
-                  ymax=Concealing_CI_95), 
-              alpha=0.1,
-              fill="blue") +
-  # Polynormial Model
-  geom_line(data=predicted_poly, 
-            aes(x=Age, y=Concealing_Median),
-            colour="red",
-            size=1) +
-  geom_ribbon(data=predicted_poly, 
-              aes(x=Age,
-                  ymin=Concealing_CI_5, 
-                  ymax=Concealing_CI_95), 
-              fill="red",
-              alpha=0.1) +
-  # Actual data
-  geom_point(data=df, aes(x=Age, y=Concealing))
-
-library(plotly) # To create interactive plots
-ggplotly(p) # To transform a ggplot into an interactive plot
-
- -

It’s good to take a few steps back and look at the bigger picture :)

- - - - - - - - - - - - - - - - - + + + + + + + + + - - - - - - - - - - - - - - - - - - - -
-
-
-

Piors Specification

-

One of the interesting aspect of the Bayesian framework is the possibility of adding prior expectations about the effect, to help model fitting and increase accuracy in noisy data or small samples.

-
-

Weakly informative priors

-

As you might have notice, we didn’t specify any priors in the previous analyses. In fact, we let the algorithm define and set weakly informative priors, designed to provide moderate regularization and help stabilize computation, without biasing the effect direction. For example, a wealky informative prior, for a standardized predictor (with mean = 0 and SD = 1) could be a normal distribution with mean = 0 and SD = 1. This means that the effect of this predictor is expected to be equally probable in any direction (as the distribution is symmetric around 0), with probability being higher close to 0 and lower far from 0.

-

While this prior doesn’t bias the direction of the Bayesian (MCMC) sampling, it suggests that having an effect of 100 (i.e., located at 100 SD of the mean as our variables are standardized) is highly unprobable, and that an effect close to 0 is more probable.

-

To better play with priors, let’s start by standardizing our dataframe.

-
# Standardize (scale and center) the numeric variables
-dfZ <- psycho::standardize(df)
-

Then, we can explicitly specify a weakly informative prior for all effects of the model.

-
# Let's fit our model
-fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, 
-                          data=dfZ,
-                          prior=normal(location = 0, # Mean
-                                       scale = 1, # SD
-                                       autoscale=FALSE)) # Don't adjust scale automatically
-

Let’s plot the prior (the expectation) against the posterior (the estimated effect) distribution.

-
results <- psycho::analyze(fit)
-
-# Extract the posterior
-posterior <- results$values$effects$Tolerating$posterior
-
-# Create a posterior with the prior and posterior distribution and plot them.
-data.frame(posterior = posterior,
-           prior = rnorm(length(posterior), 0, 1)) %>% 
-  ggplot() +
-  geom_density(aes(x=posterior), fill="lightblue", alpha=0.5) +
-  geom_density(aes(x=prior), fill="blue", alpha=0.5) +
-  scale_y_sqrt() # Change the Y axis so the plot is less ugly
-

-

This plot is rather ugly, because our posterior is very precise (due to the large sample) compared to the prior.

-
-
-

Informative priors

-

Although the default priors tend to work well, prudent use of more informative priors is encouraged. It is important to underline that setting informative priors (if realistic), does not overbias the analysis. In other words, is only “directs” the sampling: if the data are highly informative about the parameter values (enough to overwhelm the prior), a prudent informative prior (even if oppositive to the observed effect) will yield similar results to a non-informative prior. In other words, you can’t change the results dramatically by tweaking the priors. But as the amount of data and/or the signal-to-noise ratio decrease, using a more informative prior becomes increasingly important. Of course, if you see someone using a prior with mean = 42 and SD = 0.0001, you should look at his results with caution…

-

Anyway, see the official rstanarm documentation for details.

-
-
-
-

Advanced Visualization

-
-

Plot all iterations

-

As Bayesian models usually generate a lot of samples (iterations), one could want to plot them as well, instead (or along) the posterior “summary”. This can be done quite easily by extracting all the iterations in get_predicted.

-
# Fit the model
-fit <- rstanarm::stan_glm(Sex ~ Adjusting, data=df, family = "binomial")
-
# Generate a new refgrid
-refgrid <- df %>% 
-  select(Adjusting) %>% 
-  psycho::refdata(length.out=10)
-
-# Get predictions and keep iterations
-predicted <- psycho::get_predicted(fit, newdata=refgrid, keep_iterations=TRUE)
-
-# Reshape this dataframe to have iterations as factor
-predicted <- predicted %>% 
-  tidyr::gather(Iteration, Iteration_Value, starts_with("iter"))
-
-# Plot iterations as well as the median prediction
-ggplot(predicted, aes(x=Adjusting)) +
-  geom_line(aes(y=Iteration_Value, group=Iteration), size=0.3, alpha=0.01) +
-  geom_line(aes(y=Sex_Median), size=1) + 
-  ylab("Male Probability\n")
-

-
-
-
-

Credits

-

This package helped you? Don’t forget to cite the various packages you used :)

-

You can cite psycho as follows:

-
    -
  • Makowski, (2018). The psycho Package: An Efficient and Publishing-Oriented Workflow for Psychological Science. Journal of Open Source Software, 3(22), 470. https://doi.org/10.21105/joss.00470
    • -
-
-
-

Contribution

-

Improve this vignette by modifying this file!

+
+

The Bayesian Framework

+

The vignette was updated and is available here.

diff --git a/vignettes/overview.R b/vignettes/overview.R index e5cf2de..941ea41 100644 --- a/vignettes/overview.R +++ b/vignettes/overview.R @@ -4,6 +4,9 @@ library(dplyr) library(ggplot2) library(rstanarm) +## ---- out.width=700, echo = FALSE, eval = TRUE, fig.align='center'------- +knitr::include_graphics("images/workflow.PNG") + ## ---- eval = FALSE------------------------------------------------------- # # This for the stable version: # install.packages("psycho") @@ -16,60 +19,3 @@ library(rstanarm) ## ------------------------------------------------------------------------ library(psycho) -## ---- out.width=700, echo = FALSE, eval = TRUE, fig.align='center'------- -knitr::include_graphics("images/workflow.PNG") - -## ----eval=TRUE, fig.align='center', fig.height=4.5, fig.width=9, message=FALSE, warning=FALSE, results='markup'---- -library(psycho) - -# Let's create a correlation plot -p <- plot(psycho::correlation(iris)) - -# Custom theme and colours -p <- p + - scale_fill_gradientn(colors = c("#4CAF50", "#FFEB3B", "#FF5722")) + - ylab("Variables\n") + - labs(fill = "r") + - theme( - plot.background = element_rect(fill = "#607D8B"), - axis.title.y = element_text(size = 20, angle = 90, colour = "white"), - axis.text = element_text(size = 15, colour = "white"), - legend.title = element_text(size = 20, colour = "white"), - legend.text = element_text(size = 15, colour = "white"), - title = element_text(size = 16, colour = "white") - ) -p - -## ----echo=TRUE, message=FALSE, warning=FALSE, results='markup'----------- -library(psycho) - -patient <- 61 # The IQ of a patient -controls <- c(86, 100, 112, 95, 121, 102) # The IQs of a control group - -result <- crawford.test(patient, controls) -print(result) -plot(result) - -## ----echo=TRUE, message=FALSE, warning=FALSE, results='markup'----------- -library(psycho) - -case_X <- 132 -case_Y <- 7 -controls_X <- c(100, 125, 89, 105, 109, 99) -controls_Y <- c(7, 8, 9, 6, 7, 10) - -result <- crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y) - -## ----echo=TRUE, message=FALSE, warning=FALSE, results='markup'----------- -library(psycho) - -t0 <- 82 # The IQ of a patient at baseline -t1 <- 105 # The IQ of a patient after the new therapy -controls <- c(94, 100, 108, 95, 102, 94) # The IQs of a control group - -rez <- mellenbergh.test(t0, t1, controls = controls) - -# if we do not have a control group, we can also directly enter the SD of the score. -# For IQ, the SD is of 15. -rez <- mellenbergh.test(t0, t1, controls = 15) - diff --git a/vignettes/overview.Rmd b/vignettes/overview.Rmd index b5d9ddb..4d2d6ee 100644 --- a/vignettes/overview.Rmd +++ b/vignettes/overview.Rmd @@ -32,8 +32,13 @@ library(rstanarm) ``` +The package mainly revolves around the `psychobject`. Main functions from the package return this type, and the `analyze()` function transforms other R objects into psychobjects. 4 functions can be then applied on a psychobject: `summary()`, `print()`, `plot()` and `values()`. + +```{r, out.width=700, echo = FALSE, eval = TRUE, fig.align='center'} +knitr::include_graphics("images/workflow.PNG") +``` -## Installation +# Installation ### Install R and R Studio @@ -73,14 +78,6 @@ library(psycho) ``` -## General Workflow - - -The package mainly revolves around the `psychobject`. Main functions from the package return this type, and the `analyze()` function transforms other R objects into psychobjects. 4 functions can be then applied on a psychobject: `summary()`, `print()`, `plot()` and `values()`. - -```{r, out.width=700, echo = FALSE, eval = TRUE, fig.align='center'} -knitr::include_graphics("images/workflow.PNG") -``` @@ -107,96 +104,96 @@ knitr::include_graphics("images/workflow.PNG") - [Installing R, R Studio and psycho](https://neuropsychology.github.io/psycho.R/2018/03/21/installingR.html) -# Other + -## Custom Plots + -In general, the `plot()` function returns, most of the times, a ggplot object. That means it remains quite flexible. Here's an example. + -```{r eval=TRUE, fig.align='center', fig.height=4.5, fig.width=9, message=FALSE, warning=FALSE, results='markup'} -library(psycho) + + -# Let's create a correlation plot -p <- plot(psycho::correlation(iris)) - -# Custom theme and colours -p <- p + - scale_fill_gradientn(colors = c("#4CAF50", "#FFEB3B", "#FF5722")) + - ylab("Variables\n") + - labs(fill = "r") + - theme( - plot.background = element_rect(fill = "#607D8B"), - axis.title.y = element_text(size = 20, angle = 90, colour = "white"), - axis.text = element_text(size = 15, colour = "white"), - legend.title = element_text(size = 20, colour = "white"), - legend.text = element_text(size = 15, colour = "white"), - title = element_text(size = 16, colour = "white") - ) -p -``` + + + + + + + + + + + + + + + + + ------- -## Single-case methods + -### Crawford-Garthwaite (2007) Bayesian test for single-case vs. control group + -Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2012) demonstrate that the Crawford-Garthwaite (2007) t-test is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. + + -```{r echo=TRUE, message=FALSE, warning=FALSE, results='markup'} -library(psycho) -patient <- 61 # The IQ of a patient -controls <- c(86, 100, 112, 95, 121, 102) # The IQs of a control group + + -result <- crawford.test(patient, controls) -print(result) -plot(result) -``` + + -### Crawford-Howell (1998) t-test for dissociation + + + + -Assessing dissociation between processes is a fundamental part of clinical neuropsychology. However, while the detection of suspected impairments is a fundamental feature of single-case studies, evidence of an impairment on a given task usually becomes of theoretical interest only if it is observed in the context of less impaired or normal performance on other tasks. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test for dissociation is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. + + -```{r echo=TRUE, message=FALSE, warning=FALSE, results='markup'} -library(psycho) -case_X <- 132 -case_Y <- 7 -controls_X <- c(100, 125, 89, 105, 109, 99) -controls_Y <- c(7, 8, 9, 6, 7, 10) + + -result <- crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y) -``` + + + + + + -### Mellenbergh & van den Brink (1998) test for pre-post comparison -Clinicians willing to check if their intervention had an effect on a single participant might want to use the Mellenbergh & van den Brink (1998) test, comparing the difference between baseline and post-test to the standart deviation of a control group. + -```{r echo=TRUE, message=FALSE, warning=FALSE, results='markup'} -library(psycho) + -t0 <- 82 # The IQ of a patient at baseline -t1 <- 105 # The IQ of a patient after the new therapy -controls <- c(94, 100, 108, 95, 102, 94) # The IQs of a control group + + -rez <- mellenbergh.test(t0, t1, controls = controls) + + + -# if we do not have a control group, we can also directly enter the SD of the score. -# For IQ, the SD is of 15. -rez <- mellenbergh.test(t0, t1, controls = 15) -``` + + + + + + -## Credits +# Credits This package helped you? Don't forget to cite the various packages you used :) @@ -205,6 +202,6 @@ You can cite `psycho` as follows: - Makowski, (2018). *The psycho Package: An Efficient and Publishing-Oriented Workflow for Psychological Science*. Journal of Open Source Software, 3(22), 470. https://doi.org/10.21105/joss.00470 -## Contribution +# Contribution Improve this vignette by modifying [this](https://github.com/neuropsychology/psycho.R/blob/master/vignettes/overview.Rmd) file! diff --git a/vignettes/overview.html b/vignettes/overview.html index d0ec29d..a867597 100644 --- a/vignettes/overview.html +++ b/vignettes/overview.html @@ -12,50 +12,98 @@ - + psycho for R - + - + @@ -80,49 +310,42 @@

psycho for R

Dominique Makowski

-

2018-07-11

+

2019-03-29

Abstract

-

Psycho is an R package that aims at providing tools for psychologists, neuropsychologists and neuroscientists, to transform statistical outputs into something readable that can be, almost directly, copied and pasted into a report. It also implements various functions useful in psychological science, such as correlation matrices, assessment plot creation or normalization. The package revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. Four functions can then be applied on a psychobject: summary(), print(), plot() and values(). Contrary to many other packages which goal is to produce statistical analyzes, psycho aims at filling the gap between statistical R outputs and statistical report writing, with a focus on APA formatting guidelines, to enhance the standardization of results reporting. Complex outputs, such as those of Bayesian and frequentist mixed models, are automatically transformed into readable text, tables, and plots that illustrate the effects. Thus, the results can easily be incorporated into shareable reports and publications, promoting data exploration, saving time and preventing errors for better, reproducible, science.

+Psycho is an R package that aims at providing tools for psychologists, neuropsychologists and neuroscientists, to transform statistical outputs into something readable that can be, almost directly, copied and pasted into a report. It also implements various functions useful in psychological science, such as correlation matrices, assessment plot creation or normalization. The package revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. Four functions can then be applied on a psychobject: summary(), print(), plot() and values(). Contrary to many other packages which goal is to produce statistical analyzes, psycho aims at filling the gap between statistical R outputs and statistical report writing, with a focus on APA formatting guidelines, to enhance the standardization of results reporting. Complex outputs, such as those of Bayesian and frequentist mixed models, are automatically transformed into readable text, tables, and plots that illustrate the effects. Thus, the results can easily be incorporated into shareable reports and publications, promoting data exploration, saving time and preventing errors for better, reproducible, science.

Overview

-
-

Installation

+

The package mainly revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. 4 functions can be then applied on a psychobject: summary(), print(), plot() and values().

+

+
+
+

Installation

Install R and R Studio

-
-

General Workflow

-

The package mainly revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. 4 functions can be then applied on a psychobject: summary(), print(), plot() and values().

-

+
@@ -176,92 +393,75 @@

Examples

  • Compute Signal Detection Theory Indices
  • Installing R, R Studio and psycho
    • + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    -
    -

    Other

    -
    -

    Custom Plots

    -

    In general, the plot() function returns, most of the times, a ggplot object. That means it remains quite flexible. Here’s an example.

    -
    library(psycho)
-
-# Let's create a correlation plot
-p <- plot(psycho::correlation(iris))
-
-# Custom theme and colours
-p <- p +
-  scale_fill_gradientn(colors = c("#4CAF50", "#FFEB3B", "#FF5722")) +
-  ylab("Variables\n") +
-  labs(fill = "r") +
-  theme(
-    plot.background = element_rect(fill = "#607D8B"),
-    axis.title.y = element_text(size = 20, angle = 90, colour = "white"),
-    axis.text = element_text(size = 15, colour = "white"),
-    legend.title = element_text(size = 20, colour = "white"),
-    legend.text = element_text(size = 15, colour = "white"),
-    title = element_text(size = 16, colour = "white")
-  )
-p
    -

    -
    -
    -
    -

    Single-case methods

    -
    -

    Crawford-Garthwaite (2007) Bayesian test for single-case vs. control group

    -

    Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2012) demonstrate that the Crawford-Garthwaite (2007) t-test is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives.

    -
    library(psycho)
-
-patient <- 61 # The IQ of a patient
-controls <- c(86, 100, 112, 95, 121, 102) # The IQs of a control group
-
-result <- crawford.test(patient, controls)
-print(result)
    -
    ## The Bayesian test for single case assessment (Crawford, Garthwaite, 2007) suggests that the patient's score (Raw = 61, Z = -3.36, percentile = 0.038) is significantly different from the controls (M = 102.67, SD = 12.39, p < .05*). The patient's score is lower than 98.61% (95% CI [92.67, 100.00]) of the control population.
    -
    plot(result)
    -

    -
    -
    -

    Crawford-Howell (1998) t-test for dissociation

    -

    Assessing dissociation between processes is a fundamental part of clinical neuropsychology. However, while the detection of suspected impairments is a fundamental feature of single-case studies, evidence of an impairment on a given task usually becomes of theoretical interest only if it is observed in the context of less impaired or normal performance on other tasks. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test for dissociation is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives.

    -
    library(psycho)
-
-case_X <- 132
-case_Y <- 7
-controls_X <- c(100, 125, 89, 105, 109, 99)
-controls_Y <- c(7, 8, 9, 6, 7, 10)
-
-result <- crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y)
    -
    ## The Crawford-Howell (1998) t-test suggests no dissociation between test X and test Y (t(5) = 1.62, p > .1). The patient's score on test X is not significantly altered compared to its score on test Y.
    -
    -
    -

    Mellenbergh & van den Brink (1998) test for pre-post comparison

    -

    Clinicians willing to check if their intervention had an effect on a single participant might want to use the Mellenbergh & van den Brink (1998) test, comparing the difference between baseline and post-test to the standart deviation of a control group.

    -
    library(psycho)
-
-t0 <- 82 # The IQ of a patient at baseline
-t1 <- 105 # The IQ of a patient after the new therapy
-controls <- c(94, 100, 108, 95, 102, 94) # The IQs of a control group
-
-rez <- mellenbergh.test(t0, t1, controls = controls)
-
-# if we do not have a control group, we can also directly enter the SD of the score.
-# For IQ, the SD is of 15.
-rez <- mellenbergh.test(t0, t1, controls = 15)
    -
    -
    -
    -

    Credits

    +
    +

    Credits

    This package helped you? Don’t forget to cite the various packages you used :)

    You can cite psycho as follows:

    • Makowski, (2018). The psycho Package: An Efficient and Publishing-Oriented Workflow for Psychological Science. Journal of Open Source Software, 3(22), 470. https://doi.org/10.21105/joss.00470
    -
    -

    Contribution

    +
    +

    Contribution

    Improve this vignette by modifying this file!

    -
    From 80a7edf4ced778e1eb9d6fb625cc509a9ebddf92 Mon Sep 17 00:00:00 2001 From: Dominique Makowski Date: Mon, 11 Nov 2019 11:05:17 +0800 Subject: [PATCH 2/4] remove tons of stuff (0.5.0) --- DESCRIPTION | 9 +- NAMESPACE | 190 +- R/assess.R | 114 + R/crawford.test.R | 290 + R/crawford_dissociation.test.R | 93 + R/deprecated.R | 10301 +--------------- R/dprime.R | 138 + R/interpret_posterior.R | 119 + R/mellenbergh.test.R | 83 + R/miscellaneous.R | 418 + R/psychobject.R | 76 + R/startup_message.R | 2 +- man/HDImax.Rd | 16 - man/HDImin.Rd | 16 - man/R2_LOO_Adjusted.Rd | 29 - man/R2_nakagawa.Rd | 31 - man/R2_tjur.Rd | 27 - man/analyze.Rd | 36 - man/analyze.aov.Rd | 60 - man/analyze.blavaan.Rd | 39 - man/analyze.fa.Rd | 37 - man/analyze.glm.Rd | 40 - man/analyze.glmerMod.Rd | 43 - man/analyze.htest.Rd | 38 - man/analyze.lavaan.Rd | 39 - man/analyze.lm.Rd | 35 - man/analyze.lmerModLmerTest.Rd | 39 - man/analyze.principal.Rd | 37 - man/analyze.stanreg.Rd | 79 - man/as.data.frame.density.Rd | 19 - man/assess.Rd | 2 +- man/bayes_cor.Rd | 43 - man/bayes_cor.test.Rd | 42 - man/cite_packages.Rd | 24 - man/correlation.Rd | 58 - man/crawford.test.Rd | 2 +- man/crawford.test.freq.Rd | 2 +- man/crawford_dissociation.test.Rd | 2 +- man/create_intervals.Rd | 40 - man/dprime.Rd | 6 +- man/find_best_model.Rd | 27 - man/find_best_model.lavaan.Rd | 44 - man/find_best_model.lmerModLmerTest.Rd | 42 - man/find_best_model.stanreg.Rd | 55 - man/find_distance_cluster.Rd | 19 - man/find_highest_density_point.Rd | 19 - man/find_matching_string.Rd | 2 +- man/find_random_effects.Rd | 21 - man/find_season.Rd | 2 +- man/format_bf.Rd | 16 - man/format_formula.Rd | 3 +- man/format_loadings.Rd | 28 - man/format_p.Rd | 21 - man/format_string.Rd | 19 - man/get_R2.Rd | 24 - man/get_R2.glm.Rd | 32 - man/get_R2.lm.Rd | 29 - man/get_R2.merMod.Rd | 34 - man/get_R2.stanreg.Rd | 35 - man/get_cfa_model.Rd | 30 - man/get_contrasts.Rd | 48 - man/get_contrasts.glm.Rd | 25 - man/get_contrasts.glmerMod.Rd | 25 - man/get_contrasts.lm.Rd | 25 - man/get_contrasts.lmerMod.Rd | 25 - man/get_contrasts.lmerModLmerTest.Rd | 25 - man/get_contrasts.stanreg.Rd | 26 - man/get_data.Rd | 41 - man/get_formula.Rd | 35 - man/get_graph.Rd | 24 - man/get_graph.fa.Rd | 26 - man/get_graph.lavaan.Rd | 41 - man/get_graph.psychobject_correlation.Rd | 22 - man/get_info.Rd | 31 - man/get_info.lm.Rd | 33 - man/get_info.lmerModLmerTest.Rd | 33 - man/get_loadings_max.Rd | 26 - man/get_means.Rd | 44 - man/get_predicted.Rd | 26 - man/get_predicted.glm.Rd | 49 - man/get_predicted.lm.Rd | 46 - man/get_predicted.merMod.Rd | 84 - man/get_predicted.stanreg.Rd | 78 - man/golden.Rd | 2 +- man/hdi.Rd | 31 - man/interpret_R2.Rd | 24 - man/interpret_R2_posterior.Rd | 2 +- man/interpret_RMSEA.Rd | 23 - man/interpret_bf.Rd | 33 - ...lavaan.blavaan.Rd => interpret_blavaan.Rd} | 11 +- man/interpret_d.Rd | 26 - man/interpret_d_posterior.Rd | 25 - man/interpret_lavaan.Rd | 19 - man/interpret_lavaan.lavaan.Rd | 16 - man/interpret_odds.Rd | 35 - man/interpret_odds_posterior.Rd | 28 - man/interpret_omega_sq.Rd | 31 - man/interpret_r.Rd | 31 - man/interpret_r_posterior.Rd | 27 - man/is.mixed.Rd | 23 - man/is.mixed.stanreg.Rd | 19 - man/is.standardized.Rd | 5 +- man/mellenbergh.test.Rd | 2 +- man/model_to_priors.Rd | 2 +- man/mpe.Rd | 30 - man/n_factors.Rd | 38 - man/odds_to_d.Rd | 31 - man/odds_to_probs.Rd | 29 - man/omega_sq.Rd | 35 - man/overlap.Rd | 28 - man/percentile.Rd | 2 +- man/percentile_to_z.Rd | 2 +- man/plot.psychobject.Rd | 2 +- man/plot_loadings.Rd | 26 - man/power_analysis.Rd | 15 +- man/print.psychobject.Rd | 2 +- man/probs_to_odds.Rd | 23 - man/refdata.Rd | 37 - man/remove_outliers.Rd | 24 - man/reorder_matrix.Rd | 23 - man/rnorm_perfect.Rd | 30 - man/rope.Rd | 33 - man/simulate_data_regression.Rd | 1 - man/standardize.Rd | 26 - man/standardize.data.frame.Rd | 55 - man/standardize.glm.Rd | 34 - man/standardize.lm.Rd | 41 - man/standardize.numeric.Rd | 25 - man/standardize.stanreg.Rd | 36 - man/summary.psychobject.Rd | 2 +- man/values.Rd | 2 +- tests/testthat/test-assess.R | 150 + tests/testthat/test-deprecated.R | 1114 -- tests/testthat/test-dprime.R | 18 + 134 files changed, 2016 insertions(+), 14367 deletions(-) create mode 100644 R/assess.R create mode 100644 R/crawford.test.R create mode 100644 R/crawford_dissociation.test.R create mode 100644 R/dprime.R create mode 100644 R/interpret_posterior.R create mode 100644 R/mellenbergh.test.R create mode 100644 R/miscellaneous.R create mode 100644 R/psychobject.R delete mode 100644 man/HDImax.Rd delete mode 100644 man/HDImin.Rd delete mode 100644 man/R2_LOO_Adjusted.Rd delete mode 100644 man/R2_nakagawa.Rd delete mode 100644 man/R2_tjur.Rd delete mode 100644 man/analyze.Rd delete mode 100644 man/analyze.aov.Rd delete mode 100644 man/analyze.blavaan.Rd delete mode 100644 man/analyze.fa.Rd delete mode 100644 man/analyze.glm.Rd delete mode 100644 man/analyze.glmerMod.Rd delete mode 100644 man/analyze.htest.Rd delete mode 100644 man/analyze.lavaan.Rd delete mode 100644 man/analyze.lm.Rd delete mode 100644 man/analyze.lmerModLmerTest.Rd delete mode 100644 man/analyze.principal.Rd delete mode 100644 man/analyze.stanreg.Rd delete mode 100644 man/as.data.frame.density.Rd delete mode 100644 man/bayes_cor.Rd delete mode 100644 man/bayes_cor.test.Rd delete mode 100644 man/cite_packages.Rd delete mode 100644 man/correlation.Rd delete mode 100644 man/create_intervals.Rd delete mode 100644 man/find_best_model.Rd delete mode 100644 man/find_best_model.lavaan.Rd delete mode 100644 man/find_best_model.lmerModLmerTest.Rd delete mode 100644 man/find_best_model.stanreg.Rd delete mode 100644 man/find_distance_cluster.Rd delete mode 100644 man/find_highest_density_point.Rd delete mode 100644 man/find_random_effects.Rd delete mode 100644 man/format_bf.Rd delete mode 100644 man/format_loadings.Rd delete mode 100644 man/format_p.Rd delete mode 100644 man/format_string.Rd delete mode 100644 man/get_R2.Rd delete mode 100644 man/get_R2.glm.Rd delete mode 100644 man/get_R2.lm.Rd delete mode 100644 man/get_R2.merMod.Rd delete mode 100644 man/get_R2.stanreg.Rd delete mode 100644 man/get_cfa_model.Rd delete mode 100644 man/get_contrasts.Rd delete mode 100644 man/get_contrasts.glm.Rd delete mode 100644 man/get_contrasts.glmerMod.Rd delete mode 100644 man/get_contrasts.lm.Rd delete mode 100644 man/get_contrasts.lmerMod.Rd delete mode 100644 man/get_contrasts.lmerModLmerTest.Rd delete mode 100644 man/get_contrasts.stanreg.Rd delete mode 100644 man/get_data.Rd delete mode 100644 man/get_formula.Rd delete mode 100644 man/get_graph.Rd delete mode 100644 man/get_graph.fa.Rd delete mode 100644 man/get_graph.lavaan.Rd delete mode 100644 man/get_graph.psychobject_correlation.Rd delete mode 100644 man/get_info.Rd delete mode 100644 man/get_info.lm.Rd delete mode 100644 man/get_info.lmerModLmerTest.Rd delete mode 100644 man/get_loadings_max.Rd delete mode 100644 man/get_means.Rd delete mode 100644 man/get_predicted.Rd delete mode 100644 man/get_predicted.glm.Rd delete mode 100644 man/get_predicted.lm.Rd delete mode 100644 man/get_predicted.merMod.Rd delete mode 100644 man/get_predicted.stanreg.Rd delete mode 100644 man/hdi.Rd delete mode 100644 man/interpret_R2.Rd delete mode 100644 man/interpret_RMSEA.Rd delete mode 100644 man/interpret_bf.Rd rename man/{interpret_lavaan.blavaan.Rd => interpret_blavaan.Rd} (57%) delete mode 100644 man/interpret_d.Rd delete mode 100644 man/interpret_d_posterior.Rd delete mode 100644 man/interpret_lavaan.Rd delete mode 100644 man/interpret_lavaan.lavaan.Rd delete mode 100644 man/interpret_odds.Rd delete mode 100644 man/interpret_odds_posterior.Rd delete mode 100644 man/interpret_omega_sq.Rd delete mode 100644 man/interpret_r.Rd delete mode 100644 man/interpret_r_posterior.Rd delete mode 100644 man/is.mixed.Rd delete mode 100644 man/is.mixed.stanreg.Rd delete mode 100644 man/mpe.Rd delete mode 100644 man/n_factors.Rd delete mode 100644 man/odds_to_d.Rd delete mode 100644 man/odds_to_probs.Rd delete mode 100644 man/omega_sq.Rd delete mode 100644 man/overlap.Rd delete mode 100644 man/plot_loadings.Rd delete mode 100644 man/probs_to_odds.Rd delete mode 100644 man/refdata.Rd delete mode 100644 man/remove_outliers.Rd delete mode 100644 man/reorder_matrix.Rd delete mode 100644 man/rnorm_perfect.Rd delete mode 100644 man/rope.Rd delete mode 100644 man/standardize.Rd delete mode 100644 man/standardize.data.frame.Rd delete mode 100644 man/standardize.glm.Rd delete mode 100644 man/standardize.lm.Rd delete mode 100644 man/standardize.numeric.Rd delete mode 100644 man/standardize.stanreg.Rd create mode 100644 tests/testthat/test-assess.R create mode 100644 tests/testthat/test-dprime.R diff --git a/DESCRIPTION b/DESCRIPTION index 0516363..c1ba438 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: psycho Type: Package Title: Efficient and Publishing-Oriented Workflow for Psychological Science -Version: 0.4.9 +Version: 0.5.0 Authors@R: c( person("Dominique", "Makowski", @@ -33,6 +33,11 @@ Depends: R (>= 3.5.0) Imports: methods, + insight, + bayestestR, + parameters, + performance, + effectsize, dplyr, ggplot2, tidyr, @@ -40,7 +45,7 @@ Imports: purrr, psych, MASS, - qgraph, + qgraph, nFactors, ppcor, ggcorrplot, diff --git a/NAMESPACE b/NAMESPACE index f9725ee..2b11059 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,240 +1,52 @@ # Generated by roxygen2: do not edit by hand -S3method(analyze,anova) -S3method(analyze,aov) -S3method(analyze,aovlist) -S3method(analyze,blavaan) -S3method(analyze,fa) -S3method(analyze,glm) -S3method(analyze,glmerMod) -S3method(analyze,htest) -S3method(analyze,lavaan) -S3method(analyze,lm) -S3method(analyze,lmerModLmerTest) -S3method(analyze,principal) -S3method(analyze,stanreg) -S3method(as.data.frame,density) -S3method(find_best_model,lavaan) -S3method(find_best_model,lmerModLmerTest) -S3method(find_best_model,stanreg) S3method(find_combinations,formula) -S3method(get_R2,glm) -S3method(get_R2,lm) -S3method(get_R2,merMod) -S3method(get_R2,stanreg) -S3method(get_contrasts,glm) -S3method(get_contrasts,glmerMod) -S3method(get_contrasts,lm) -S3method(get_contrasts,lmerMod) -S3method(get_contrasts,lmerModLmerTest) -S3method(get_contrasts,stanreg) -S3method(get_data,lm) -S3method(get_data,merMod) -S3method(get_data,stanreg) -S3method(get_formula,glm) -S3method(get_formula,glmerMod) -S3method(get_formula,lm) -S3method(get_formula,lmerMod) -S3method(get_formula,lmerModLmerTest) -S3method(get_formula,stanreg) -S3method(get_graph,fa) -S3method(get_graph,lavaan) -S3method(get_graph,psychobject_correlation) -S3method(get_info,glm) -S3method(get_info,glmerMod) -S3method(get_info,lm) -S3method(get_info,lmerMod) -S3method(get_info,lmerModLmerTest) -S3method(get_info,stanreg) -S3method(get_means,glm) -S3method(get_means,glmerMod) -S3method(get_means,lm) -S3method(get_means,lmerMod) -S3method(get_means,lmerModLmerTest) -S3method(get_means,stanreg) -S3method(get_predicted,glm) -S3method(get_predicted,lm) -S3method(get_predicted,merMod) -S3method(get_predicted,stanreg) -S3method(interpret_lavaan,blavaan) -S3method(interpret_lavaan,lavaan) -S3method(is.mixed,stanreg) S3method(plot,psychobject) S3method(print,psychobject) -S3method(standardize,data.frame) -S3method(standardize,glm) -S3method(standardize,glmerMod) -S3method(standardize,lm) -S3method(standardize,lmerMod) -S3method(standardize,numeric) -S3method(standardize,stanreg) S3method(summary,psychobject) -export(.fa_variance_text) -export(HDI) -export(HDImax) -export(HDImin) -export(R2_LOO_Adjusted) -export(R2_nakagawa) -export(R2_tjur) -export(analyze) export(assess) -export(bayes_cor) -export(bayes_cor.test) -export(cite_packages) -export(correlation) export(crawford.test) export(crawford.test.freq) export(crawford_dissociation.test) -export(create_intervals) export(dprime) -export(find_best_model) export(find_combinations) -export(find_distance_cluster) -export(find_highest_density_point) export(find_matching_string) -export(find_random_effects) export(find_season) -export(format_bf) export(format_digit) export(format_formula) -export(format_loadings) -export(format_p) -export(format_string) -export(get_R2) -export(get_cfa_model) -export(get_contrasts) -export(get_data) -export(get_formula) -export(get_graph) -export(get_info) -export(get_loadings_max) -export(get_means) -export(get_predicted) export(golden) -export(interpret_R2) export(interpret_R2_posterior) -export(interpret_RMSEA) -export(interpret_bf) -export(interpret_d) -export(interpret_d_posterior) -export(interpret_lavaan) -export(interpret_odds) -export(interpret_odds_posterior) -export(interpret_omega_sq) -export(interpret_r) -export(interpret_r_posterior) -export(is.mixed) +export(interpret_blavaan) export(is.psychobject) export(is.standardized) export(mellenbergh.test) export(model_to_priors) -export(mpe) -export(n_factors) -export(odds_to_d) -export(odds_to_probs) -export(omega_sq) -export(overlap) export(percentile) export(percentile_to_z) -export(plot_loadings) export(power_analysis) -export(probs_to_odds) -export(refdata) export(remove_empty_cols) -export(remove_outliers) -export(reorder_matrix) -export(rnorm_perfect) -export(rope) export(simulate_data_regression) -export(standardize) export(values) -import(broom) import(dplyr) -import(ggcorrplot) import(ggplot2) -import(lmerTest) -import(loo) -import(ppcor) import(purrr) -import(rstantools) -import(tidyr) -importFrom(BayesFactor,correlationBF) -importFrom(BayesFactor,posterior) -importFrom(DescTools,AUC) -importFrom(MASS,ginv) -importFrom(MASS,mvrnorm) -importFrom(MuMIn,r.squaredGLMM) -importFrom(MuMIn,std.coef) -importFrom(blavaan,standardizedposterior) -importFrom(broom,tidy) -importFrom(dplyr,bind_cols) -importFrom(emmeans,emmeans) -importFrom(ggplot2,cut_interval) -importFrom(ggplot2,cut_number) -importFrom(ggplot2,element_text) -importFrom(ggplot2,theme) -importFrom(graphics,pairs) -importFrom(lavaan,fitmeasures) -importFrom(lavaan,parameterEstimates) -importFrom(lme4,findbars) -importFrom(lme4,getME) -importFrom(loo,kfold) -importFrom(loo,loo) -importFrom(nFactors,moreStats) -importFrom(nFactors,nScree) -importFrom(psych,VSS) -importFrom(psych,corr.test) -importFrom(purrr,discard) -importFrom(purrr,keep) -importFrom(qgraph,cor_auto) -importFrom(rstanarm,bayes_R2) importFrom(rstanarm,normal) importFrom(scales,rescale) importFrom(stats,approx) -importFrom(stats,as.dist) -importFrom(stats,as.formula) -importFrom(stats,complete.cases) -importFrom(stats,confint) importFrom(stats,cor) -importFrom(stats,cor.test) -importFrom(stats,cov) importFrom(stats,density) -importFrom(stats,dnorm) importFrom(stats,ecdf) -importFrom(stats,family) -importFrom(stats,formula) -importFrom(stats,getCall) -importFrom(stats,hclust) -importFrom(stats,mad) -importFrom(stats,median) importFrom(stats,model.frame) -importFrom(stats,model.matrix) -importFrom(stats,model.response) importFrom(stats,na.omit) -importFrom(stats,nobs) -importFrom(stats,p.adjust) importFrom(stats,pnorm) -importFrom(stats,predict) importFrom(stats,pt) importFrom(stats,qnorm) -importFrom(stats,quantile) importFrom(stats,rchisq) -importFrom(stats,residuals) importFrom(stats,rnorm) -importFrom(stats,runif) importFrom(stats,sd) importFrom(stats,terms) importFrom(stats,update) importFrom(stats,var) -importFrom(stats,vcov) -importFrom(stringr,str_remove_all) -importFrom(stringr,str_replace) -importFrom(stringr,str_squish) -importFrom(stringr,str_to_title) -importFrom(stringr,str_trim) -importFrom(tibble,rownames_to_column) -importFrom(utils,capture.output) importFrom(utils,combn) -importFrom(utils,data) importFrom(utils,head) importFrom(utils,tail) diff --git a/R/assess.R b/R/assess.R new file mode 100644 index 0000000..85a3335 --- /dev/null +++ b/R/assess.R @@ -0,0 +1,114 @@ +#' Compare a patient's score to a control group +#' +#' Compare a patient's score to a control group. +#' +#' @param patient Single value (patient's score). +#' @param controls Vector of values (control's scores). +#' @param mean Mean of the control sample. +#' @param sd SD of the control sample. +#' @param n Size of the control sample. +#' @param CI Credible interval bounds. +#' @param treshold Significance treshold. +#' @param iter Number of iterations. +#' @param color_controls Color of the controls distribution. +#' @param color_CI Color of CI distribution. +#' @param color_score Color of the line representing the patient's score. +#' @param color_size Size of the line representing the patient's score. +#' @param alpha_controls Alpha of the CI distribution. +#' @param alpha_CI lpha of the controls distribution. +#' @param verbose Print possible warnings. +#' +#' @return output +#' +#' @examples +#' result <- assess(patient = 124, mean = 100, sd = 15, n = 100) +#' print(result) +#' plot(result) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @details Until relatively recently the standard way of testing for a difference between a case and controls was to convert the case’s score to a z score using the control sample mean and standard deviation (SD). If z was less than -1.645 (i.e., below 95% of the controls) then it was concluded that the case was significantly lower than controls. However, this method has serious disadvantages (Crawford and Garthwaite, 2012). +#' +#' @importFrom stats ecdf +#' @import ggplot2 +#' @import dplyr +#' @export +assess <- function(patient, + mean = 0, + sd = 1, + n = NULL, + controls = NULL, + CI = 95, + treshold = 0.05, + iter = 10000, + color_controls = "#2196F3", + color_CI = "#E91E63", + color_score = "black", + color_size = 2, + alpha_controls = 1, + alpha_CI = 0.8, + verbose = TRUE) { + if (is.null(controls)) { + if (is.null(n)) { + if (verbose == TRUE) { + warning("Sample size (n) not provided, thus set to 1000.") + } + n <- 1000 + } + } + + + + + # If score is list + if (length(patient) > 1) { + if (verbose == TRUE) { + warning("Multiple scores were provided. Returning a list of results.") + } + results <- list() + for (i in seq_len(length(patient))) { + results[[i]] <- crawford.test( + patient[i], + controls, + mean, + sd, + n, + CI, + treshold, + iter, + color_controls, + color_CI, + color_score, + color_size, + alpha_controls, + alpha_CI + ) + return(results) + } + } else { + result <- crawford.test( + patient, + controls, + mean, + sd, + n, + CI, + treshold, + iter, + color_controls, + color_CI, + color_score, + color_size, + alpha_controls, + alpha_CI + ) + return(result) + } +} + + + + + + + + diff --git a/R/crawford.test.R b/R/crawford.test.R new file mode 100644 index 0000000..c904d26 --- /dev/null +++ b/R/crawford.test.R @@ -0,0 +1,290 @@ +#' Crawford-Garthwaite (2007) Bayesian test for single-case analysis. +#' +#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2007) demonstrate that the Bayesian test is a better approach than other commonly-used alternatives. +#' . +#' +#' @param patient Single value (patient's score). +#' @param controls Vector of values (control's scores). +#' @param mean Mean of the control sample. +#' @param sd SD of the control sample. +#' @param n Size of the control sample. +#' @param CI Credible interval bounds. +#' @param treshold Significance treshold. +#' @param iter Number of iterations. +#' @param color_controls Color of the controls distribution. +#' @param color_CI Color of CI distribution. +#' @param color_score Color of the line representing the patient's score. +#' @param color_size Size of the line representing the patient's score. +#' @param alpha_controls Alpha of the CI distribution. +#' @param alpha_CI lpha of the controls distribution. +#' +#' +#' @details The p value obtained when this test is used to test significance also simultaneously provides a point estimate of the abnormality of the patient’s score; for example if the one-tailed probability is .013 then we know that the patient’s score is significantly (p < .05) below the control mean and that it is estimated that 1.3% of the control population would obtain a score lower than the patient’s. As for the credible interval interpretation, we could say that there is a 95% probability that the true level of abnormality of the patient’s score lies within the stated limits, or that There is 95% confidence that the percentage of people who have a score lower than the patient’s is between 0.01% and 6.66%. +#' +#' @examples +#' library(psycho) +#' +#' crawford.test(patient = 125, mean = 100, sd = 15, n = 100) +#' plot(crawford.test(patient = 80, mean = 100, sd = 15, n = 100)) +#' +#' crawford.test(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' test <- crawford.test(patient = 7, controls = c(0, -2, 5, -6, 0, 3, -4, -2)) +#' plot(test) +#' @author Dominique Makowski +#' +#' @importFrom stats pnorm var approx rchisq rnorm density +#' @importFrom scales rescale +#' @import ggplot2 +#' @export +crawford.test <- function(patient, + controls = NULL, + mean = NULL, + sd = NULL, + n = NULL, + CI = 95, + treshold = 0.1, + iter = 10000, + color_controls = "#2196F3", + color_CI = "#E91E63", + color_score = "black", + color_size = 2, + alpha_controls = 1, + alpha_CI = 0.8) { + if (is.null(controls)) { + # Check if a parameter is null + if (length(c(mean, sd, n)) != 3) { + stop("Please provide either controls or mean, sd and n.") + } + sample_mean <- mean + sample_sd <- sd + sample_var <- sd^2 + } else { + sample_mean <- mean(controls) + sample_var <- var(controls) + sample_sd <- sd(controls) + n <- length(controls) + } + degfree <- n - 1 + + + # Computation ------------------------------------------------------------- + + + pvalues <- c() + for (i in 1:iter) { + # step 1 + psi <- rchisq(1, df = degfree, ncp = 0) + o <- (n - 1) * sample_var / psi + + # step 2 + z <- rnorm(1, 0, 1) + u <- sample_mean + z * sqrt((o / n)) + + # step 3 + z_patient <- (patient - u) / sqrt(o) + p <- 2 * (1 - pnorm(abs(z_patient), lower.tail = TRUE)) # One-tailed p-value + pvalues <- c(pvalues, p) + } + + + # Point estimates --------------------------------------------------------- + + z_score <- (patient - sample_mean) / sample_sd + perc <- percentile(z_score) + + pvalues <- pvalues / 2 + p <- mean(pvalues) + ci <- bayestestR::hdi(pvalues, ci = CI / 100) + + # Text -------------------------------------------------------------------- + + p_interpretation <- ifelse(p < treshold, " significantly ", " not significantly ") + direction <- ifelse(patient - sample_mean < 0, " lower than ", " higher than ") + + + text <- paste0( + "The Bayesian test for single case assessment (Crawford, Garthwaite, 2007) suggests that the patient's score (Raw = ", + insight::format_value(patient), + ", Z = ", + insight::format_value(z_score), + ", percentile = ", + insight::format_value(perc), + ") is", + p_interpretation, + "different from the controls (M = ", + insight::format_value(sample_mean), + ", SD = ", + insight::format_value(sample_sd), + ", p ", + parameters::format_p(p), + ").", + " The patient's score is", + direction, + insight::format_value((1 - p) * 100), + "% (", + parameters::format_ci(ci$CI_low, ci$CI_high, ci = CI / 100), + ") of the control population." + ) + + + + # Store values ------------------------------------------------------------ + + values <- list( + patient_raw = patient, + patient_z = z_score, + patient_percentile = perc, + controls_mean = sample_mean, + controls_sd = sample_sd, + controls_var = sample_var, + controls_sd = sample_sd, + controls_n = n, + text = text, + p = p, + CI_lower = ci$CI_low, + CI_higher = ci$CI_high + ) + + summary <- data.frame( + controls_mean = sample_mean, + controls_sd = sample_sd, + controls_n = n, + p = p, + CI_lower = ci$CI_low, + CI_higher = ci$CI_high + ) + + if (is.null(controls)) { + controls <- bayestestR::distribution_normal(n, sample_mean, sample_sd) + } + + + # Plot -------------------------------------------------------------------- + if (patient - sample_mean < 0) { + uncertainty <- percentile_to_z(pvalues * 100) + } else { + uncertainty <- percentile_to_z((1 - pvalues) * 100) + } + + + + + plot <- bayestestR::distribution_normal(length(uncertainty), 0, 1) %>% + density() %>% + as.data.frame() %>% + mutate_(y = "y/max(y)") %>% + mutate(distribution = "Control") %>% + rbind(uncertainty %>% + density() %>% + as.data.frame() %>% + mutate_(y = "y/max(y)") %>% + mutate(distribution = "Uncertainty")) %>% + mutate_(x = "scales::rescale(x, from=c(0, 1), to = c(sample_mean, sample_mean+sample_sd))") %>% + ggplot(aes_string(x = "x", ymin = 0, ymax = "y")) + + geom_ribbon(aes_string(fill = "distribution", alpha = "distribution")) + + geom_vline(xintercept = patient, colour = color_score, size = color_size) + + scale_fill_manual(values = c(color_controls, color_CI)) + + scale_alpha_manual(values = c(alpha_controls, alpha_CI)) + + xlab("\nScore") + + ylab("") + + theme_minimal() + + theme( + legend.position = "none", + axis.ticks.y = element_blank(), + axis.text.y = element_blank() + ) + + + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + return(output) +} + + + + + + + + + + +#' Crawford-Howell (1998) frequentist t-test for single-case analysis. +#' +#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. +#' . +#' +#' @param patient Single value (patient's score). +#' @param controls Vector of values (control's scores). +#' +#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the patient is different from the control group. +#' +#' @examples +#' library(psycho) +#' +#' crawford.test.freq(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' crawford.test.freq(patient = 7, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' @author Dan Mirman, Dominique Makowski +#' +#' @importFrom stats pt sd +#' @export +crawford.test.freq <- function(patient, controls) { + tval <- (patient - mean(controls)) / (sd(controls) * sqrt((length(controls) + 1) / length(controls))) + + degfree <- length(controls) - 1 + + pval <- 2 * (1 - pt(abs(tval), df = degfree)) # One-tailed p-value + + # One-tailed p value + if (pval > .05 & pval / 2 < .05) { + one_tailed <- paste0( + " However, the null hypothesis of no difference can be rejected at a one-tailed 5% significance level (one-tailed p ", + parameters::format_p(pval / 2), + ")." + ) + } else { + one_tailed <- "" + } + + + p_interpretation <- ifelse(pval < 0.05, " significantly ", " not significantly ") + t_interpretation <- ifelse(tval < 0, " lower than ", " higher than ") + + text <- paste0( + "The Crawford-Howell (1998) t-test suggests that the patient's score (", + insight::format_value(patient), + ") is", + p_interpretation, + "different from the controls (M = ", + insight::format_value(mean(controls)), + ", SD = ", + insight::format_value(sd(controls)), + ", t(", + degfree, + ") = ", + insight::format_value(tval), + ", p ", + parameters::format_p(pval), + ").", + one_tailed, + " The patient's score is", + t_interpretation, + insight::format_value((1 - pval) * 100), + "% of the control population." + ) + + values <- list( + text = text, + p = pval, + df = degfree, + t = tval + ) + summary <- data.frame(t = tval, df = degfree, p = pval) + plot <- "Not available yet" + + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + output +} diff --git a/R/crawford_dissociation.test.R b/R/crawford_dissociation.test.R new file mode 100644 index 0000000..2e46b8c --- /dev/null +++ b/R/crawford_dissociation.test.R @@ -0,0 +1,93 @@ + + + +#' Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks. +#' +#' Assessing dissociation between processes is a fundamental part of clinical neuropsychology. However, while the detection of suspected impairments is a fundamental feature of single-case studies, evidence of an impairment on a given task usually becomes of theoretical interest only if it is observed in the context of less impaired or normal performance on other tasks. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test for dissociation is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. +#' . +#' +#' @param case_X Single value (patient's score on test X). +#' @param case_Y Single value (patient's score on test Y). +#' @param controls_X Vector of values (control's scores of X). +#' @param controls_Y Vector of values (control's scores of Y). +#' @param verbose True or False. Prints the interpretation text. +#' +#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the dissociation between test X and test Y is significant. +#' +#' @examples +#' library(psycho) +#' +#' case_X <- 142 +#' case_Y <- 7 +#' controls_X <- c(100, 125, 89, 105, 109, 99) +#' controls_Y <- c(7, 8, 9, 6, 7, 10) +#' +#' crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y) +#' @author Dominique Makowski +#' +#' @importFrom stats sd pt cor +#' @export +crawford_dissociation.test <- function(case_X, case_Y, controls_X, controls_Y, verbose = TRUE) { + X_mean <- mean(controls_X) + X_sd <- sd(controls_X) + Y_mean <- mean(controls_Y) + Y_sd <- sd(controls_Y) + r <- cor(controls_X, controls_Y) + n <- length(controls_X) + degfree <- n - 1 + + case_X_Z <- (case_X - X_mean) / X_sd + case_Y_Z <- (case_Y - Y_mean) / Y_sd + + tval <- (case_X_Z - case_Y_Z) / sqrt((2 - 2 * r) * ((n + 1) / n)) + + pval <- 2 * (1 - pt(abs(tval), df = degfree)) # two-tailed p-value + + + + + + p_interpretation <- ifelse(pval < 0.05, " a significant ", " no ") + p_interpretation2 <- ifelse(pval < 0.05, " ", " not ") + z_interpretation <- ifelse(tval < 0, " below ", " above ") + pop_interpretation <- ifelse(tval < 0, " above ", " below ") + + if (abs(case_X_Z) > abs(case_Y_Z)) { + var_interpretation1 <- "test X" + var_interpretation2 <- "test Y" + } else { + var_interpretation1 <- "test Y" + var_interpretation2 <- "test X" + } + + text <- paste0( + "The Crawford-Howell (1998) t-test suggests", + p_interpretation, + "dissociation between test X and test Y (t(", + degfree, + ") = ", + insight::format_value(tval), + ", p ", + parameters::format_p(pval), + "). The patient's score on ", + var_interpretation1, + " is", + p_interpretation2, + "significantly altered compared to its score on ", + var_interpretation2, + "." + ) + + + result <- data.frame(t = tval, df = degfree, p = pval) + + if (verbose == TRUE) { + cat(paste0(text, "\n\n")) + } + + return(result) +} + + + + diff --git a/R/deprecated.R b/R/deprecated.R index 67ac5ec..1c2b8c2 100644 --- a/R/deprecated.R +++ b/R/deprecated.R @@ -1,349 +1,4 @@ -#' Analyze aov and anova objects -#' -#' Analyze aov and anova objects. -#' -#' @param x aov object. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_omega_sq]{interpret_omega_sq}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' df <- psycho::affective -#' -#' x <- aov(df$Tolerating ~ df$Salary) -#' x <- aov(df$Tolerating ~ df$Salary * df$Sex) -#' -#' x <- anova(lm(df$Tolerating ~ df$Salary * df$Sex)) -#' -#' -#' summary(analyze(x)) -#' print(analyze(x)) -#' -#' df <- psycho::emotion %>% -#' mutate(Recall = ifelse(Recall == TRUE, 1, 0)) %>% -#' group_by(Participant_ID, Emotion_Condition) %>% -#' summarise(Recall = sum(Recall) / n()) -#' -#' x <- aov(Recall ~ Emotion_Condition + Error(Participant_ID), data = df) -#' x <- anova(lmerTest::lmer(Recall ~ Emotion_Condition + (1 | Participant_ID), data = df)) -#' analyze(x) -#' summary(x) -#' } -#' -#' @references -#' \itemize{ -#' \item{Levine, T. R., & Hullett, C. R. (2002). Eta squared, partial eta squared, and misreporting of effect size in communication research. Human Communication Research, 28(4), 612-625.} -#' \item{Pierce, C. A., Block, R. A., & Aguinis, H. (2004). Cautionary note on reporting eta-squared values from multifactor ANOVA designs. Educational and psychological measurement, 64(6), 916-924.} -#' } -#' -#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/os2 -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import broom -#' -#' @export -analyze.aov <- function(x, effsize_rules = "field2013", ...) { - if (!"aov" %in% class(x)) { - if (!"Residuals" %in% row.names(x)) { - if (!is.null(x$Within)) { - x <- x$Within - message("(Repeated measures ANOVAs are bad, you should use mixed-models...)") - } else { - return(.analyze.anova_lmer(x)) - } - } - } else { - if (!is.null(x$Within)) { - x <- x$Within - message("(Repeated measures ANOVAs are bad, you should use mixed-models...)") - } - } - - - - - # Processing - # ------------- - - - # Effect Size - omega <- tryCatch({ - omega_sq(x, partial = TRUE) - }, warning = function(w) { - stop("I believe there are within and between subjects variables that caused the error. You should REALLY use mixed-models.") - }) - - - - - all_values <- x %>% - broom::tidy() %>% - dplyr::full_join(data.frame("Omega" = omega) %>% - tibble::rownames_to_column("term"), by = "term") %>% - mutate_("Effect_Size" = "interpret_omega_sq(Omega, rules = 'field2013')") %>% - rename_( - "Effect" = "term", - "Sum_Squares" = "sumsq", - "Mean_Square" = "meansq", - "F" = "statistic", - "p" = "p.value" - ) - - varnames <- all_values$Effect - df_residuals <- all_values[all_values$Effect == "Residuals", ]$df - - values <- list() - for (var in varnames) { - values[[var]] <- list() - current_values <- dplyr::filter_(all_values, "Effect == var") - values[[var]]$df <- current_values$df - values[[var]]$Sum_Squares <- current_values$Sum_Squares - values[[var]]$Mean_Square <- current_values$Mean_Square - values[[var]]$F <- current_values$F - values[[var]]$p <- current_values$p - values[[var]]$Omega <- current_values$Omega - values[[var]]$Effect_Size <- current_values$Effect_Size - - if (var != "Residuals") { - if (current_values$p < .05) { - significance <- "significant" - } else { - significance <- "not significant" - } - - if (grepl(":", var)) { - effect <- "interaction between" - varname <- stringr::str_replace_all(var, ":", " and ") - } else { - varname <- var - effect <- "effect of" - } - - values[[var]]$text <- paste0( - "The ", - effect, - " ", - varname, - " is ", - significance, - " (F(", - current_values$df, - ", ", - df_residuals, - ") = ", - format_digit(current_values$F), - ", p ", - format_p(current_values$p, stars = FALSE), - ") and can be considered as ", - current_values$Effect_Size, - " (Partial Omega-squared = ", - format_digit(current_values$Omega), - ")." - ) - } - } - - # Summary - # ------------- - summary <- all_values - - # Text - # ------------- - text <- c() - for (var in varnames[varnames != "Residuals"]) { - text <- c(text, paste(" -", values[[var]]$text)) - } - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - -#' @export -analyze.anova <- analyze.aov - -#' @export -analyze.aovlist <- analyze.aov - - - -#' @keywords internal -.analyze.anova_lmer <- function(x) { - if (!"NumDF" %in% colnames(x)) { - stop("Cannot analyze the anova from lme4. Please refit the model using lmerTest.") - } - - summary <- x %>% - as.data.frame() %>% - tibble::rownames_to_column("term") %>% - rename_( - "Effect" = "term", - "df" = "NumDF", - "df_Residuals" = "DenDF", - "Sum_Squares" = "`Sum Sq`", - "Mean_Square" = "`Mean Sq`", - "F" = "`F value`", - "p" = "`Pr(>F)`" - ) %>% - select_("Effect", "df", "df_Residuals", "Sum_Squares", "Mean_Square", "F", "p") - - varnames <- summary$Effect - - values <- list() - for (var in varnames) { - values[[var]] <- list() - current_values <- dplyr::filter_(summary, "Effect == var") - values[[var]]$df <- current_values$df - values[[var]]$df_Residuals <- current_values$df_Residuals - values[[var]]$Sum_Squares <- current_values$Sum_Squares - values[[var]]$Mean_Square <- current_values$Mean_Square - values[[var]]$F <- current_values$F - values[[var]]$p <- current_values$p - # values[[var]]$Omega <- current_values$Omega - # values[[var]]$Effect_Size <- current_values$Effect_Size - - if (current_values$p < .05) { - significance <- "significant" - } else { - significance <- "not significant" - } - - if (grepl(":", var)) { - effect <- "interaction between" - varname <- stringr::str_replace_all(var, ":", " and ") - } else { - varname <- var - effect <- "effect of" - } - - values[[var]]$text <- paste0( - "The ", - effect, - " ", - varname, - " is ", - significance, - " (F(", - current_values$df, - ", ", - format_digit(current_values$df_Residuals, 0), - ") = ", - format_digit(current_values$F), - ", p ", - format_p(current_values$p, stars = FALSE), - ")." - ) - } - - - # Text - # ------------- - text <- c() - for (var in varnames[varnames != "Residuals"]) { - text <- c(text, paste(" -", values[[var]]$text)) - } - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - -#' Partial Omega Squared. -#' -#' Partial Omega Squared. -#' -#' @param x aov object. -#' @param partial Return partial omega squared. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' -#' x <- aov(df$Tolerating ~ df$Salary) -#' x <- aov(df$Tolerating ~ df$Salary * df$Sex) -#' -#' omega_sq(x) -#' @seealso http://stats.stackexchange.com/a/126520 -#' -#' @author Arnoud Plantinga -#' @importFrom stringr str_trim -#' @export -omega_sq <- function(x, partial = TRUE) { - if ("aov" %in% class(x)) { - summary_aov <- summary(x)[[1]] - } else { - summary_aov <- x - } - residRow <- nrow(summary_aov) - dfError <- summary_aov[residRow, 1] - msError <- summary_aov[residRow, 3] - nTotal <- sum(summary_aov$Df) - dfEffects <- summary_aov[1:{ - residRow - 1 - }, 1] - ssEffects <- summary_aov[1:{ - residRow - 1 - }, 2] - msEffects <- summary_aov[1:{ - residRow - 1 - }, 3] - ssTotal <- rep(sum(summary_aov[1:residRow, 2]), 3) - Omegas <- abs((ssEffects - dfEffects * msError) / (ssTotal + msError)) - names(Omegas) <- stringr::str_trim(rownames(summary_aov)[1:{ - residRow - 1 - }]) - - partOmegas <- abs((dfEffects * (msEffects - msError)) / - (ssEffects + (nTotal - dfEffects) * msError)) - names(partOmegas) <- stringr::str_trim(rownames(summary_aov)[1:{ - residRow - 1 - }]) - - if (partial == TRUE) { - return(partOmegas) - } else { - return(Omegas) - } -} - - - - - - @@ -378,127 +33,6 @@ is.psychobject <- function(x) inherits(x, "psychobject") -#' Create a reference grid. -#' -#' Create a reference grid. -#' -#' @param df The dataframe. -#' @param target String or list of strings to indicate target columns. Can be "all". -#' @param length.out Length of numeric target variables. -#' @param factors Type of summary for factors. Can be "combination" or "reference". -#' @param numerics Type of summary for numerics Can be "combination", any function ("mean", "median", ...) or a value. -#' @param na.rm Remove NaNs. -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' newdata <- refdata(df, target = "Sex") -#' newdata <- refdata(df, target = "Sex", factors = "combinations") -#' newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), length.out = 3) -#' newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), numerics = 0) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom purrr keep -#' @import tidyr -#' @export -refdata <- function(df, target = "all", length.out = 10, factors = "reference", numerics = "mean", na.rm = TRUE) { - - # Target - if (all(target == "all") | ncol(df) == 1) { - return(.refdata_target(target = df[c(names(df))], length.out = length.out)) - } - - target_df <- .refdata_target(target = df[c(target)], length.out = length.out) - - # Rest - df_rest <- df[!names(df) %in% c(target)] - var_order <- names(df_rest) - - facs <- purrr::discard(df_rest, is.numeric) - facs <- mutate_all(facs, as.factor) - nums <- purrr::keep(df_rest, is.numeric) - - - smart_summary <- function(x, numerics) { - if (na.rm == TRUE) x <- na.omit(x) - - if (is.numeric(x)) { - fun <- paste0(numerics, "(x)") - out <- eval(parse(text = fun)) - } else if (is.factor(x)) { - out <- levels(x)[1] - } else if (is.character(x)) { - out <- unique(x)[1] - } else if (is.logical(x)) { - out <- unique(x)[1] - } else { - warning("Argument is not numeric nor factor: returning NA.") - out <- NA - } - return(out) - } - - - if (factors == "reference") { - facs <- dplyr::summarise_all(facs, smart_summary) - } else { - facs <- tidyr::expand_(facs, names(facs)) - } - - if (is.numeric(numerics)) { - nums[1, ] <- numerics - nums <- nums[1, ] - } else if (numerics == "combination") { - nums <- tidyr::expand_(nums, names(nums)) - } else { - nums <- dplyr::summarise_all(nums, smart_summary, numerics) - } - - - if (nrow(facs) == 0 | ncol(facs) == 0) { - refrest <- nums - } else if (nrow(nums) == 0 | ncol(nums) == 0) { - refrest <- facs - } else { - refrest <- merge(facs, nums) - } - - refrest <- refrest[var_order] - refdata <- merge(target_df, refrest) - - return(refdata) -} - - - - - - - - - - -#' @keywords internal -.refdata_target <- function(target, length.out = 10) { - at_vars <- names(target) - at_df <- data.frame() - for (var in at_vars) { - ref_var <- .refdata_var(x = target[[var]], length.out = length.out, varname = var) - if (nrow(at_df) == 0) { - at_df <- ref_var - } else { - at_df <- merge(at_df, ref_var) - } - } - return(at_df) -} - - - - - - @@ -511,109 +45,64 @@ refdata <- function(df, target = "all", length.out = 10, factors = "reference", -#' @keywords internal -.refdata_var <- function(x, length.out = 10, varname = NULL) { - if (is.numeric(x)) { - out <- data.frame(seq(min(x, na.rm = TRUE), - max(x, na.rm = TRUE), - length.out = length.out - )) - } else if (is.factor(x)) { - out <- data.frame(levels(x)) - } else if (is.character(x)) { - x <- as.factor(x) - out <- data.frame(levels(x)) - } else { - warning("Argument is not numeric nor factor: returning NA.") - out <- NA - return() - } - - if (is.null(varname)) { - names(out) <- "x" - } else { - names(out) <- varname - } - return(out) -} - -#' Remove outliers. +#' Simulates data for single or multiple regression. #' -#' Removes outliers (with the z-score method only for now). +#' Simulates data for single or multiple regression. #' -#' @param df Dataframe. -#' @param target String or list of strings of variables -#' @param threshold The z-score value (deviation of SD) by which to consider outliers. -#' @param direction Can be "both", "upper" or "lower". +#' @param coefs Desired theorethical coefs. Can be a single value or a list. +#' @param sample Desired sample size. +#' @param error The error (standard deviation of gaussian noise). #' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' @examples +#' library(psycho) +#' +#' data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) +#' fit <- lm(y ~ ., data = data) +#' coef(fit) +#' @details See https://stats.stackexchange.com/questions/59062/multiple-linear-regression-simulation +#' +#' @author TPArrow #' #' @export -remove_outliers <- function(df, target, threshold = qnorm(0.95), direction = "both") { - for (var in c(target)) { - df <- .remove_outliers(df, var, threshold, direction) - } - return(df) -} - - +simulate_data_regression <- function(coefs = 0.5, sample = 100, error = 0) { + # Prevent error + coefs[coefs == 0] <- 0.01 + y <- rnorm(sample, 0, 1) + n_var <- length(coefs) + X <- scale(matrix(rnorm(sample * (n_var), 0, 1), ncol = n_var)) + X <- cbind(y, X) -#' @keywords internal -.remove_outliers <- function(df, target, threshold = qnorm(0.95), direction = "both") { - df <- df %>% - mutate_("outlier_criterion" = target) %>% - standardize(subset = "outlier_criterion") - if (direction %in% c("both", "upper")) { - df <- df %>% - filter_("outlier_criterion <= threshold") - } - if (direction %in% c("both", "lower")) { - df <- df %>% - filter_("outlier_criterion >= -threshold") - } + # find the current correlation matrix + cor_0 <- var(X) - df <- df %>% - select_("-outlier_criterion") + # cholesky decomposition to get independence + chol_0 <- solve(chol(cor_0)) - return(df) -} + X <- X %*% chol_0 + # create new correlation structure (zeros can be replaced with other r vals) + coefs_structure <- diag(x = 1, nrow = n_var + 1, ncol = n_var + 1) + coefs_structure[-1, 1] <- coefs + coefs_structure[1, -1] <- coefs + X <- X %*% chol(coefs_structure) * sd(y) + mean(y) + X <- X[, -1] + # Add noise + y <- y + rnorm(sample, 0, error) + data <- data.frame(X) + names(data) <- paste0("V", 1:n_var) + data$y <- as.vector(y) -#' Perfect Normal Distribution. -#' -#' Generates a sample of size n with a near-perfect normal distribution. -#' -#' @param n number of observations. If length(n) > 1, the length is taken to be the number required. -#' @param mean vector of means. -#' @param sd vector of standard deviations. -#' @param method "qnorm" or "average". -#' @param iter number of iterations (precision). -#' -#' @examples -#' library(psycho) -#' x <- rnorm_perfect(10) -#' plot(density(x)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats rnorm -#' @export -rnorm_perfect <- function(n, mean = 0, sd = 1, method = "qnorm", iter = 10000) { - if (method == "average") { - x <- rowMeans(replicate(iter, sort(rnorm(n, mean, sd)))) - } else { - x <- qnorm(seq(1 / n, 1 - 1 / n, length.out = n), mean, sd) - } - return(x) + return(data) } @@ -621,8658 +110,217 @@ rnorm_perfect <- function(n, mean = 0, sd = 1, method = "qnorm", iter = 10000) { -#' Region of Practical Equivalence (ROPE) -#' -#' Compute the proportion of a posterior distribution that lies within a region of practical equivalence. -#' -#' @param posterior Posterior Distribution. -#' @param bounds Rope lower and higher bounds. -#' @param CI The credible interval to use. -#' @param overlap Compute rope overlap (EXPERIMENTAL). -#' -#' -#' @return list containing rope indices -#' -#' @examples -#' library(psycho) -#' -#' posterior <- rnorm(1000, 0, 0.01) -#' results <- rope(posterior) -#' results$decision -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -rope <- function(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = FALSE) { - - - # Basic rope -------------------------------------------------------------- - HDI_area <- HDI(posterior, CI / 100) - HDI_area <- posterior[dplyr::between( - posterior, - HDI_area$values$HDImin, - HDI_area$values$HDImax - )] - area_within <- HDI_area[dplyr::between(HDI_area, bounds[1], bounds[2])] - area_outside <- HDI_area[!dplyr::between(HDI_area, bounds[1], bounds[2])] - p_within <- length(area_within) / length(posterior) - p_outside <- length(area_outside) / length(posterior) - rope_decision <- ifelse(p_within == 0, "Accept", - ifelse(p_outside == 0, "Reject", "Undecided") - ) - # Rope Overlap ------------------------------------------------------------ - if (overlap == TRUE) { - sd <- abs(bounds[1] - bounds[2]) / 2 - sd <- sd / 3 - norm <- rnorm_perfect(length(posterior), 0, sd) - rope_overlap <- overlap(posterior, norm) * 100 - output <- list(rope_decision = rope_decision, rope_probability = p_within, rope_overlap = rope_overlap) - } else { - output <- list(rope_decision = rope_decision, rope_probability = p_within) - } - return(output) -} +# analyze.blavaan <- function(x, CI = 90, standardize = FALSE, ...) { +# fit <- x +# +# +# # Processing +# # ------------- +# values <- list() +# values$CI <- CI +# +# # Fit measures +# values$Fit_Measures <- interpret_blavaan(fit) +# +# +# # Text +# # ------------- +# computations <- .get_info_computations(fit) +# fitmeasures <- values$Fit_Measures$text +# text <- paste0( +# "A Bayesian model was fitted (", +# computations, +# "). The fit indices are as following: ", +# fitmeasures +# ) +# +# # Summary +# # ------------- +# summary <- .summary_blavaan(fit, CI = CI, standardize = standardize) +# +# # Plot +# # ------------- +# plot <- "Use `get_graph` in association with ggraph." +# +# output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) +# +# class(output) <- c("psychobject", "list") +# return(output) +# } + + + + +# .get_info_computations <- function(fit) { +# chains <- blavaan::blavInspect(fit, "n.chains") +# sample <- fit@external$sample +# warmup <- fit@external$burnin +# text <- paste0( +# chains, +# " chains, each with iter = ", +# sample, +# "; warmup = ", +# warmup +# ) +# return(text) +# } + + + + +# .process_blavaan <- function(fit, standardize = FALSE, CI = 90) { +# # Get relevant rows +# PE <- parameterEstimates(fit, +# se = FALSE, ci = FALSE, remove.eq = FALSE, remove.system.eq = TRUE, +# remove.ineq = FALSE, remove.def = FALSE, +# add.attributes = TRUE +# ) +# if (!("group" %in% names(PE))) PE$group <- 1 +# newpt <- fit@ParTable +# pte2 <- which(newpt$free > 0) +# relevant_rows <- match( +# with(newpt, paste(lhs[pte2], op[pte2], rhs[pte2], group[pte2], sep = "")), +# paste(PE$lhs, PE$op, PE$rhs, PE$group, sep = "") +# ) +# +# # Priors +# priors <- rep(NA, nrow(PE)) +# priors[relevant_rows] <- newpt$prior[pte2] +# priors[is.na(PE$prior)] <- "" +# +# +# +# +# # Posterior +# if (standardize == FALSE) { +# posteriors <- blavaan::blavInspect(fit, "draws") %>% +# as.matrix() %>% +# as.data.frame() +# names(posteriors) <- names(lavaan::coef(fit)) +# } else { +# posteriors <- blavaan::standardizedposterior(fit) %>% +# as.data.frame() +# } +# +# +# +# # Effects +# MPE <- c() +# Median <- c() +# MAD <- c() +# Effect <- c() +# CI_lower <- c() +# CI_higher <- c() +# for (effect in names(posteriors)) { +# posterior <- posteriors[[effect]] +# Effect <- c(Effect, effect) +# MPE <- c(MPE, mpe(posterior)$MPE) +# Median <- c(Median, median(posterior)) +# MAD <- c(MAD, mad(posterior)) +# +# CI_values <- HDI(posterior, prob = CI / 100) +# CI_lower <- c(CI_lower, CI_values$values$HDImin) +# CI_higher <- c(CI_higher, CI_values$values$HDImax) +# } +# +# if (standardize == FALSE) { +# Effects <- rep(NA, nrow(PE)) +# Effects[relevant_rows] <- Effect +# MPEs <- rep(NA, nrow(PE)) +# MPEs[relevant_rows] <- MPE +# Medians <- rep(NA, nrow(PE)) +# Medians[relevant_rows] <- Median +# MADs <- rep(NA, nrow(PE)) +# MADs[relevant_rows] <- MAD +# CI_lowers <- rep(NA, nrow(PE)) +# CI_lowers[relevant_rows] <- CI_lower +# CI_highers <- rep(NA, nrow(PE)) +# CI_highers[relevant_rows] <- CI_higher +# } else { +# Effects <- Effect +# MPEs <- MPE +# Medians <- Median +# MADs <- MAD +# CI_lowers <- CI_lower +# CI_highers <- CI_higher +# } +# +# data <- data.frame( +# "Effect" = Effects, +# "Median" = Medians, +# "MAD" = MADs, +# "MPE" = MPEs, +# "CI_lower" = CI_lowers, +# "CI_higher" = CI_highers, +# "Prior" = priors +# ) +# +# return(data) +# } +# .summary_blavaan <- function(fit, CI = 90, standardize = FALSE) { +# solution <- lavaan::parameterEstimates(fit, se = TRUE, ci = TRUE, standardized = FALSE, level = CI / 100) +# +# solution <- solution %>% +# rename( +# "From" = "rhs", +# "To" = "lhs", +# "Operator" = "op", +# "Coef" = "est", +# "SE" = "se", +# "CI_lower" = "ci.lower", +# "CI_higher" = "ci.upper" +# ) %>% +# mutate(Type = dplyr::case_when( +# Operator == "=~" ~ "Loading", +# Operator == "~" ~ "Regression", +# Operator == "~~" ~ "Correlation", +# TRUE ~ NA_character_ +# )) %>% +# select(one_of(c("To", "Operator", "From", "Type"))) %>% +# mutate_("Effect" = "as.character(paste0(To, Operator, From))") %>% +# full_join(.process_blavaan(fit, CI = CI, standardize = standardize) %>% +# mutate_("Effect" = "as.character(Effect)"), by = "Effect") %>% +# select_("-Effect") %>% +# mutate_( +# "Median" = "replace_na(Median, 1)", +# "MAD" = "replace_na(MAD, 0)", +# "MPE" = "replace_na(MPE, 100)" +# ) %>% +# select(one_of(c("From", "Operator", "To", "Median", "MAD", "CI_lower", "CI_higher", "MPE", "Prior", "Type"))) %>% +# dplyr::filter_("Operator != '~1'") +# +# +# return(solution) +# } -#' Simulates data for single or multiple regression. -#' -#' Simulates data for single or multiple regression. -#' -#' @param coefs Desired theorethical coefs. Can be a single value or a list. -#' @param sample Desired sample size. -#' @param error The error (standard deviation of gaussian noise). -#' -#' @examples -#' library(psycho) -#' -#' data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) -#' fit <- lm(y ~ ., data = data) -#' coef(fit) -#' analyze(fit) -#' @details See https://stats.stackexchange.com/questions/59062/multiple-linear-regression-simulation -#' -#' @author TPArrow -#' -#' @export -simulate_data_regression <- function(coefs = 0.5, sample = 100, error = 0) { - - # Prevent error - coefs[coefs == 0] <- 0.01 - - y <- rnorm(sample, 0, 1) - - n_var <- length(coefs) - X <- scale(matrix(rnorm(sample * (n_var), 0, 1), ncol = n_var)) - X <- cbind(y, X) - - # find the current correlation matrix - cor_0 <- var(X) - - # cholesky decomposition to get independence - chol_0 <- solve(chol(cor_0)) - - X <- X %*% chol_0 - - # create new correlation structure (zeros can be replaced with other r vals) - coefs_structure <- diag(x = 1, nrow = n_var + 1, ncol = n_var + 1) - coefs_structure[-1, 1] <- coefs - coefs_structure[1, -1] <- coefs - - X <- X %*% chol(coefs_structure) * sd(y) + mean(y) - X <- X[, -1] - - # Add noise - y <- y + rnorm(sample, 0, error) - - data <- data.frame(X) - names(data) <- paste0("V", 1:n_var) - data$y <- as.vector(y) - - return(data) -} - - - - - - -#' Standardize. -#' -#' Standardize objects. See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=standardize.numeric]{standardize.numeric}} -#' \item{\link[=standardize.data.frame]{standardize.data.frame}} -#' \item{\link[=standardize.stanreg]{standardize.stanreg}} -#' \item{\link[=standardize.lm]{standardize.lm}} -#' \item{\link[=standardize.glm]{standardize.glm}} -#' } -#' -#' @param x Object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -standardize <- function(x, ...) { - UseMethod("standardize") -} - - - - - - - - - - - - - - - - - - - - - - - - -#' Standardize (scale and reduce) numeric variables. -#' -#' Standardize (Z-score, "normalize") a vector. -#' -#' @param x Numeric vector. -#' @param normalize Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' standardize(x = c(1, 4, 6, 2)) -#' standardize(x = c(1, 4, 6, 2), normalize = TRUE) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -standardize.numeric <- function(x, normalize = FALSE, ...) { - if (all(is.na(x)) | length(unique(x)) == 2) { - return(x) - } - - if (normalize == FALSE) { - return(as.vector(scale(x, ...))) - } else { - return(as.vector((x - min(x, na.rm = TRUE)) / diff(range(x, na.rm = TRUE), na.rm = TRUE))) - } -} - - - - - - - - - - - - - - - - - - -#' Standardize (scale and reduce) Dataframe. -#' -#' Selects numeric variables and standardize (Z-score, "normalize") them. -#' -#' @param x Dataframe. -#' @param subset Character or list of characters of column names to be -#' standardized. -#' @param except Character or list of characters of column names to be excluded -#' from standardization. -#' @param normalize Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1. -#' @param ... Arguments passed to or from other methods. -#' -#' @return Dataframe. -#' -#' @examples -#' \dontrun{ -#' df <- data.frame( -#' Participant = as.factor(rep(1:25, each = 4)), -#' Condition = base::rep_len(c("A", "B", "C", "D"), 100), -#' V1 = rnorm(100, 30, .2), -#' V2 = runif(100, 3, 5), -#' V3 = rnorm(100, 100, 10) -#' ) -#' -#' dfZ <- standardize(df) -#' dfZ <- standardize(df, except = "V3") -#' dfZ <- standardize(df, except = c("V1", "V2")) -#' dfZ <- standardize(df, subset = "V3") -#' dfZ <- standardize(df, subset = c("V1", "V2")) -#' dfZ <- standardize(df, normalize = TRUE) -#' -#' # Respects grouping -#' dfZ <- df %>% -#' dplyr::group_by(Participant) %>% -#' standardize(df) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @importFrom purrr keep discard -#' @import dplyr -#' @export -standardize.data.frame <- function(x, subset = NULL, except = NULL, normalize = FALSE, ...) { - if (inherits(x, "grouped_df")) { - dfZ <- x %>% dplyr::do_(".standardize_df(., subset=subset, except=except, normalize=normalize, ...)") - } else { - dfZ <- .standardize_df(x, subset = subset, except = except, normalize = normalize, ...) - } - - return(dfZ) -} - - - - - - - - - - - - - - - - - -#' @keywords internal -.standardize_df <- function(x, subset = NULL, except = NULL, normalize = FALSE, ...) { - df <- x - - # Variable order - var_order <- names(df) - - # Keep subset - if (!is.null(subset) && subset %in% names(df)) { - to_keep <- as.data.frame(df[!names(df) %in% c(subset)]) - df <- df[names(df) %in% c(subset)] - } else { - to_keep <- NULL - } - - # Remove exceptions - if (!is.null(except) && except %in% names(df)) { - if (is.null(to_keep)) { - to_keep <- as.data.frame(df[except]) - } else { - to_keep <- cbind(to_keep, as.data.frame(df[except])) - } - - df <- df[!names(df) %in% c(except)] - } - - # Remove non-numerics - dfother <- purrr::discard(df, is.numeric) - dfnum <- purrr::keep(df, is.numeric) - - # Scale - dfnum <- as.data.frame(sapply(dfnum, standardize, normalize = normalize)) - - # Add non-numerics - if (is.null(ncol(dfother))) { - df <- dfnum - } else { - df <- dplyr::bind_cols(dfother, dfnum) - } - - # Add exceptions - if (!is.null(subset) | !is.null(except) && exists("to_keep")) { - df <- dplyr::bind_cols(df, to_keep) - } - - # Reorder - df <- df[var_order] - - return(df) -} - - - - - - - - - - - - - -#' Standardize Posteriors. -#' -#' Compute standardized posteriors from which to get standardized coefficients. -#' -#' @param x A stanreg model. -#' @param method "refit" (default) will entirely refit the model based on standardized data. Can take a long time. Other post-hoc methods are "posterior" (based on estimated SD) or "sample" (based on the sample SD). -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = iris) -#' fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = standardize(iris)) -#' posteriors <- standardize(fit) -#' posteriors <- standardize(fit, method = "posterior") -#' } -#' -#' @author \href{https://github.com/jgabry}{Jonah Gabry}, \href{https://github.com/bgoodri}{bgoodri} -#' -#' @seealso https://github.com/stan-dev/rstanarm/issues/298 -#' -#' @importFrom utils capture.output -#' @export -standardize.stanreg <- function(x, method = "refit", ...) { - fit <- x - - predictors <- get_info(fit)$predictors - predictors <- c("(Intercept)", predictors) - - if (method == "sample") { - # By jgabry - predictors <- all.vars(as.formula(fit$formula)) - outcome <- predictors[[1]] - X <- as.matrix(model.matrix(fit)[, -1]) # -1 to drop column of 1s for intercept - sd_X_over_sd_y <- apply(X, 2, sd) / sd(fit$data[[outcome]]) - beta <- as.matrix(fit, pars = colnames(X)) # posterior distribution of regression coefficients - posteriors_std <- sweep(beta, 2, sd_X_over_sd_y, "*") # multiply each row of b by sd_X_over_sd_y - } else if (method == "posterior") { - # By bgoordi - X <- model.matrix(fit) - # if(preserve_factors == TRUE){ - # X <- as.data.frame(X) - # X[!names(as.data.frame(X)) %in% predictors] <- scale(X[!names(as.data.frame(X)) %in% predictors]) - # X <- as.matrix(X) - # } - sd_X <- apply(X, MARGIN = 2, FUN = sd)[-1] - sd_Y <- apply(rstanarm::posterior_predict(fit), MARGIN = 1, FUN = sd) - beta <- as.matrix(fit)[, 2:ncol(X), drop = FALSE] - posteriors_std <- sweep( - sweep(beta, MARGIN = 2, STATS = sd_X, FUN = `*`), - MARGIN = 1, STATS = sd_Y, FUN = `/` - ) - } else { - useless_output <- capture.output(fit_std <- update(fit, data = standardize(fit$data))) - posteriors_std <- as.data.frame(fit_std) - } - - return(posteriors_std) -} - - - - - - - -#' Standardize Coefficients. -#' -#' Compute standardized coefficients. -#' -#' @param x A linear model. -#' @param method The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "agresti". -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Sex), data = psycho::affective, family = "binomial") -#' -#' standardize(fit) -#' } -#' -#' @author Kamil Barton -#' @importFrom stats model.frame model.response model.matrix -#' -#' @seealso https://think-lab.github.io/d/205/ -#' -#' @export -standardize.glm <- function(x, method = "refit", ...) { - fit <- x - - if (method == "agresti") { - coefs <- MuMIn::coefTable(fit)[, 1:2] - X <- as.matrix(model.matrix(fit)[, -1]) # -1 to drop column of 1s for intercept - sd_X <- sd(X, na.rm = TRUE) - coefs <- coefs * sd_X - } else { - # refit method - data <- get_data(fit) - fit_std <- update(fit, data = standardize(data)) - - - coefs <- MuMIn::coefTable(fit_std)[, 1:2] - } - - coefs <- as.data.frame(coefs) - names(coefs) <- c("Coef_std", "SE_std") - return(coefs) -} - -#' @export -standardize.glmerMod <- standardize.glm - - - -#' Standardize Coefficients. -#' -#' Compute standardized coefficients. -#' -#' @param x A linear model. -#' @param method The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "posthoc". -#' @param partial_sd Logical, if set to TRUE, model coefficients are multiplied by partial SD, otherwise they are multiplied by the ratio of the standard deviations of the independent variable and dependent variable. -#' @param preserve_factors Standardize factors-related coefs only by the dependent variable (i.e., do not standardize the dummies generated by factors). -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' df <- mtcars %>% -#' mutate(cyl = as.factor(cyl)) -#' -#' fit <- lm(wt ~ mpg * cyl, data = df) -#' fit <- lmerTest::lmer(wt ~ mpg * cyl + (1 | gear), data = df) -#' -#' summary(fit) -#' standardize(fit) -#' } -#' -#' @author Kamil Barton -#' @importFrom stats model.frame model.response model.matrix -#' -#' @export -standardize.lm <- function(x, method = "refit", partial_sd = FALSE, preserve_factors = TRUE, ...) { - fit <- x - - if (method == "posthoc") { - coefs <- .standardize_coefs(fit, partial_sd = partial_sd, preserve_factors = preserve_factors) - } else { - data <- get_data(fit) - fit_std <- update(fit, data = standardize(data)) - coefs <- MuMIn::coefTable(fit_std)[, 1:2] - } - - coefs <- as.data.frame(coefs) - names(coefs) <- c("Coef_std", "SE_std") - return(coefs) -} - - -#' @export -standardize.lmerMod <- standardize.lm - - - - - - - - - - - - - - - - - -#' @keywords internal -.partialsd <- - function(x, sd, vif, n, p = length(x) - 1) { - sd * sqrt(1 / vif) * sqrt((n - 1) / (n - p)) - } - - -#' @importFrom stats vcov -#' @keywords internal -.vif <- - function(x) { - v <- vcov(x) - nam <- dimnames(v)[[1L]] - if (dim(v)[1L] < 2L) { - return(structure(rep_len(1, dim(v)[1L]), - names = dimnames(v)[[1L]] - )) - } - if ((ndef <- sum(is.na(MuMIn::coeffs(x)))) > 0L) { - stop(sprintf(ngettext( - ndef, "one coefficient is not defined", - "%d coefficients are not defined" - ), ndef)) - } - o <- attr(model.matrix(x), "assign") - if (any(int <- (o == 0))) { - v <- v[!int, !int, drop = FALSE] - } else { - warning("no intercept: VIFs may not be sensible") - } - d <- sqrt(diag(v)) - rval <- numeric(length(nam)) - names(rval) <- nam - rval[!int] <- diag(solve(v / (d %o% d))) - rval[int] <- 1 - rval - } - - - -#' @importFrom stats nobs vcov -#' @keywords internal -.standardize_coefs <- function(fit, partial_sd = FALSE, preserve_factors = TRUE, ...) { - # coefs <- MuMIn::coefTable(fit, ...) - coefs <- as.data.frame(MuMIn::coefTable(fit)) - model_matrix <- model.matrix(fit) - - predictors <- get_info(fit)$predictors - predictors <- c("(Intercept)", predictors) - - if (preserve_factors == TRUE) { - response_sd <- sd(model.response(model.frame(fit))) - factors <- as.data.frame(model_matrix)[!names(as.data.frame(model_matrix)) %in% predictors] - bx_factors <- rep(1 / response_sd, length(names(factors))) - bx_factors <- data.frame(t(bx_factors)) - names(bx_factors) <- names(factors) - coefs_factors <- coefs[names(factors), ] - model_matrix_factors <- as.matrix(factors) - - coefs <- coefs[!rownames(coefs) %in% names(factors), ] - model_matrix <- as.matrix(as.data.frame(model_matrix)[names(as.data.frame(model_matrix)) %in% predictors]) - } - - if (partial_sd == TRUE) { - bx <- .partialsd( - coefs[, 1L], - apply(model_matrix, 2L, sd), - .vif(fit), - nobs(fit), - sum(attr(model_matrix, "assign") != 0) - ) - } else { - response_sd <- sd(model.response(model.frame(fit))) - bx <- apply(model_matrix, 2L, sd) / response_sd - } - bx <- as.data.frame(t(bx)) - names(bx) <- row.names(coefs) - - if (preserve_factors == TRUE) { - bx <- cbind(bx, bx_factors) - } - - - # coefs <- MuMIn::coefTable(fit, ...) - coefs <- as.data.frame(MuMIn::coefTable(fit)) - multiplier <- as.numeric(bx[row.names(coefs)]) - - coefs[, 1L:2L] <- coefs[, 1L:2L] * multiplier - colnames(coefs)[1L:2L] <- c("Coef.std", "SE.std") - return(coefs) -} - - - - - - - -#' Print the results. -#' -#' Print the results. -#' -#' @param object A psychobject class object. -#' @param round Round the ouput. -#' @param ... Further arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @method summary psychobject -#' @export -summary.psychobject <- function(object, round = NULL, ...) { - summary <- object$summary - - if (!is.null(round)) { - nums <- dplyr::select_if(summary, is.numeric) - nums <- round(nums, round) - fact <- dplyr::select_if(summary, is.character) - fact <- cbind(fact, dplyr::select_if(summary, is.factor)) - summary <- cbind(fact, nums) - } - - return(summary) -} - - - - - - - -#' Extract values as list. -#' -#' @param x A psychobject class object. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -values <- function(x) { - values <- x$values - return(values) -} - - - - -#' Analyze blavaan (SEM or CFA) objects. -#' -#' Analyze blavaan (SEM or CFA) objects. -#' -#' @param x lavaan object. -#' @param CI Credible interval level. -#' @param standardize Compute standardized coefs. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lavaan) -#' -#' model <- " visual =~ x1 + x2 + x3\ntextual =~ x4 + x5 + x6\nspeed =~ x7 + x8 + x9 " -#' x <- lavaan::cfa(model, data = HolzingerSwineford1939) -#' -#' rez <- analyze(x) -#' print(rez) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso -#' https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM -#' -#' @importFrom lavaan parameterEstimates fitmeasures -#' @importFrom blavaan standardizedposterior -#' -#' @export -analyze.blavaan <- function(x, CI = 90, standardize = FALSE, ...) { - fit <- x - - - # Processing - # ------------- - values <- list() - values$CI <- CI - - # Fit measures - values$Fit_Measures <- interpret_lavaan(fit) - - - # Text - # ------------- - computations <- .get_info_computations(fit) - fitmeasures <- values$Fit_Measures$text - text <- paste0( - "A Bayesian model was fitted (", - computations, - "). The fit indices are as following: ", - fitmeasures - ) - - # Summary - # ------------- - summary <- .summary_blavaan(fit, CI = CI, standardize = standardize) - - # Plot - # ------------- - plot <- "Use `get_graph` in association with ggraph." - - output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - -#' @keywords internal -.get_info_computations <- function(fit) { - chains <- blavaan::blavInspect(fit, "n.chains") - sample <- fit@external$sample - warmup <- fit@external$burnin - text <- paste0( - chains, - " chains, each with iter = ", - sample, - "; warmup = ", - warmup - ) - return(text) -} - - - - -#' @keywords internal -.process_blavaan <- function(fit, standardize = FALSE, CI = 90) { - # Get relevant rows - PE <- parameterEstimates(fit, - se = FALSE, ci = FALSE, remove.eq = FALSE, remove.system.eq = TRUE, - remove.ineq = FALSE, remove.def = FALSE, - add.attributes = TRUE - ) - if (!("group" %in% names(PE))) PE$group <- 1 - newpt <- fit@ParTable - pte2 <- which(newpt$free > 0) - relevant_rows <- match( - with(newpt, paste(lhs[pte2], op[pte2], rhs[pte2], group[pte2], sep = "")), - paste(PE$lhs, PE$op, PE$rhs, PE$group, sep = "") - ) - - # Priors - priors <- rep(NA, nrow(PE)) - priors[relevant_rows] <- newpt$prior[pte2] - priors[is.na(PE$prior)] <- "" - - - - - # Posterior - if (standardize == FALSE) { - posteriors <- blavaan::blavInspect(fit, "draws") %>% - as.matrix() %>% - as.data.frame() - names(posteriors) <- names(lavaan::coef(fit)) - } else { - posteriors <- blavaan::standardizedposterior(fit) %>% - as.data.frame() - } - - - - # Effects - MPE <- c() - Median <- c() - MAD <- c() - Effect <- c() - CI_lower <- c() - CI_higher <- c() - for (effect in names(posteriors)) { - posterior <- posteriors[[effect]] - Effect <- c(Effect, effect) - MPE <- c(MPE, mpe(posterior)$MPE) - Median <- c(Median, median(posterior)) - MAD <- c(MAD, mad(posterior)) - - CI_values <- HDI(posterior, prob = CI / 100) - CI_lower <- c(CI_lower, CI_values$values$HDImin) - CI_higher <- c(CI_higher, CI_values$values$HDImax) - } - - if (standardize == FALSE) { - Effects <- rep(NA, nrow(PE)) - Effects[relevant_rows] <- Effect - MPEs <- rep(NA, nrow(PE)) - MPEs[relevant_rows] <- MPE - Medians <- rep(NA, nrow(PE)) - Medians[relevant_rows] <- Median - MADs <- rep(NA, nrow(PE)) - MADs[relevant_rows] <- MAD - CI_lowers <- rep(NA, nrow(PE)) - CI_lowers[relevant_rows] <- CI_lower - CI_highers <- rep(NA, nrow(PE)) - CI_highers[relevant_rows] <- CI_higher - } else { - Effects <- Effect - MPEs <- MPE - Medians <- Median - MADs <- MAD - CI_lowers <- CI_lower - CI_highers <- CI_higher - } - - data <- data.frame( - "Effect" = Effects, - "Median" = Medians, - "MAD" = MADs, - "MPE" = MPEs, - "CI_lower" = CI_lowers, - "CI_higher" = CI_highers, - "Prior" = priors - ) - - return(data) -} - - - -#' @keywords internal -.summary_blavaan <- function(fit, CI = 90, standardize = FALSE) { - solution <- lavaan::parameterEstimates(fit, se = TRUE, ci = TRUE, standardized = FALSE, level = CI / 100) - - solution <- solution %>% - rename( - "From" = "rhs", - "To" = "lhs", - "Operator" = "op", - "Coef" = "est", - "SE" = "se", - "CI_lower" = "ci.lower", - "CI_higher" = "ci.upper" - ) %>% - mutate(Type = dplyr::case_when( - Operator == "=~" ~ "Loading", - Operator == "~" ~ "Regression", - Operator == "~~" ~ "Correlation", - TRUE ~ NA_character_ - )) %>% - select(one_of(c("To", "Operator", "From", "Type"))) %>% - mutate_("Effect" = "as.character(paste0(To, Operator, From))") %>% - full_join(.process_blavaan(fit, CI = CI, standardize = standardize) %>% - mutate_("Effect" = "as.character(Effect)"), by = "Effect") %>% - select_("-Effect") %>% - mutate_( - "Median" = "replace_na(Median, 1)", - "MAD" = "replace_na(MAD, 0)", - "MPE" = "replace_na(MPE, 100)" - ) %>% - select(one_of(c("From", "Operator", "To", "Median", "MAD", "CI_lower", "CI_higher", "MPE", "Prior", "Type"))) %>% - dplyr::filter_("Operator != '~1'") - - - return(solution) -} - - - - - - - - - - -#' Analyze fa objects. -#' -#' Analyze fa objects. -#' -#' @param x An psych object. -#' @param labels Supply a additional column with e.g. item labels. -#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(psych) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' -#' results <- analyze(x) -#' print(results) -#' summary(results) -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -analyze.fa <- function(x, labels = NULL, treshold = "max", ...) { - loadings <- format_loadings(x, labels) - - values <- list() - values$variance <- x$Vaccounted - values$loadings <- loadings$loadings - values$loadings_max <- loadings$max - values$cfa_model <- get_cfa_model(loadings$loadings, treshold = treshold) - - text <- .fa_variance_text(values$variance) - text <- paste0(text, "\n\n", format(values$cfa_model)) - summary <- values$loadings - plot <- plot_loadings(values$loadings) - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - -#' @export -.fa_variance_text <- function(variance) { - variance <- as.data.frame(variance) - n_factors <- ncol(variance) - - if (ncol(variance) == 1) { - t <- as.data.frame(t(variance)) - tot_var <- t$`Proportion Var` - text <- paste0( - "The unique component accounted for ", - format_digit(tot_var * 100), - "% of the total variance." - ) - } else { - t <- as.data.frame(t(variance)) - tot_var <- max(t$`Cumulative Var`) - - factors <- names(variance) - var <- variance["Proportion Var", ] - text_var <- paste0(factors, - " = ", - format_digit(var * 100), - "%", - collapse = ", " - ) - - text <- paste0( - "The ", - n_factors, - " components accounted for ", - format_digit(tot_var * 100), - "% of the total variance (" - ) - text <- paste0(text, text_var, ").") - } - - return(text) -} - - - - - - - -#' Format the loadings of a factor analysis. -#' -#' Format the loadings of a factor analysis. -#' -#' @param x An psych object. -#' @param labels Supply a additional column with e.g. item labels. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' format_loadings(x) -#' } -#' -#' @import dplyr -#' @export -format_loadings <- function(x, labels = NULL) { - - - # Check loadings and remove those inferior to a treshold - loadings <- x$loadings %>% - unclass() %>% - as.data.frame() - - # Save n factors - n_factors <- length(loadings) - - # Add item labels - loadings$Item <- rownames(loadings) - if (length(labels) == nrow(loadings)) { - loadings$Label <- labels - } else { - loadings$Label <- 1:nrow(loadings) - } - - # Keep Order - loadings$N <- 1:nrow(loadings) - - - # Select the max loading for each item - max <- get_loadings_max(loadings) - - - # Reorder the loading matrix accordingly - loadings <- loadings[max$N, ] %>% - select_("N", "Item", "Label", "everything()") - - return(list(loadings = loadings, max = max)) -} - - - -#' Get loadings max. -#' -#' Get loadings max. -#' -#' @param loadings Formatted loadings. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' get_loadings_max(format_loadings(x)$loadings) -#' } -#' -#' @import dplyr -#' @export -get_loadings_max <- function(loadings) { - max <- loadings %>% - tidyr::gather_("Component", "Loading", names(loadings)[!names(loadings) %in% c("Item", "N", "Label")]) %>% - dplyr::group_by_("Item") %>% - dplyr::slice_("which.max(abs(Loading))") %>% - dplyr::arrange_("Component", "desc(Loading)") - return(max) -} - - - -#' Get CFA model. -#' -#' Get CFA model. -#' -#' @param loadings Formatted loadings. -#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' loadings <- format_loadings(x)$loadings -#' get_cfa_model(loadings, treshold = "max") -#' get_cfa_model(loadings, treshold = 0.1) -#' } -#' -#' @import dplyr -#' @export -get_cfa_model <- function(loadings, treshold = "max") { - if (treshold == "max") { - filtered_loadings <- get_loadings_max(loadings) - } else { - filtered_loadings <- loadings %>% - tidyr::gather_("Component", "Loading", names(loadings)[!names(loadings) %in% c("Item", "N", "Label")]) %>% - filter_("Loading > treshold") - } - - cfa_model <- filtered_loadings %>% - select_("Item", "Component") %>% - group_by_("Component") %>% - summarise_("Observed" = 'paste(Item, collapse=" + ")') %>% - transmute_("Latent_Variable" = 'paste(Component, Observed, sep=" =~ ")') %>% - pull() - - cfa_model <- c("#Latent variables", cfa_model) %>% - paste(collapse = "\n") - - return(cfa_model) -} - - - - -#' Plot loadings. -#' -#' Plot loadings. -#' -#' @param loadings Loadings by variable. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' x <- psych::fa(psych::Thurstone.33, 2) -#' plot_loadings(format_loadings(x)$loadings) -#' } -#' -#' @import dplyr -#' @export -plot_loadings <- function(loadings) { - if (all(loadings$Label != loadings$N)) { - loadings$Item <- paste0(loadings$Label, " (", loadings$Item, ")") - } - - p <- loadings %>% - gather("Component", "Loading", matches("\\d$")) %>% - mutate_("Loading" = "abs(Loading)") %>% - mutate_("Item" = "factor(Item, levels=rev(get_loadings_max(loadings)$Item))") %>% - ggplot(aes_string(y = "Loading", x = "Item", fill = "Component")) + - geom_bar(stat = "identity") + - coord_flip() + - ylab("\nLoading Strength") + - xlab("Item\n") - - return(p) -} - - - - - - - -#' Analyze glm objects. -#' -#' Analyze glm objects. -#' -#' @param x glm object. -#' @param CI Confidence interval bounds. Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @seealso \link[=get_R2.glm]{"get_R2.glm"} -#' -#' @import dplyr -#' @importFrom stats formula -#' @importFrom stringr str_squish -#' @export -analyze.glm <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - if (fit$family$family != "binomial") { - stop(paste("Models of family", fit$family$family, "not supported yet.")) - } - - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # R2 <- tjur_D(fit) - R2 <- get_R2(fit, method = "nakagawa") - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$z <- summary$`z.value` - summary$p <- summary$`Pr...z..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_odds(tail(summary$Coef_std, -1), log = TRUE, rules = effsize_rules)) - - summary <- dplyr::select_( - summary, "Variable", "Coef", "SE", "z", "Coef_std", "SE_std", - "p", "Effect_Size" - ) - - if (!is.null(CI)) { - CI_values <- suppressMessages(confint(fit, level = CI / 100)) - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"]), - ", ", - format_digit(summary[varname, "CI_higher"]), - "]" - ) - } else { - CI_text <- "" - } - - - - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", z = ", - format_digit(summary[varname, "z"], 2), ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), ")." - ) - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - CI_lower = summary[varname, "CI_lower"], - CI_higher = summary[varname, "CI_higher"], - z = summary[varname, "z"], - Coef_std = summary[varname, "Coef_std"], - SE_std = summary[varname, "SE_std"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - outcome, - " (formula = ", - stringr::str_squish(paste0(format(stats::formula(fit)), collapse = "")), - ") has an explanatory power of ", - format_digit(R2 * 100, 2), - "%. ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - -#' Analyze glmerMod objects. -#' -#' Analyze glmerMod objects. -#' -#' @param x merModLmerTest object. -#' @param CI Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @importFrom MuMIn r.squaredGLMM -#' @importFrom MuMIn std.coef -#' @importFrom stringr str_squish -#' @import lmerTest -#' @import dplyr -#' @export -analyze.glmerMod <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - info <- get_info(fit) - R2 <- tryCatch({ - get_R2(fit) - }, error = function(e) { - warning("Couldn't compute R2. Might be caused by the presence of missing data.") - R2 <- list(R2m = NA, R2c = NA) - return(R2) - }) - - - - - - - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$z <- summary$`z.value` - summary$p <- summary$`Pr...z..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_odds(tail(summary$Coef_std, -1), log = TRUE, rules = effsize_rules)) - - - # Summary - summary <- dplyr::select_(summary, "Variable", "Coef", "SE", "z", "p", "Coef_std", "SE_std", "Effect_Size") - - # CI computation - if (!is.null(CI)) { - CI_values <- tryCatch({ - suppressMessages(confint(fit, level = CI / 100)) - }, error = function(e) { - warning("Couldn't compute CI. Skipping.") - CI_values <- NA - return(CI_values) - }) - if (!all(is.na(CI_values))) { - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } else { - CI <- NULL - } - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - values$model$R2m <- R2$R2m - values$model$R2c <- R2$R2c - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"]), - ", ", - format_digit(summary[varname, "CI_higher"]), - "]" - ) - } else { - CI_text <- "" - } - - - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } else { - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), - ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", z = ", - format_digit(summary[varname, "z"], 2), - ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), - ")." - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - z = summary[varname, "z"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - info$outcome, - " (formula = ", - format(info$formula), - ") has an explanatory power (conditional R2) of ", - format_digit(R2$R2c * 100, 2), - "%, in which the fixed effects' part is ", - format_digit(R2$R2m * 100, 2), "% (marginal R2). ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - -#' Analyze htest (correlation, t-test...) objects. -#' -#' Analyze htest (correlation, t-test...) objects. -#' -#' @param x htest object. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' -#' x <- t.test(df$Tolerating, df$Adjusting) -#' x <- t.test(df$Tolerating ~ df$Sex) -#' x <- t.test(df$Tolerating, mu = 2) -#' x <- cor.test(df$Tolerating, df$Adjusting) -#' -#' results <- analyze(x) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' -#' @export -analyze.htest <- function(x, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - values <- list() - values$method <- x$method - values$names <- x$data.name - values$statistic <- x$statistic - values$effect <- x$estimate - values$p <- x$p.value - values$df <- x$parameter - values$CI <- x$conf.int - values$signif <- ifelse(values$p < .05, "significant", "not significant") - values$CI_level <- attr(values$CI, "conf.level") * 100 - values$CI_format <- paste0(values$CI_level, "% CI [", format_digit(values$CI[1]), ", ", format_digit(values$CI[2]), "]") - - - - # Text - # ------------- - - # CORRELATION - if (grepl("correlation", values$method)) { - text <- paste0( - "The ", - values$method, - " between ", - values$names, - " is ", - values$signif, - ", ", - interpret_r(values$effect, rules = effsize_rules), - " (r(", - format_digit(values$df), - ") = ", - format_digit(values$effect), - ", ", - values$CI_format, - ", p ", - format_p(values$p, stars = FALSE), - ")." - ) - - # T-TEST - } else if (grepl("t-test", values$method)) { - if (names(x$null.value) == "mean") { - means <- paste0( - " (mean = ", - format_digit(values$effect), - ")" - ) - vars <- paste0(values$names, means, " and mu = ", x$null.value) - } else { - means <- paste0( - c( - paste0( - names(values$effect), " = ", - format_digit(values$effect) - ), - paste0( - "difference = ", - format_digit(values$effect[1] - values$effect[2]) - ) - ), - collapse = ", " - ) - vars <- paste0(values$names, " (", means, ")") - } - - values$effect <- values$effect[1] - values$effect[2] - - text <- paste0( - "The ", - values$method, - " suggests that the difference ", - ifelse(grepl(" by ", values$names), "of ", "between "), - vars, - " is ", - values$signif, - " (t(", - format_digit(values$df), - ") = ", - format_digit(values$statistic), - ", ", - values$CI_format, - ", p ", - format_p(values$p, stars = FALSE), - ")." - ) - # OTHER - } else { - stop(paste0("The ", values$method, " is not implemented yet.")) - } - - - # Summary - # ------------- - summary <- data.frame( - effect = values$effect, - statistic = values$statistic, - df = values$df, - p = values$p, - CI_lower = values$CI[1], - CI_higher = values$CI[2] - ) - rownames(summary) <- NULL - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - -#' Analyze lavaan SEM or CFA) objects. -#' -#' Analyze lavaan (SEM or CFA) objects. -#' -#' @param x lavaan object. -#' @param CI Confidence interval level. -#' @param standardize Compute standardized coefs. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lavaan) -#' -#' model <- " visual =~ x1 + x2 + x3\ntextual =~ x4 + x5 + x6\nspeed =~ x7 + x8 + x9 " -#' x <- lavaan::cfa(model, data = HolzingerSwineford1939) -#' -#' rez <- analyze(x) -#' print(rez) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso -#' https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM -#' -#' -#' @importFrom lavaan parameterEstimates fitmeasures -#' -#' @export -analyze.lavaan <- function(x, CI = 95, standardize = FALSE, ...) { - fit <- x - - - # Processing - # ------------- - values <- list() - values$CI <- CI - - # Fit measures - values$Fit_Measures <- interpret_lavaan(fit) - - - - - # Summary - # ------------- - summary <- .summary_lavaan(fit, CI = CI, standardize = standardize) - - # Plot - # ------------- - plot <- "Use `get_graph` in association with ggraph." - - output <- list(text = values$Fit_Measures$text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - - - - - -#' @keywords internal -.summary_lavaan <- function(fit, CI = 95, standardize = FALSE) { - if (standardize == FALSE) { - solution <- lavaan::parameterEstimates(fit, se = TRUE, standardized = standardize, level = CI / 100) - } else { - solution <- lavaan::standardizedsolution(fit, se = TRUE, level = CI / 100) %>% - rename_("est" = "est.std") - } - - solution <- solution %>% - rename( - "From" = "rhs", - "To" = "lhs", - "Operator" = "op", - "Coef" = "est", - "SE" = "se", - "p" = "pvalue", - "CI_lower" = "ci.lower", - "CI_higher" = "ci.upper" - ) %>% - mutate(Type = dplyr::case_when( - Operator == "=~" ~ "Loading", - Operator == "~" ~ "Regression", - Operator == "~~" ~ "Correlation", - TRUE ~ NA_character_ - )) %>% - mutate_("p" = "replace_na(p, 0)") - - if ("group" %in% names(solution)) { - solution <- solution %>% - rename("Group" = "group") %>% - select(one_of(c("Group", "From", "Operator", "To", "Coef", "SE", "CI_lower", "CI_higher", "p", "Type"))) - } else { - solution <- select(solution, one_of(c("From", "Operator", "To", "Coef", "SE", "CI_lower", "CI_higher", "p", "Type"))) - } - - return(solution) -} - - - - - - -#' Analyze lm objects. -#' -#' Analyze lm objects. -#' -#' @param x lm object. -#' @param CI Confidence interval bounds. Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) -#' fit <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris) -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' @importFrom stats formula -#' @importFrom stringr str_squish -#' @export -analyze.lm <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - R2 <- get_R2(fit) - R2adj <- R2$R2.adj - R2 <- R2$R2 - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$t <- summary$`t.value` - summary$p <- summary$`Pr...t..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit", data = data), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_d(tail(summary$Coef_std, -1), rules = effsize_rules)) - - summary <- dplyr::select_( - summary, "Variable", "Coef", "SE", "t", "Coef_std", "SE_std", - "p", "Effect_Size" - ) - - if (!is.null(CI)) { - CI_values <- confint(fit, level = CI / 100) - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - values$model$R2 <- R2 - values$model$R2adj <- R2adj - - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"]), - ", ", - format_digit(summary[varname, "CI_higher"]), - "]" - ) - } else { - CI_text <- "" - } - - - - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", t = ", - format_digit(summary[varname, "t"], 2), ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), ")." - ) - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - CI_lower = summary[varname, "CI_lower"], - CI_higher = summary[varname, "CI_higher"], - t = summary[varname, "t"], - Coef_std = summary[varname, "Coef_std"], - SE_std = summary[varname, "SE_std"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - outcome, - " (formula = ", - stringr::str_squish(paste0(format(stats::formula(fit)), collapse = "")), - ") explains ", - format_digit(R2 * 100, 2), - "% of the variance of the endogen (adj. R2 = ", - format_digit(R2adj * 100, 2), - "). ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - - - -#' Analyze lmerModLmerTest objects. -#' -#' Analyze lmerModLmerTest objects. -#' -#' @param x lmerModLmerTest object. -#' @param CI Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lmerTest) -#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -#' -#' results <- analyze(fit) -#' summary(results) -#' print(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @importFrom MuMIn r.squaredGLMM -#' @importFrom MuMIn std.coef -#' @importFrom stringr str_squish -#' @import dplyr -#' @export -analyze.lmerModLmerTest <- function(x, CI = 95, effsize_rules = "cohen1988", ...) { - - - # Processing - # ------------- - fit <- x - - info <- get_info(fit) - R2 <- get_R2(fit) - - - - # TODO: Bootstrapped p values - # nsim determines p-value decimal places - # boot.out = lme4::bootMer(fit, lme4::fixef, nsim=1000) - # p = rbind( - # (1-apply(boot.out$t<0, 2, mean))*2, - # (1-apply(boot.out$t>0, 2, mean))*2) - # p = apply(p, 2, min) - - - - # Summary - # ------------- - summary <- data.frame(summary(fit)$coefficients) - - summary$Variable <- rownames(summary) - summary$Coef <- summary$Estimate - summary$SE <- summary$`Std..Error` - summary$df <- as.numeric(summary$df) - summary$t <- summary$`t.value` - summary$p <- summary$`Pr...t..` - - # standardized coefficients - standardized <- tibble::rownames_to_column(standardize(fit, method = "refit"), "Variable") - summary <- merge(summary, standardized, by = "Variable", all.x = TRUE, sort = FALSE) - summary$Effect_Size <- c(NA, interpret_d(tail(summary$Coef_std, -1), rules = effsize_rules)) - - summary <- dplyr::select_( - summary, "Variable", "Coef", "SE", "t", "df", "p", "Coef_std", "SE_std", "Effect_Size" - ) - - # CI computation - if (!is.null(CI)) { - CI_values <- tryCatch({ - suppressMessages(confint(fit, level = CI / 100)) - }, error = function(e) { - warning("Couldn't compute CI. Skipping.") - CI_values <- NA - return(CI_values) - }) - if (!all(is.na(CI_values))) { - CI_values <- tail(CI_values, n = length(rownames(summary))) - summary$CI_lower <- CI_values[, 1] - summary$CI_higher <- CI_values[, 2] - } else { - CI <- NULL - } - } - - - # Varnames - varnames <- summary$Variable - row.names(summary) <- varnames - - - # Values - # ------------- - # Initialize empty values - values <- list(model = list(), effects = list()) - values$model$R2m <- R2$R2m - values$model$R2c <- R2$R2c - - - # Loop over all variables - for (varname in varnames) { - if (summary[varname, "p"] < .1) { - significance <- " " - } else { - significance <- " not " - } - - if (!is.null(CI)) { - CI_text <- paste0( - ", ", - CI, "% CI [", - format_digit(summary[varname, "CI_lower"]), - ", ", - format_digit(summary[varname, "CI_higher"]), - "]" - ) - } else { - CI_text <- "" - } - - - - - if (varname == "(Intercept)") { - text <- paste0( - "The model's intercept is at ", - format_digit(summary[varname, "Coef"], 2), - " (SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - "). Within this model:" - ) - } else { - text <- paste0( - "The effect of ", - varname, - " is", - significance, - "significant (beta = ", - format_digit(summary[varname, "Coef"], 2), - ", SE = ", - format_digit(summary[varname, "SE"], 2), - CI_text, - ", t(", - format_digit(summary[varname, "df"], 0), - ") = ", - format_digit(summary[varname, "t"], 2), - ", p ", - format_p(summary[varname, "p"], stars = FALSE), - ") and can be considered as ", - tolower(summary[varname, "Effect_Size"]), - " (std. beta = ", - format_digit(summary[varname, "Coef_std"], 2), - ", std. SE = ", - format_digit(summary[varname, "SE_std"], 2), - ")." - ) - } - - values$effects[[varname]] <- list( - Coef = summary[varname, "Coef"], - SE = summary[varname, "SE"], - CI_lower = summary[varname, "CI_lower"], - CI_higher = summary[varname, "CI_higher"], - t = summary[varname, "t"], - df = summary[varname, "df"], - Coef_std = summary[varname, "Coef_std"], - SE_std = summary[varname, "SE_std"], - p = summary[varname, "p"], - Effect_Size = summary[varname, "Effect_Size"], - Text = text - ) - } - - - - # Text - # ------------- - text <- c(paste0( - "The overall model predicting ", - info$outcome, - " (formula = ", - format(info$formula), - ") has an total explanatory power (conditional R2) of ", - format_digit(R2$R2c * 100, 2), - "%, in which the fixed effects explain ", - format_digit(R2$R2m * 100, 2), "% of the variance (marginal R2). ", - values$effects[["(Intercept)"]]$Text - )) - - for (varname in varnames) { - if (varname != "(Intercept)") { - text <- c(text, paste(" -", values$effects[[varname]]$Text)) - } - } - - - - # Plot - # ------------- - plot <- "Not available yet" - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - -#' Analyze fa objects. -#' -#' Analyze fa objects. -#' -#' @param x An psych object. -#' @param labels Supply a additional column with e.g. item labels. -#' @param treshold 'max' or numeric. The treshold over which to associate an item with its component. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(psych) -#' -#' x <- psych::pca(psych::Thurstone.33, 2) -#' -#' results <- analyze(x) -#' print(results) -#' summary(results) -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -analyze.principal <- function(x, labels = NULL, treshold = "max", ...) { - loadings <- format_loadings(x, labels) - - values <- list() - values$variance <- x$Vaccounted - values$loadings <- loadings$loadings - values$loadings_max <- loadings$max - values$cfa_model <- get_cfa_model(loadings$loadings, treshold = treshold) - - text <- .fa_variance_text(values$variance) - text <- paste0(text, "\n\n", format(values$cfa_model)) - summary <- values$loadings - plot <- plot_loadings(values$loadings) - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - -#' Analyze objects. -#' -#' Analyze objects. See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=analyze.stanreg]{analyze.stanreg}} -#' \item{\link[=analyze.lmerModLmerTest]{analyze.merModLmerTest}} -#' \item{\link[=analyze.glmerMod]{analyze.glmerMod}} -#' \item{\link[=analyze.lm]{analyze.lm}} -#' \item{\link[=analyze.glm]{analyze.glm}} -#' } -#' \itemize{ -#' \item{\link[=analyze.htest]{analyze.htest}} -#' \item{\link[=analyze.aov]{analyze.aov}} -#' } -#' \itemize{ -#' \item{\link[=analyze.fa]{analyze.fa}} -#' \item{\link[=analyze.principal]{analyze.principal}} -#' \item{\link[=analyze.lavaan]{analyze.lavaan}} -#' \item{\link[=analyze.blavaan]{analyze.blavaan}} -#' } -#' -#' @param x object to analyze. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -analyze <- function(x, ...) { - UseMethod("analyze") -} - - - - -#' Analyze stanreg objects. -#' -#' Analyze stanreg objects. -#' -#' @param x A stanreg model. -#' @param CI Credible interval bounds. -#' @param index Index of effect existence to report. Can be 'overlap' or 'ROPE'. -#' @param ROPE_bounds Bounds of the ROPE. If NULL and effsize is TRUE, than the ROPE. -#' will have default values c(-0.1, 0.1) and computed on the standardized posteriors. -#' @param effsize Compute Effect Sizes according to Cohen (1988). For linear models only. -#' @param effsize_rules Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}. -#' @param ... Arguments passed to or from other methods. -#' -#' @return Contains the following indices: -#' \itemize{ -#' \item{the Median of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models).} -#' \item{the Median Absolute Deviation (MAD), a robust measure of dispertion (could be seen as a robust version of SD).} -#' \item{the Credible Interval (CI) (by default, the 90\% CI; see Kruschke, 2018), representing a range of possible parameter.} -#' \item{the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).} -#' \item{the Overlap (O), the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution.} -#' \item{the ROPE, the proportion of the 95\% CI of the posterior distribution that lies within the region of practical equivalence.} -#' } -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' data <- attitude -#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) -#' -#' results <- analyze(fit, effsize = TRUE) -#' summary(results) -#' print(results) -#' plot(results) -#' -#' -#' fit <- rstanarm::stan_lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -#' results <- analyze(fit) -#' summary(results) -#' -#' fit <- rstanarm::stan_glm(Sex ~ Adjusting, -#' data = psycho::affective, family = "binomial" -#' ) -#' results <- analyze(fit) -#' summary(results) -#' -#' fit <- rstanarm::stan_glmer(Sex ~ Adjusting + (1 | Salary), -#' data = psycho::affective, family = "binomial" -#' ) -#' results <- analyze(fit) -#' summary(results) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso -#' \link[=get_R2.stanreg]{"get_R2.stanreg"} -#' \link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} -#' -#' @import loo -#' @import tidyr -#' @import dplyr -#' @import ggplot2 -#' @importFrom stats quantile as.formula -#' @importFrom utils head tail capture.output -#' @importFrom broom tidy -#' @importFrom stringr str_squish str_replace -#' @export -analyze.stanreg <- function(x, CI = 90, index = "overlap", ROPE_bounds = NULL, effsize = FALSE, effsize_rules = "cohen1988", ...) { - fit <- x - - # Info -------------------------------------------------------------------- - - # Algorithm - if (fit$algorithm == "optimizing") { - stop("Can't analyze models fitted with 'optimizing' algorithm.") - } - computations <- capture.output(fit$stanfit) - computations <- paste0(computations[2], computations[3], collapse = "") - computations <- stringr::str_remove_all(computations, ", total post-warmup draws.*") - computations <- stringr::str_remove_all(computations, " draws per chain") - computations <- stringr::str_replace_all(computations, "=", " = ") - - # Extract posterior distributions - posteriors <- as.data.frame(fit) - - - # Varnames - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - varnames <- names(fit$coefficients) - varnames <- varnames[grepl("b\\[", varnames) == FALSE] - - # Initialize empty values - values <- list(model = list(), effects = list()) - - values$model$formula <- fit$formula - values$model$outcome <- outcome - values$model$predictors <- predictors - - # Priors - info_priors <- rstanarm::prior_summary(fit) - values$priors <- info_priors - - # R2 ---------------------------------------------------------------------- - - R2 <- get_R2(fit, silent = TRUE) - if (is.list(R2)) { - posteriors$R2 <- R2$R2_posterior - R2.adj <- R2$R2.adj - if (!"R2" %in% varnames) { - varnames <- c("R2", varnames) - } - R2 <- TRUE - } else { - R2 <- FALSE - } - - # Random effect info -------------------------------------------- - if (is.mixed(fit)) { - random_info <- broom::tidy(fit, parameters = "varying") %>% - dplyr::rename_( - "Median" = "estimate", - "MAD" = "std.error" - ) - values$random <- random_info - } - - # Standardized posteriors -------------------------------------------- - if (effsize == TRUE) { - posteriors_std <- standardize(fit, method = "refit") - # Avoir some problems - if (length(setdiff(names(posteriors_std), varnames[varnames != "R2"])) != 0) { - names(posteriors_std) <- varnames[varnames != "R2"] - } - } else { - posteriors_std <- as.data.frame(fit) - } - - # Get indices of each variable -------------------------------------------- - - # Loop over all variables - for (varname in varnames) { - if (varname == "R2") { - values$effects[[varname]] <- .process_R2(varname, - posteriors, - info_priors, - R2.adj = R2.adj, - CI = CI, - effsize = effsize - ) - } else if (varname == "(Intercept)") { - values$effects[[varname]] <- .process_intercept(varname, - posteriors, - info_priors, - predictors, - CI = CI, - effsize = effsize - ) - } else { - values$effects[[varname]] <- .process_effect(varname, - posteriors, - posteriors_std = posteriors_std, - info_priors, - predictors, - CI = CI, - effsize = effsize, - effsize_rules = effsize_rules, - fit = fit, - index = index, - ROPE_bounds = ROPE_bounds - ) - } - } - - - # Summary -------------------------------------------------------------------- - summary <- data.frame() - for (varname in varnames) { - summary <- rbind( - summary, - data.frame( - Variable = varname, - Median = values$effects[[varname]]$median, - MAD = values$effects[[varname]]$mad, - CI_lower = values$effects[[varname]]$CI_values[1], - CI_higher = values$effects[[varname]]$CI_values[2], - Median_std = values$effects[[varname]]$std_median, - MAD_std = values$effects[[varname]]$std_mad, - MPE = values$effects[[varname]]$MPE, - ROPE = values$effects[[varname]]$ROPE, - Overlap = values$effects[[varname]]$overlap - ) - ) - } - - if (effsize == FALSE) { - summary <- select_(summary, "-Median_std", "-MAD_std") - } - - if (index == "ROPE") { - summary <- select_(summary, "-Overlap") - } else { - summary <- select_(summary, "-ROPE") - } - - # Text -------------------------------------------------------------------- - # ------------------------------------------------------------------------- - # Model - info <- paste0( - "We fitted a ", - ifelse(fit$algorithm == "sampling", "Markov Chain Monte Carlo", fit$algorithm), - " ", - fit$family$family, - " (link = ", - fit$family$link, - ") model (", - computations, - ") to predict ", - outcome, - " (formula = ", stringr::str_squish(paste0(format(fit$formula), collapse = "")), - "). The model's priors were set as follows: " - ) - - # Priors - text_priors <- rstanarm::prior_summary(fit) - if ("adjusted_scale" %in% names(text_priors$prior) & !is.null(text_priors$prior$adjusted_scale)) { - scale <- paste0( - "), scale = (", - paste(sapply(text_priors$prior$adjusted_scale, format_digit), collapse = ", ") - ) - } else { - scale <- paste0( - "), scale = (", - paste(sapply(text_priors$prior$scale, format_digit), collapse = ", ") - ) - } - - info_priors_text <- paste0( - " ~ ", - text_priors$prior$dist, - " (location = (", - paste(text_priors$prior$location, collapse = ", "), - scale, - "))" - ) - - # Coefs - coefs_text <- c() - for (varname in varnames) { - effect_text <- values$effects[[varname]]$text - if (effsize == TRUE) { - if (!varname %in% c("(Intercept)", "R2")) { - effsize_text <- stringr::str_replace( - values$effects[[varname]]$EffSize_text, - "The effect's size", - "It" - )[1] - effect_text <- paste(effect_text, effsize_text) - } - } - coefs_text <- c(coefs_text, effect_text) - } - - # Text - if ("R2" %in% varnames) { - text <- c( - info, - "", - info_priors_text, - "", - "", - paste0( - coefs_text[1], - coefs_text[2] - ), - "", - tail(coefs_text, -2) - ) - } else { - text <- c( - info, - "", - info_priors_text, - "", - "", - coefs_text[1], - "", - tail(coefs_text, -1) - ) - } - - - - - # Plot -------------------------------------------------------------------- - # ------------------------------------------------------------------------- - - plot <- posteriors[varnames] %>% - # select(-`(Intercept)`) %>% - gather() %>% - rename_(Variable = "key", Coefficient = "value") %>% - ggplot(aes_string(x = "Variable", y = "Coefficient", fill = "Variable")) + - geom_violin() + - geom_boxplot(fill = "grey", alpha = 0.3, outlier.shape = NA) + - stat_summary( - fun.y = "mean", geom = "errorbar", - aes_string(ymax = "..y..", ymin = "..y.."), - width = .75, linetype = "dashed", colour = "red" - ) + - geom_hline(aes(yintercept = 0)) + - theme_classic() + - coord_flip() + - scale_fill_brewer(palette = "Set1") + - scale_colour_brewer(palette = "Set1") - - - - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - - - - - - - - - - - -#' @keywords internal -.get_info_priors <- function(varname, info_priors, predictors = NULL) { - # Prior - # TBD: this doesn't work with categorical predictors :( - values <- list() - - if (varname == "(Intercept)") { - values["prior_distribution"] <- info_priors$prior_intercept$dist - values["prior_location"] <- info_priors$prior_intercept$location - values["prior_scale"] <- info_priors$prior_intercept$scale - values["prior_adjusted_scale"] <- info_priors$prior_intercept$adjusted_scale - } else { - if (varname %in% predictors) { - predictor_index <- which(predictors == varname) - if (length(info_priors$prior$dist) == 1) { - info_priors$prior$dist <- rep( - info_priors$prior$dist, - length(info_priors$prior$location) - ) - } - values["prior_distribution"] <- info_priors$prior$dist[predictor_index] - values["prior_location"] <- info_priors$prior$location[predictor_index] - values["prior_scale"] <- info_priors$prior$scale[predictor_index] - values["prior_adjusted_scale"] <- info_priors$prior$adjusted_scale[predictor_index] - } - } - return(values) -} - - - - - - - - -#' @keywords internal -.process_R2 <- function(varname, posteriors, info_priors, R2.adj = NULL, CI = 90, effsize = FALSE) { - values <- .get_info_priors(varname, info_priors) - posterior <- posteriors[, varname] - - # Find basic posterior indices - values$posterior <- posterior - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- NA - values$MPE_values <- NA - values$overlap <- NA - values$ROPE <- NA - values$adjusted_r_squared <- R2.adj - - # Text - values$text <- paste0( - "The model has an explanatory power (R2) of about ", - format_digit(values$median * 100), - "% (MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1]), - ", ", - format_digit(values$CI_values[2]), - "]" - ) - - if (is.null(R2.adj) | is.na(R2.adj)) { - values$text <- paste0( - values$text, - ")." - ) - } else { - values$text <- paste0( - values$text, - ", adj. R2 = ", - format_digit(R2.adj), - ")." - ) - } - - - # Effize - if (effsize == TRUE) { - values$std_posterior <- NA - values$std_median <- NA - values$std_mad <- NA - values$std_mean <- NA - values$std_sd <- NA - values$std_CI_values <- NA - values$std_CI_values <- NA - - values$EffSize <- NA - values$EffSize_text <- NA - values$EffSize_VeryLarge <- NA - values$EffSize_Large <- NA - values$EffSize_Moderate <- NA - values$EffSize_Small <- NA - values$EffSize_VerySmall <- NA - values$EffSize_Opposite <- NA - } else { - values$std_median <- NA - values$std_mad <- NA - } - - return(values) -} - - - - -#' @keywords internal -.process_intercept <- function(varname, posteriors, info_priors, predictors, CI = 90, effsize = FALSE) { - values <- .get_info_priors(varname, info_priors, predictors) - posterior <- posteriors[, varname] - - # Find basic posterior indices - values$posterior <- posterior - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- NA - values$MPE_values <- NA - values$overlap <- NA - values$ROPE <- NA - - - - # Text - values$text <- paste0( - " The intercept is at ", - format_digit(values$median), - " (MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1]), - ", ", - format_digit(values$CI_values[2]), - "]). Within this model:" - ) - - # Effize - if (effsize == TRUE) { - values$std_posterior <- NA - values$std_median <- NA - values$std_mad <- NA - values$std_mean <- NA - values$std_sd <- NA - values$std_CI_values <- NA - values$std_CI_values <- NA - - values$EffSize <- NA - values$EffSize_text <- NA - values$EffSize_VeryLarge <- NA - values$EffSize_Large <- NA - values$EffSize_Moderate <- NA - values$EffSize_Small <- NA - values$EffSize_VerySmall <- NA - values$EffSize_Opposite <- NA - } else { - values$std_median <- NA - values$std_mad <- NA - } - - return(values) -} - - - - -#' @keywords internal -.process_effect <- function(varname, - posteriors, - posteriors_std, - info_priors, - predictors, - CI = 90, - effsize = FALSE, - effsize_rules = FALSE, - fit, - index = "overlap", - ROPE_bounds = NULL) { - values <- .get_info_priors(varname, info_priors, predictors) - posterior <- posteriors[, varname] - - - # Find basic posterior indices - values$posterior <- posterior - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- mpe(posterior)$MPE - values$MPE_values <- mpe(posterior)$values - - # Index - values$overlap <- 100 * overlap( - posterior, - rnorm_perfect( - length(posterior), - 0, - sd(posterior) - ) - ) - - if (!is.null(ROPE_bounds)) { - rope <- rope(posterior, bounds = ROPE_bounds) - values$ROPE_decision <- rope$rope_decision - values$ROPE <- rope$rope_probability - } else { - values$ROPE <- NA - values$ROPE_decision <- NA - } - - if (index == "overlap") { - index <- paste0( - "Overlap = ", - format_digit(values$overlap), - "%)." - ) - } else if (index == "ROPE") { - if (!is.null(ROPE_bounds)) { - index <- paste0( - "ROPE = ", - format_digit(values$ROPE), - ")." - ) - } else { - if (effsize == TRUE) { - rope <- rope(posteriors_std[, varname], bounds = c(-0.1, 0.1)) - values$ROPE_decision <- rope$rope_decision - values$ROPE <- rope$rope_probability - index <- paste0( - "ROPE = ", - format_digit(values$ROPE), - ")." - ) - } else { - warning("you need to specify ROPE_bounds (e.g. 'c(-0.1, 0.1)'). Computing overlap instead.") - index <- paste0( - "Overlap = ", - format_digit(values$overlap), - "%)." - ) - } - } - } else { - warning("Parameter 'index' should be 'overlap' or 'ROPE'. Computing overlap.") - index <- paste0( - "Overlap = ", - format_digit(values$overlap), - "%)." - ) - } - - - - - - # Text - if (grepl(":", varname)) { - splitted <- strsplit(varname, ":")[[1]] - if (length(splitted) == 2) { - name <- paste0( - "interaction between ", - splitted[1], " and ", splitted[2] - ) - } else { - name <- varname - } - } else { - name <- paste0("effect of ", varname) - } - - direction <- ifelse(values$median > 0, "positive", "negative") - - values$text <- paste0( - " - The ", - name, - " has a probability of ", - format_digit(values$MPE), - "% of being ", - direction, - " (Median = ", - format_digit(values$median), - ", MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1]), ", ", - format_digit(values$CI_values[2]), "], ", - index - ) - - - - # Effize - if (effsize == TRUE) { - posterior_std <- posteriors_std[, varname] - values$std_posterior <- posterior_std - values$std_median <- median(posterior_std) - values$std_mad <- mad(posterior_std) - values$std_mean <- mean(posterior_std) - values$std_sd <- sd(posterior_std) - values$std_CI_values <- HDI(posterior_std, prob = CI / 100) - values$std_CI_values <- c(values$std_CI_values$values$HDImin, values$std_CI_values$values$HDImax) - - if (fit$family$family == "binomial" & fit$family$link == "logit") { - EffSize <- interpret_odds_posterior(posterior_std, log = TRUE, rules = effsize_rules) - } else { - EffSize <- interpret_d_posterior(posterior_std, rules = effsize_rules) - } - - values$EffSize <- EffSize$summary - values$EffSize$Variable <- varname - values$EffSize_text <- EffSize$text - } else { - values$std_median <- NA - values$std_mad <- NA - } - - return(values) -} - - - - - - -#' Coerce to a Data Frame. -#' -#' Functions to check if an object is a data frame, or coerce it if possible. -#' -#' @param x any R object. -#' @param ... additional arguments to be passed to or from methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @method as.data.frame density -#' @export -as.data.frame.density <- function(x, ...) { - df <- data.frame(x = x$x, y = x$y) - - return(df) -} - - - -#' Compare a patient's score to a control group -#' -#' Compare a patient's score to a control group. -#' -#' @param patient Single value (patient's score). -#' @param controls Vector of values (control's scores). -#' @param mean Mean of the control sample. -#' @param sd SD of the control sample. -#' @param n Size of the control sample. -#' @param CI Credible interval bounds. -#' @param treshold Significance treshold. -#' @param iter Number of iterations. -#' @param color_controls Color of the controls distribution. -#' @param color_CI Color of CI distribution. -#' @param color_score Color of the line representing the patient's score. -#' @param color_size Size of the line representing the patient's score. -#' @param alpha_controls Alpha of the CI distribution. -#' @param alpha_CI lpha of the controls distribution. -#' @param verbose Print possible warnings. -#' -#' @return output -#' -#' @examples -#' result <- assess(patient = 124, mean = 100, sd = 15, n = 100) -#' print(result) -#' plot(result) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @details Until relatively recently the standard way of testing for a difference between a case and controls was to convert the case’s score to a z score using the control sample mean and standard deviation (SD). If z was less than -1.645 (i.e., below 95% of the controls) then it was concluded that the case was significantly lower than controls. However, this method has serious disadvantages (Crawford and Garthwaite, 2012). -#' -#' @importFrom stats ecdf -#' @import ggplot2 -#' @import dplyr -#' @export -assess <- function(patient, - mean = 0, - sd = 1, - n = NULL, - controls = NULL, - CI = 95, - treshold = 0.05, - iter = 10000, - color_controls = "#2196F3", - color_CI = "#E91E63", - color_score = "black", - color_size = 2, - alpha_controls = 1, - alpha_CI = 0.8, - verbose = TRUE) { - if (is.null(controls)) { - if (is.null(n)) { - if (verbose == TRUE) { - warning("Sample size (n) not provided, thus set to 1000.") - } - n <- 1000 - } - } - - - - - # If score is list - if (length(patient) > 1) { - if (verbose == TRUE) { - warning("Multiple scores were provided. Returning a list of results.") - } - results <- list() - for (i in seq_len(length(patient))) { - results[[i]] <- crawford.test( - patient[i], - controls, - mean, - sd, - n, - CI, - treshold, - iter, - color_controls, - color_CI, - color_score, - color_size, - alpha_controls, - alpha_CI - ) - return(results) - } - } else { - result <- crawford.test( - patient, - controls, - mean, - sd, - n, - CI, - treshold, - iter, - color_controls, - color_CI, - color_score, - color_size, - alpha_controls, - alpha_CI - ) - return(result) - } -} - - - - - - - - -#' Performs a Bayesian correlation. -#' -#' Performs a Bayesian correlation. -#' -#' @param x First continuous variable. -#' @param y Second continuous variable. -#' @param CI Credible interval bounds. -#' @param iterations The number of iterations to sample. -#' @param effsize_rules_r Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}. -#' @param effsize_rules_bf Grid for effect size interpretation. See \link[=interpret_bf]{interpret_bf}. -#' -#' @return A psychobject. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' x <- psycho::affective$Concealing -#' y <- psycho::affective$Tolerating -#' -#' bayes_cor.test(x, y) -#' summary(bayes_cor.test(x, y)) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom BayesFactor correlationBF posterior -#' @importFrom stats complete.cases cor.test -#' @import dplyr -#' @export -bayes_cor.test <- function(x, y, CI = 90, iterations = 10000, effsize_rules_r = "cohen1988", effsize_rules_bf = "jeffreys1961") { - - - # Varnames ---------------------------------------------------------------- - - - if (is.null(names(x))) { - var1 <- deparse(substitute(x)) - } else { - var1 <- names(x) - x <- pull(x) - } - - if (is.null(names(y))) { - var2 <- deparse(substitute(y)) - } else { - var2 <- names(y) - y <- pull(y) - } - - # Remove missing - var_x <- x[complete.cases(x, y)] - var_y <- y[complete.cases(x, y)] - - # Correlation ------------------------------------------------------------- - - # Stop if same variable - if (cor.test(var_x, var_y)$estimate > 0.999) { - return(1) - } - - - cor <- BayesFactor::correlationBF(var_x, var_y) - posterior <- as.vector(suppressMessages(BayesFactor::posterior(cor, iterations = iterations, progress = FALSE))) - - values <- list() - values$posterior <- posterior - values$bf <- as.vector(cor)[1] - values$median <- median(posterior) - values$mad <- mad(posterior) - values$mean <- mean(posterior) - values$sd <- sd(posterior) - values$CI <- HDI(posterior, prob = CI / 100)$text - values$CI_values <- HDI(posterior, prob = CI / 100) - values$CI_values <- c(values$CI_values$values$HDImin, values$CI_values$values$HDImax) - values$MPE <- mpe(posterior)$MPE - values$MPE_values <- mpe(posterior)$values - - norm <- rnorm_perfect(length(posterior), 0, sd(posterior)) - values$overlap <- overlap(posterior, norm) * 100 - - rope_indices <- rope(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = TRUE) - values$rope_decision <- rope_indices$rope_decision - values$rope_probability <- rope_indices$rope_probability - values$rope_overlap <- rope_indices$rope_overlap - - - summary <- data.frame( - Median = values$median, - MAD = values$mad, - CI_lower = values$CI_values[1], - CI_higher = values$CI_values[2], - MPE = values$MPE, - BF = values$bf, - Overlap = values$overlap, - Rope = values$rope_decision - ) - rownames(summary) <- paste0(var1, " / ", var2) - - values$effect_size <- interpret_r_posterior(posterior, rules = effsize_rules_r) - interpretation_r <- interpret_r(values$median, strength = FALSE, rules = effsize_rules_r) - interpretation_bf <- interpret_bf(values$bf, direction = FALSE, rules = effsize_rules_bf) - if (values$bf < 1) { - interpretation_bf <- paste(interpretation_bf, "in favour of an absence of a ") - } else { - interpretation_bf <- paste(interpretation_bf, "in favour of the existence of a ") - } - - text <- paste0( - "Results of the Bayesian correlation indicate ", - interpretation_bf, - interpretation_r, - " association between ", - var1, - " and ", - var2, - " (r = ", - format_digit(values$median), - ", MAD = ", - format_digit(values$mad), - ", ", - CI, - "% CI [", - format_digit(values$CI_values[1]), - ", ", - format_digit(values$CI_values[2]), - "]). ", - values$effect_size$text - ) - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - -#' Bayesian Correlation Matrix. -#' -#' Bayesian Correlation Matrix. -#' -#' @param df The dataframe. -#' @param df2 Optional dataframe to correlate with the first one. -#' @param reorder Reorder matrix by correlation strength. Only for square matrices. -#' -#' @return A list of dataframes -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' df <- psycho::affective -#' cor <- bayes_cor(df) -#' summary(cor) -#' print(cor) -#' plot(cor) -#' -#' df <- select(psycho::affective, Adjusting, Tolerating) -#' df2 <- select(psycho::affective, -Adjusting, -Tolerating) -#' cor <- bayes_cor(df, df2) -#' summary(cor) -#' print(cor) -#' plot(cor) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -bayes_cor <- function(df, df2 = NULL, reorder = TRUE) { - df <- purrr::keep(df, is.numeric) - - if (!is.null(df2)) { - df2 <- purrr::keep(df2, is.numeric) - combinations <- expand.grid(names(df), names(df2)) - df <- cbind(df, df2) - } else { - combinations <- expand.grid(names(df), names(df)) - } - - size_row <- length(unique(combinations$Var1)) - size_col <- length(unique(combinations$Var2)) - dimnames <- list( - unique(combinations$Var1), - unique(combinations$Var2) - ) - - r <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - mpe <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - bf <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - ci <- matrix(0, nrow = size_row, ncol = size_col, dimnames = dimnames) - text <- matrix("", nrow = size_row, ncol = size_col, dimnames = dimnames) - - counter <- 0 - for (j in seq_len(size_col)) { - for (i in seq_len(size_row)) { - counter <- counter + 1 - - x <- df[[as.character(combinations$Var1[counter])]] - y <- df[[as.character(combinations$Var2[counter])]] - result <- bayes_cor.test(x, y) - - if (!is.psychobject(result)) { - text[i, j] <- "" - r[i, j] <- 1 - mpe[i, j] <- 100 - bf[i, j] <- Inf - ci[i, j] <- "100% CI [1, 1]" - } else { - text[i, j] <- paste0( - " - ", - names(df)[j], - " / ", - names(df)[i], - ": ", - result$text - ) - text[i, j] <- stringr::str_remove(text[i, j], "between x and y ") - r[i, j] <- result$values$median - mpe[i, j] <- result$values$MPE - bf[i, j] <- result$values$bf - ci[i, j] <- result$values$CI - } - } - } - - - # Reorder - if (is.null(df2) & reorder == TRUE) { - r <- reorder_matrix(r, r) - mpe <- reorder_matrix(mpe, r) - bf <- reorder_matrix(bf, r) - ci <- reorder_matrix(ci, r) - text <- reorder_matrix(text, r) - } - - - stars <- ifelse(bf > 30, "***", - ifelse(bf > 10, "**", - ifelse(bf > 3, "*", "") - ) - ) - - - - summary <- round(r, 2) - summary <- matrix(paste(summary, stars, sep = ""), ncol = ncol(r), dimnames = dimnames(r)) - - if (is.null(df2)) { - summary[upper.tri(summary, diag = TRUE)] <- "" # remove upper triangle - summary <- summary[-1, -ncol(summary)] # Remove first row and last column - - text[upper.tri(text, diag = TRUE)] <- "" # remove upper triangle - text <- text[-1, -ncol(text)] # Remove first row and last column - } - - summary <- as.data.frame(summary) - text <- as.vector(text) - text <- text[!text == ""] - - - # Values - values <- list( - r = r, - mpe = mpe, - bf = bf, - ci = ci, - stars = stars - ) - - # Plot - plot <- round(r, 2) %>% - as.data.frame() %>% - tibble::rownames_to_column("Var1") %>% - gather_("Var2", "Correlation", as.character(unique(combinations$Var2))) %>% - ggplot(aes_string(x = "Var2", y = "Var1", fill = "Correlation", label = "Correlation")) + - geom_tile(color = "white") + - scale_fill_gradient2( - low = "#2196F3", high = "#E91E63", mid = "white", - midpoint = 0, limit = c(-1, 1) - ) + - theme_minimal() + - theme( - axis.title = element_blank(), - axis.text.x = element_text( - angle = 45, - vjust = 1, - hjust = 1 - ), - legend.position = "none" - ) + - coord_fixed() + - geom_text(color = "black") - - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) -} - - - -#' Reorder square matrix. -#' -#' Reorder square matrix. -#' -#' @param mat A square matrix. -#' @param dmat A square matrix with values to use as distance. -#' -#' @examples -#' library(psycho) -#' -#' r <- correlation(iris) -#' r <- r$values$r -#' r <- reorder_matrix(r) -#' @importFrom stats as.dist hclust -#' @export -reorder_matrix <- function(mat, dmat = NULL) { - if (is.null(dmat)) { - dmat <- mat - } - - if (ncol(mat) != nrow(mat) | ncol(dmat) != nrow(dmat)) { - warning("Matrix must be squared.") - return(mat) - } - - dmat <- as.dist((1 - dmat) / 2, diag = TRUE, upper = TRUE) - hc <- hclust(dmat) - mat <- mat[hc$order, hc$order] - return(mat) -} - - - - - - - - -#' Citations of loaded packages. -#' -#' Get the citations of loaded packages. -#' -#' @param session A `devtools::sessionInfo()` object. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' cite_packages(sessionInfo()) -#' } -#' -#' @author \href{https://github.com/DominiqueMakowski}{Dominique Makowski} -#' -#' @export -cite_packages <- function(session) { - pkgs <- session$otherPkgs - citations <- c() - for (pkg_name in names(pkgs)) { - pkg <- pkgs[[pkg_name]] - - citation <- format(citation(pkg_name))[[2]] %>% - stringr::str_split("\n") %>% - flatten() %>% - paste(collapse = "SPLIT") %>% - stringr::str_split("SPLITSPLIT") - - i <- 1 - while (stringr::str_detect(citation[[1]][i], "To cite ")) { - i <- i + 1 - } - - - citation <- citation[[1]][i] %>% - stringr::str_remove_all("SPLIT") %>% - stringr::str_trim() %>% - stringr::str_squish() - - citations <- c(citations, citation) - } - return(data.frame("Packages" = citations)) -} - - - - - - - - -#' Multiple Correlations. -#' -#' Compute different kinds of correlation matrices. -#' -#' @param df The dataframe. -#' @param df2 Optional dataframe to correlate with the first one. -#' @param type A character string indicating which correlation type is to be -#' computed. One of "full" (default), "partial" (partial correlations), -#' "semi" (semi-partial correlations), "glasso" -#' (Graphical lasso- estimation of Gaussian graphical models) or "cor_auto" -#' (will use the qgraph::cor_auto function to return pychoric or polyserial -#' correlations if needed). -#' @param method A character string indicating which correlation coefficient is -#' to be computed. One of "pearson" (default), "kendall", or "spearman" can be -#' abbreviated. -#' @param adjust What adjustment for multiple tests should be used? ("holm", -#' "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"). See -#' \link[stats]{p.adjust} for details about why to use "holm" rather than -#' "bonferroni"). -#' @param i_am_cheating Set to TRUE to run many uncorrected correlations. -#' -#' @return output -#' -#' @examples -#' df <- attitude -#' -#' # Normal correlations -#' results <- psycho::correlation(df) -#' print(results) -#' plot(results) -#' -#' # Partial correlations with correction -#' results <- psycho::correlation(df, -#' type = "partial", -#' method = "spearman", -#' adjust = "holm" -#' ) -#' print(results) -#' plot(results) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats na.omit p.adjust cor runif -#' @importFrom psych corr.test -#' @importFrom ggplot2 theme element_text -#' @importFrom stringr str_to_title -#' @import ggcorrplot -#' @import ppcor -#' @import dplyr -#' @export -correlation <- function(df, - df2 = NULL, - type = "full", - method = "pearson", - adjust = "holm", - i_am_cheating = FALSE) { - - # Processing - # ------------------- - if (method == "bayes" | method == "bayesian") { - return(bayes_cor(df, df2, reorder = TRUE)) - } - - - # N samples - n <- nrow(df) - - # Remove non numeric - df <- purrr::keep(df, is.numeric) - if (is.null(df2) == FALSE) { - df2 <- purrr::keep(df2, is.numeric) - } - - # P-fishing prevention - if (ncol(df) > 10 && adjust == "none" && i_am_cheating == FALSE) { - warning("We've detected that you are running a lot (> 10) of correlation tests without adjusting the p values. To help you in your p-fishing, we've added some interesting variables: You never know, you might find something significant!\nTo deactivate this, change the 'i_am_cheating' argument to TRUE.") - df_complete <- dplyr::mutate_all(df, dplyr::funs_("replace(., is.na(.), 0)")) - df$Local_Air_Density <- svd(df_complete)$u[, 1] - df$Reincarnation_Cycle <- runif(nrow(df), max = 100) - df$Communism_Level <- -1 * svd(df_complete)$u[, 2] - df$Alien_Mothership_Distance <- rnorm(nrow(df), mean = 50000, sd = 5000) - df$Schopenhauers_Optimism <- svd(df_complete)$u[, 3] - df$Hulks_Power <- runif(nrow(df), max = 10) - } - - - - # Compute r coefficients - if (type == "full") { - corr <- psych::corr.test(df, y = df2, use = "pairwise", method = method, adjust = "none") - r <- corr$r - p <- corr$p - t <- corr$t - ci <- corr$ci - ci.adj <- corr$ci.adj - } else { - if (is.null(df2) == FALSE) { - df <- cbind(df, df2) - } - - df <- stats::na.omit(df) # enable imputation - if (type == "semi") { - corr <- ppcor::spcor(df, method = method) - r <- corr$estimate - p <- corr$p.value - t <- corr$statistic - ci <- "Not available for partial and semipartial correlations." - ci.adj <- "Not available for partial and semipartial correlations." - } - else if (type == "partial") { - corr <- ppcor::pcor(df, method = method) - r <- corr$estimate - p <- corr$p.value - t <- corr$statistic - ci <- "Not available for partial and semipartial correlations." - ci.adj <- "Not available for partial and semipartial correlations." - } - else if (type == "glasso") { - corr <- qgraph::EBICglasso(cor(df), n, gamma = 0.5) - r <- corr - p <- NULL - t <- NULL - ci <- "Not available for glasso estimation." - ci.adj <- "Not available for glasso estimation." - } - else if (type == "cor_auto") { - corr <- qgraph::cor_auto(df, forcePD = FALSE) - r <- corr - p <- NULL - t <- NULL - ci <- "Not available for cor_auto estimation." - ci.adj <- "Not available for cor_auto estimation." - } - else { - warning("type parameter must be 'full', 'semi', 'partial', 'glasso' or 'cor_auto'") - return() - } - } - - - - # Adjust P values - if (is.null(p) == FALSE) { - if (adjust != "none") { - if ((type == "full" & is.null(df2) == FALSE) | (type == "semi")) { - p[, ] <- p.adjust(p, method = adjust) - } else { - p[lower.tri(p)] <- p.adjust(p[lower.tri(p)], method = adjust, n = choose(nrow(p), 2)) - p[upper.tri(p)] <- p.adjust(p[upper.tri(p)], method = adjust, n = choose(nrow(p), 2)) - } - } - } - - - - - # Values - # ------------- - values <- list(r = r, p = p, t = t, ci = ci, ci.adj = ci.adj, n = n) - - - - - - # Summary - # ------------- - - # Define notions for significance levels; spacing is important. - if (is.null(p) == FALSE) { - stars <- ifelse(p < .001, "***", - ifelse(p < .01, "** ", - ifelse(p < .05, "* ", " ") - ) - ) - } else { - stars <- "" - } - - - # build a new correlation matrix with significance stars - table <- matrix(paste0(round(r, 2), stars), ncol = ncol(r)) - - - # Format - rownames(table) <- colnames(df) - if (isSymmetric(r)) { - diag(table) <- paste0(diag(round(r, 2)), " ") - colnames(table) <- colnames(df) - table[upper.tri(table, diag = TRUE)] <- "" # remove upper triangle - table <- as.data.frame(table) - # remove last column and return the matrix (which is now a data frame) - summary <- cbind(table[seq_len(length(table) - 1)]) - } else { - if (is.null(df2)) { - colnames(table) <- colnames(df) - } else { - if (type == "semi") { - colnames(table) <- colnames(df) - } else { - colnames(table) <- colnames(df2) - } - } - table <- as.data.frame(table) - summary <- table - } - - - - - # Text - # ------------- - sentences <- c() - for (row in seq_len(nrow(r))) { - for (col in seq_len(ncol(r))) { - if (as.matrix(table)[row, col] == "") next # skip iteration and go to next iteration - - val_r <- as.matrix(r)[row, col] - val_t <- tryCatch({ - as.matrix(t)[row, col] - }, error = function(e) { - "NA" - }) - val_p <- tryCatch({ - as.matrix(p)[row, col] - }, error = function(e) { - "NA" - }) - var1 <- colnames(r)[col] - var2 <- row.names(r)[row] - - if (is.numeric(val_p) & val_p <= .05) { - significance <- "significant " - } else if (is.numeric(val_p) & val_p > .05) { - significance <- "non significant " - } else { - significance <- "" - } - - - sentence <- paste0( - " - ", - var1, - " / ", - var2, - ": ", - "Results of the ", - stringr::str_to_title(method), - " correlation showed a ", - significance, - interpret_r(val_r), - " association between ", - var1, - " and ", - var2, - " (r(", - n - 2, - ") = ", - psycho::format_digit(val_r), - ", p ", - psycho::format_p(val_p), - ")." - ) - - sentences <- c(sentences, sentence) - } - } - - sentences <- c(paste0( - stringr::str_to_title(method), - " ", - stringr::str_to_title(type), - " correlation (p value correction: ", - adjust, - "):\n" - ), sentences) - - text <- sentences - - - - - # Plot - # ------------- - if (is.null(df2) == FALSE & type == "full") { - corr <- psych::corr.test(cbind(df, df2), use = "pairwise", method = method, adjust = "none") - r <- corr$r - p <- corr$p - p[lower.tri(p)] <- p.adjust(p[lower.tri(p)], method = adjust, n = choose(nrow(p), 2)) - p[upper.tri(p)] <- p.adjust(p[upper.tri(p)], method = adjust, n = choose(nrow(p), 2)) - # warning("Due to the presence of two dataframes, the plot might be incorrect. Consider with caution.") - } - - if (type == "semi") { - plot <- ggcorrplot::ggcorrplot( - r, - title = paste("A ", type, "'s correlation matrix (correction: ", adjust, ")\n", sep = ""), - method = "circle", - type = "full", - colors = c("#E91E63", "white", "#03A9F4"), - hc.order = TRUE, - p.mat = p, - insig = "pch", - legend.title = "", - lab = FALSE - ) + - ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.7)) - } else { - plot <- ggcorrplot::ggcorrplot( - r, - title = paste("A ", type, "'s correlation matrix (correction: ", adjust, ")\n", sep = ""), - method = "circle", - type = "lower", - colors = c("#E91E63", "white", "#03A9F4"), - hc.order = TRUE, - p.mat = p, - insig = "pch", - legend.title = "", - lab = FALSE - ) + - ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.7)) - } - - - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "psychobject_correlation", "list") - return(output) -} - - - - - - - - - - - -#' Crawford-Garthwaite (2007) Bayesian test for single-case analysis. -#' -#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2007) demonstrate that the Bayesian test is a better approach than other commonly-used alternatives. -#' . -#' -#' @param patient Single value (patient's score). -#' @param controls Vector of values (control's scores). -#' @param mean Mean of the control sample. -#' @param sd SD of the control sample. -#' @param n Size of the control sample. -#' @param CI Credible interval bounds. -#' @param treshold Significance treshold. -#' @param iter Number of iterations. -#' @param color_controls Color of the controls distribution. -#' @param color_CI Color of CI distribution. -#' @param color_score Color of the line representing the patient's score. -#' @param color_size Size of the line representing the patient's score. -#' @param alpha_controls Alpha of the CI distribution. -#' @param alpha_CI lpha of the controls distribution. -#' -#' -#' @details The p value obtained when this test is used to test significance also simultaneously provides a point estimate of the abnormality of the patient’s score; for example if the one-tailed probability is .013 then we know that the patient’s score is significantly (p < .05) below the control mean and that it is estimated that 1.3% of the control population would obtain a score lower than the patient’s. As for the credible interval interpretation, we could say that there is a 95% probability that the true level of abnormality of the patient’s score lies within the stated limits, or that There is 95% confidence that the percentage of people who have a score lower than the patient’s is between 0.01% and 6.66%. -#' -#' @examples -#' library(psycho) -#' -#' crawford.test(patient = 125, mean = 100, sd = 15, n = 100) -#' plot(crawford.test(patient = 80, mean = 100, sd = 15, n = 100)) -#' -#' crawford.test(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' test <- crawford.test(patient = 7, controls = c(0, -2, 5, -6, 0, 3, -4, -2)) -#' plot(test) -#' @author Dominique Makowski -#' -#' @importFrom stats pnorm var approx rchisq -#' @importFrom scales rescale -#' @import ggplot2 -#' @export -crawford.test <- function(patient, - controls = NULL, - mean = NULL, - sd = NULL, - n = NULL, - CI = 95, - treshold = 0.1, - iter = 10000, - color_controls = "#2196F3", - color_CI = "#E91E63", - color_score = "black", - color_size = 2, - alpha_controls = 1, - alpha_CI = 0.8) { - if (is.null(controls)) { - # Check if a parameter is null - if (length(c(mean, sd, n)) != 3) { - stop("Please provide either controls or mean, sd and n.") - } - sample_mean <- mean - sample_sd <- sd - sample_var <- sd^2 - } else { - sample_mean <- mean(controls) - sample_var <- var(controls) - sample_sd <- sd(controls) - n <- length(controls) - } - degfree <- n - 1 - - - # Computation ------------------------------------------------------------- - - - pvalues <- c() - for (i in 1:iter) { - # step 1 - psi <- rchisq(1, df = degfree, ncp = 0) - o <- (n - 1) * sample_var / psi - - # step 2 - z <- rnorm(1, 0, 1) - u <- sample_mean + z * sqrt((o / n)) - - # step 3 - z_patient <- (patient - u) / sqrt(o) - p <- 2 * (1 - pnorm(abs(z_patient), lower.tail = TRUE)) # One-tailed p-value - pvalues <- c(pvalues, p) - } - - - # Point estimates --------------------------------------------------------- - - z_score <- (patient - sample_mean) / sample_sd - perc <- percentile(z_score) - - pvalues <- pvalues / 2 - p <- mean(pvalues) - CI <- HDI(pvalues, prob = CI / 100) - # CI_1 <- sort(pvalues)[iter * (100 - CI) / 100] - - - # Text -------------------------------------------------------------------- - - p_interpretation <- ifelse(p < treshold, " significantly ", " not significantly ") - direction <- ifelse(patient - sample_mean < 0, " lower than ", " higher than ") - - - text <- paste0( - "The Bayesian test for single case assessment (Crawford, Garthwaite, 2007) suggests that the patient's score (Raw = ", - format_digit(patient), - ", Z = ", - format_digit(z_score), - ", percentile = ", - format_digit(perc), - ") is", - p_interpretation, - "different from the controls (M = ", - format_digit(sample_mean), - ", SD = ", - format_digit(sample_sd), - ", p ", - format_p(p), - ").", - " The patient's score is", - direction, - format_digit((1 - p) * 100), - "% (95% CI [", - paste(format_digit(sort(c((1 - CI$values$HDImin) * 100, (1 - CI$values$HDImax) * 100))), collapse = ", "), - "]) of the control population." - ) - - - - # Store values ------------------------------------------------------------ - - values <- list( - patient_raw = patient, - patient_z = z_score, - patient_percentile = perc, - controls_mean = sample_mean, - controls_sd = sample_sd, - controls_var = sample_var, - controls_sd = sample_sd, - controls_n = n, - text = text, - p = p, - CI_lower = CI$values$HDImin, - CI_higher = CI$values$HDImax - ) - - summary <- data.frame( - controls_mean = sample_mean, - controls_sd = sample_sd, - controls_n = n, - p = p, - CI_lower = CI$values$HDImin, - CI_higher = CI$values$HDImax - ) - - if (is.null(controls)) { - controls <- rnorm_perfect(n, sample_mean, sample_sd) - } - - - # Plot -------------------------------------------------------------------- - if (patient - sample_mean < 0) { - uncertainty <- percentile_to_z(pvalues * 100) - } else { - uncertainty <- percentile_to_z((1 - pvalues) * 100) - } - - - - - plot <- rnorm_perfect(length(uncertainty), 0, 1) %>% - density() %>% - as.data.frame() %>% - mutate_(y = "y/max(y)") %>% - mutate(distribution = "Control") %>% - rbind(uncertainty %>% - density() %>% - as.data.frame() %>% - mutate_(y = "y/max(y)") %>% - mutate(distribution = "Uncertainty")) %>% - mutate_(x = "scales::rescale(x, from=c(0, 1), to = c(sample_mean, sample_mean+sample_sd))") %>% - ggplot(aes_string(x = "x", ymin = 0, ymax = "y")) + - geom_ribbon(aes_string(fill = "distribution", alpha = "distribution")) + - geom_vline(xintercept = patient, colour = color_score, size = color_size) + - scale_fill_manual(values = c(color_controls, color_CI)) + - scale_alpha_manual(values = c(alpha_controls, alpha_CI)) + - xlab("\nScore") + - ylab("") + - theme_minimal() + - theme( - legend.position = "none", - axis.ticks.y = element_blank(), - axis.text.y = element_blank() - ) - - - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - -#' Crawford-Howell (1998) frequentist t-test for single-case analysis. -#' -#' Neuropsychologists often need to compare a single case to a small control group. However, the standard two-sample t-test does not work because the case is only one observation. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. -#' . -#' -#' @param patient Single value (patient's score). -#' @param controls Vector of values (control's scores). -#' -#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the patient is different from the control group. -#' -#' @examples -#' library(psycho) -#' -#' crawford.test.freq(patient = 10, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' crawford.test.freq(patient = 7, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' @author Dan Mirman, Dominique Makowski -#' -#' @importFrom stats pt sd -#' @export -crawford.test.freq <- function(patient, controls) { - tval <- (patient - mean(controls)) / (sd(controls) * sqrt((length(controls) + 1) / length(controls))) - - degfree <- length(controls) - 1 - - pval <- 2 * (1 - pt(abs(tval), df = degfree)) # One-tailed p-value - - # One-tailed p value - if (pval > .05 & pval / 2 < .05) { - one_tailed <- paste0( - " However, the null hypothesis of no difference can be rejected at a one-tailed 5% significance level (one-tailed p ", - format_p(pval / 2), - ")." - ) - } else { - one_tailed <- "" - } - - - p_interpretation <- ifelse(pval < 0.05, " significantly ", " not significantly ") - t_interpretation <- ifelse(tval < 0, " lower than ", " higher than ") - - text <- paste0( - "The Crawford-Howell (1998) t-test suggests that the patient's score (", - format_digit(patient), - ") is", - p_interpretation, - "different from the controls (M = ", - format_digit(mean(controls)), - ", SD = ", - format_digit(sd(controls)), - ", t(", - degfree, - ") = ", - format_digit(tval), - ", p ", - format_p(pval), - ").", - one_tailed, - " The patient's score is", - t_interpretation, - format_digit((1 - pval) * 100), - "% of the control population." - ) - - values <- list( - text = text, - p = pval, - df = degfree, - t = tval - ) - summary <- data.frame(t = tval, df = degfree, p = pval) - plot <- "Not available yet" - - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - -#' Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks. -#' -#' Assessing dissociation between processes is a fundamental part of clinical neuropsychology. However, while the detection of suspected impairments is a fundamental feature of single-case studies, evidence of an impairment on a given task usually becomes of theoretical interest only if it is observed in the context of less impaired or normal performance on other tasks. Crawford and Garthwaite (2012) demonstrate that the Crawford-Howell (1998) t-test for dissociation is a better approach (in terms of controlling Type I error rate) than other commonly-used alternatives. -#' . -#' -#' @param case_X Single value (patient's score on test X). -#' @param case_Y Single value (patient's score on test Y). -#' @param controls_X Vector of values (control's scores of X). -#' @param controls_Y Vector of values (control's scores of Y). -#' @param verbose True or False. Prints the interpretation text. -#' -#' @return Returns a data frame containing the t-value, degrees of freedom, and p-value. If significant, the dissociation between test X and test Y is significant. -#' -#' @examples -#' library(psycho) -#' -#' case_X <- 142 -#' case_Y <- 7 -#' controls_X <- c(100, 125, 89, 105, 109, 99) -#' controls_Y <- c(7, 8, 9, 6, 7, 10) -#' -#' crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y) -#' @author Dominique Makowski -#' -#' @importFrom stats sd pt -#' @export -crawford_dissociation.test <- function(case_X, case_Y, controls_X, controls_Y, verbose = TRUE) { - X_mean <- mean(controls_X) - X_sd <- sd(controls_X) - Y_mean <- mean(controls_Y) - Y_sd <- sd(controls_Y) - r <- cor(controls_X, controls_Y) - n <- length(controls_X) - degfree <- n - 1 - - case_X_Z <- (case_X - X_mean) / X_sd - case_Y_Z <- (case_Y - Y_mean) / Y_sd - - tval <- (case_X_Z - case_Y_Z) / sqrt((2 - 2 * r) * ((n + 1) / n)) - - pval <- 2 * (1 - pt(abs(tval), df = degfree)) # two-tailed p-value - - - - - - p_interpretation <- ifelse(pval < 0.05, " a significant ", " no ") - p_interpretation2 <- ifelse(pval < 0.05, " ", " not ") - z_interpretation <- ifelse(tval < 0, " below ", " above ") - pop_interpretation <- ifelse(tval < 0, " above ", " below ") - - if (abs(case_X_Z) > abs(case_Y_Z)) { - var_interpretation1 <- "test X" - var_interpretation2 <- "test Y" - } else { - var_interpretation1 <- "test Y" - var_interpretation2 <- "test X" - } - - text <- paste0( - "The Crawford-Howell (1998) t-test suggests", - p_interpretation, - "dissociation between test X and test Y (t(", - degfree, - ") = ", - format_digit(tval), - ", p ", - format_p(pval), - "). The patient's score on ", - var_interpretation1, - " is", - p_interpretation2, - "significantly altered compared to its score on ", - var_interpretation2, - "." - ) - - - result <- data.frame(t = tval, df = degfree, p = pval) - - if (verbose == TRUE) { - cat(paste0(text, "\n\n")) - } - - return(result) -} - - - - - - - -#' Overlap of Two Empirical Distributions. -#' -#' A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). -#' -#' @param x A vector of numerics. -#' @param n Number of intervals to create, OR -#' @param length Length of each interval. -#' @param equal_range Makes n groups with with equal range (TRUE) or (approximately) equal numbers of observations (FALSE). -#' @param labels Can be a custom list, "NULL", "FALSE" or "median". -#' @param dig.lab Integer which is used when labels are not given. It determines the number of digits used in formatting the break numbers. -#' -#' @examples -#' library(psycho) -#' -#' x <- rnorm(100, 0, 1) -#' -#' create_intervals(x, n = 4) -#' create_intervals(x, n = 4, equal_range = FALSE) -#' create_intervals(x, length = 1) -#' -#' create_intervals(x, n = 4, labels = "median") -#' create_intervals(x, n = 4, labels = FALSE) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom ggplot2 cut_interval cut_number -#' @export -create_intervals <- function(x, n = NULL, length = NULL, equal_range = TRUE, labels = NULL, dig.lab = 3) { - if (equal_range) { - if (is.character(labels) && labels == "median") { - cuts <- ggplot2::cut_interval(x, n = n, length = length, labels = FALSE) - } else { - cuts <- ggplot2::cut_interval(x, n = n, length = length, labels = labels, dig.lab = dig.lab) - } - } else { - if (is.character(labels) && labels == "median") { - cuts <- ggplot2::cut_number(x, n = n, labels = FALSE) - } else { - cuts <- ggplot2::cut_number(x, n = n, labels = labels, dig.lab = dig.lab) - } - } - - - if (is.character(labels) && labels == "median") { - cuts <- cuts %>% - data.frame(x) %>% - group_by_(".") %>% - mutate_("cuts" = "median(x)") %>% - ungroup() %>% - select_("cuts") %>% - pull() - } - - return(cuts) -} - - - - - - - - - - - -#' Dprime and Other Signal Detection Theory indices. -#' -#' Computes Signal Detection Theory indices (d', beta, A', B''D, c). -#' -#' @param n_hit Number of hits. -#' @param n_fa Number of false alarms. -#' @param n_miss Number of misses. -#' @param n_cr Number of correct rejections. -#' @param n_targets Number of targets (n_hit + n_miss). -#' @param n_distractors Number of distractors (n_fa + n_cr). -#' @param adjusted Should it use the Hautus (1995) adjustments for extreme values. -#' -#' @return Calculates the d', the beta, the A' and the B''D based on the signal detection theory (SRT). See Pallier (2002) for the algorithms. -#' -#' Returns a list containing the following indices: -#' \itemize{ -#' \item{\strong{dprime (d')}: }{The sensitivity. Reflects the distance between the two distributions: signal, and signal+noise and corresponds to the Z value of the hit-rate minus that of the false-alarm rate.} -#' \item{\strong{beta}: }{The bias (criterion). The value for beta is the ratio of the normal density functions at the criterion of the Z values used in the computation of d'. This reflects an observer's bias to say 'yes' or 'no' with the unbiased observer having a value around 1.0. As the bias to say 'yes' increases (liberal), resulting in a higher hit-rate and false-alarm-rate, beta approaches 0.0. As the bias to say 'no' increases (conservative), resulting in a lower hit-rate and false-alarm rate, beta increases over 1.0 on an open-ended scale.} -#' \item{\strong{c}: }{Another index of bias. the number of standard deviations from the midpoint between these two distributions, i.e., a measure on a continuum from "conservative" to "liberal".} -#' \item{\strong{aprime (A')}: }{Non-parametric estimate of discriminability. An A' near 1.0 indicates good discriminability, while a value near 0.5 means chance performance.} -#' \item{\strong{bppd (B''D)}: }{Non-parametric estimate of bias. A B''D equal to 0.0 indicates no bias, positive numbers represent conservative bias (i.e., a tendency to answer 'no'), negative numbers represent liberal bias (i.e. a tendency to answer 'yes'). The maximum absolute value is 1.0.} -#' } -#' -#' -#' Note that for d' and beta, adjustement for extreme values are made following the recommandations of Hautus (1995). - - -#' @examples -#' library(psycho) -#' -#' n_hit <- 9 -#' n_fa <- 2 -#' n_miss <- 1 -#' n_cr <- 7 -#' -#' indices <- psycho::dprime(n_hit, n_fa, n_miss, n_cr) -#' -#' -#' df <- data.frame( -#' Participant = c("A", "B", "C"), -#' n_hit = c(1, 2, 5), -#' n_fa = c(6, 8, 1) -#' ) -#' -#' indices <- psycho::dprime( -#' n_hit = df$n_hit, -#' n_fa = df$n_fa, -#' n_targets = 10, -#' n_distractors = 10, -#' adjusted = FALSE -#' ) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats qnorm -#' @export -dprime <- function(n_hit, n_fa, n_miss = NULL, n_cr = NULL, n_targets = NULL, n_distractors = NULL, adjusted = TRUE) { - if (is.null(n_targets)) { - n_targets <- n_hit + n_miss - } - - if (is.null(n_distractors)) { - n_distractors <- n_fa + n_cr - } - - - # Parametric Indices ------------------------------------------------------ - - - if (adjusted == TRUE) { - if (is.null(n_miss) | is.null(n_cr)) { - warning("Please provide n_miss and n_cr in order to compute adjusted ratios. Computing indices anyway with non-adjusted ratios...") - - # Non-Adjusted ratios - hit_rate_adjusted <- n_hit / n_targets - fa_rate_adjusted <- n_fa / n_distractors - } else { - # Adjusted ratios - hit_rate_adjusted <- (n_hit + 0.5) / ((n_hit + 0.5) + n_miss + 1) - fa_rate_adjusted <- (n_fa + 0.5) / ((n_fa + 0.5) + n_cr + 1) - } - - # dprime - dprime <- qnorm(hit_rate_adjusted) - qnorm(fa_rate_adjusted) - - # beta - zhr <- qnorm(hit_rate_adjusted) - zfar <- qnorm(fa_rate_adjusted) - beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) - - # c - c <- -(qnorm(hit_rate_adjusted) + qnorm(fa_rate_adjusted)) / 2 - } else { - # Ratios - hit_rate <- n_hit / n_targets - fa_rate <- n_fa / n_distractors - - # dprime - dprime <- qnorm(hit_rate) - qnorm(fa_rate) - - # beta - zhr <- qnorm(hit_rate) - zfar <- qnorm(fa_rate) - beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) - - # c - c <- -(qnorm(hit_rate) + qnorm(fa_rate)) / 2 - } - - # Non-Parametric Indices ------------------------------------------------------ - - # Ratios - hit_rate <- n_hit / n_targets - fa_rate <- n_fa / n_distractors - - # aprime - a <- 1 / 2 + ((hit_rate - fa_rate) * (1 + hit_rate - fa_rate) / (4 * hit_rate * (1 - fa_rate))) - b <- 1 / 2 - ((fa_rate - hit_rate) * (1 + fa_rate - hit_rate) / (4 * fa_rate * (1 - hit_rate))) - - a[fa_rate > hit_rate] <- b[fa_rate > hit_rate] - a[fa_rate == hit_rate] <- .5 - aprime <- a - - # bppd - bppd <- (hit_rate * (1 - hit_rate) - fa_rate * (1 - fa_rate)) / (hit_rate * (1 - hit_rate) + fa_rate * (1 - fa_rate)) - bppd_b <- (fa_rate * (1 - fa_rate) - hit_rate * (1 - hit_rate)) / (fa_rate * (1 - fa_rate) + hit_rate * (1 - hit_rate)) - bppd[fa_rate > hit_rate] <- bppd_b[fa_rate > hit_rate] - - - - return(list(dprime = dprime, beta = beta, aprime = aprime, bppd = bppd, c = c)) -} - - - - - - - - -#' Returns all combinations of lavaan models with their indices of fit. -#' -#' Returns all combinations of lavaan models with their indices of fit. -#' -#' @param fit A lavaan object. -#' @param latent Copy/paste the part related to latent variables loadings. -#' @param samples Number of random draws. -#' @param verbose Show progress. -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' library(psycho) -#' library(lavaan) -#' -#' model <- " visual =~ x1 + x2 + x3 -#' textual =~ x4 + x5 + x6 -#' speed =~ x7 + x8 + x9 -#' visual ~ textual -#' textual ~ speed" -#' fit <- lavaan::sem(model, data = HolzingerSwineford1939) -#' -#' models <- find_best_model(fit, latent = "visual =~ x1 + x2 + x3 -#' textual =~ x4 + x5 + x6 -#' speed =~ x7 + x8 + x9") -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' -#' @method find_best_model lavaan -#' @export -find_best_model.lavaan <- function(fit, latent = "", samples = 1000, verbose = FALSE, ...) { - update_model <- function(fit, latent, model) { - newfit <- update(fit, paste0(latent, "\n", model)) - - indices <- data.frame(Value = lavaan::fitMeasures(newfit)) %>% - tibble::rownames_to_column("Index") %>% - tidyr::spread_("Index", "Value") %>% - cbind(data.frame( - model = model, - n_links = nrow(lavaan::lavInspect(fit, "est")$beta) - )) - return(indices) - } - - vars <- row.names(lavaan::lavInspect(fit, "est")$beta) - # info <- fit@Model - - data <- data.frame() - for (outcome in vars) { - remaning_vars <- vars[!stringr::str_detect(vars, outcome)] - combinations <- c() - for (y in 1:length(remaning_vars)) { - combinations <- c(combinations, combn(remaning_vars, y, simplify = FALSE)) - } - combinations <- sapply(combinations, paste0, collapse = "+") - combinations <- paste0(outcome, "~", combinations) - x <- data.frame(A = combinations) - names(x) <- c(outcome) - if (nrow(data) == 0) { - data <- x - } else { - data <- cbind(data, x) - } - } - - data <- rbind(data, head(data[NA, ], 1)) - data[] <- lapply(data, as.character) - data[is.na(data)] <- "" - rownames(data) <- NULL - - out <- data.frame() - for (i in 1:samples) { - if (verbose == TRUE) { - cat(".") - } - model <- "" - for (var in names(data)) { - model <- paste0(model, sample(data[[var]], 1), "\n") - } - - if (!model %in% out$model) { - out <- tryCatch( - rbind(out, update_model(fit, latent, model)), - error = function(e) out, - warning = function(w) out - ) - } - } - return(out) -} - - - - - - - - -#' Returns the best combination of predictors for lmerTest objects. -#' -#' Returns the best combination of predictors for lmerTest objects. -#' -#' @param fit A merModLmerTest object. -#' @param interaction Include interaction term. -#' @param fixed Additional formula part to add at the beginning of -#' each formula -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(lmerTest) -#' -#' data <- standardize(iris) -#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = data) -#' -#' best <- find_best_model(fit) -#' best_formula <- best$formula -#' best$table -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats update -#' @import dplyr -#' -#' @method find_best_model lmerModLmerTest -#' @export -find_best_model.lmerModLmerTest <- function(fit, interaction = TRUE, fixed = NULL, ...) { - - # Extract infos - combinations <- find_combinations(as.formula(get_formula(fit)), interaction = interaction, fixed = fixed) - - - # Recreating the dataset without NA - dataComplete <- fit@frame[complete.cases(fit@frame), ] - - - # fit models - models <- c() - for (formula in combinations) { - newfit <- update(fit, formula, data = dataComplete) - models <- c(models, newfit) - } - - - # No warning messages for this part - options(warn = -1) - - # Model comparison - comparison <- as.data.frame(do.call("anova", models)) - - # Re-displaying warning messages - options(warn = 0) - - # Creating row names to the combinations array equivalent to the comparison data frame - combinations <- as.data.frame(combinations, row.names = paste0("MODEL", seq(1, length(combinations)))) - - # Reordering the rows in the same way for both combinations and comparison before implementing the formulas - comparison <- comparison[ order(row.names(comparison)), ] - comparison$formula <- combinations[order(row.names(combinations)), ] - - # Sorting the data frame by the AIC then BIC - comparison <- comparison[order(comparison$AIC, comparison$BIC), ] - - - - # Best model by criterion - best_aic <- dplyr::arrange_(comparison, "AIC") %>% - dplyr::select_("formula") %>% - head(1) - best_aic <- as.character(best_aic[[1]]) - - best_bic <- dplyr::arrange_(comparison, "BIC") %>% - dplyr::select_("formula") %>% - head(1) - best_bic <- as.character(best_bic[[1]]) - - by_criterion <- data.frame(formula = c(best_aic, best_bic), criterion = c("AIC", "BIC")) - - # Best formula - best <- table(by_criterion$formula) - best <- names(best[which.max(best)]) - - best <- list(formula = best, by_criterion = by_criterion, table = comparison) - return(best) -} - - - - - - - - -#' Returns the best model. -#' -#' Returns the best model. See the -#' documentation for your model's class: -#' \itemize{ -#' \item{\link[=find_best_model.stanreg]{find_best_model.stanreg}} -#' \item{\link[=find_best_model.lmerModLmerTest]{find_best_model.lmerModLmerTest}} -#' } -#' -#' @param fit Model -#' @param ... Arguments passed to or from other methods. -#' -#' @seealso \code{\link{find_best_model.stanreg}} -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_best_model <- function(fit, ...) { - UseMethod("find_best_model") -} - - - - - - - - - -#' Returns the best combination of predictors based on LOO cross-validation indices. -#' -#' Returns the best combination of predictors based on LOO cross-validation indices. -#' -#' @param fit A stanreg object. -#' @param interaction Include interaction term. -#' @param fixed Additional formula part to add at the beginning of -#' each formula -#' @param K For kfold, the number of subsets of equal (if possible) size into -#' which the data will be randomly partitioned for performing K-fold -#' cross-validation. The model is refit K times, each time leaving out one of -#' the K subsets. If K is equal to the total number of observations in the data -#' then K-fold cross-validation is equivalent to exact leave-one-out -#' cross-validation. -#' @param k_treshold Threshold for flagging estimates of the Pareto shape -#' parameters k estimated by loo. -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' data <- standardize(attitude) -#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) -#' -#' best <- find_best_model(fit) -#' best_formula <- best$formula -#' best$table -#' -#' # To deactivate Kfold evaluation -#' best <- find_best_model(fit, K = 0) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom rstanarm bayes_R2 -#' @importFrom loo loo kfold -#' @importFrom stats update median -#' @import dplyr -#' -#' @method find_best_model stanreg -#' @export -find_best_model.stanreg <- function(fit, interaction = TRUE, fixed = NULL, K = 10, k_treshold = NULL, ...) { - - # Extract infos - combinations <- find_combinations(fit$formula, interaction = interaction, fixed = fixed) - - # Compute fitting indices - loos <- list() - kfolds <- list() - complexities <- list() - R2s <- list() - for (i in seq_len(length(combinations))) { - print(paste0(i, "/", length(combinations))) - - formula <- combinations[i] - newfit <- update(fit, formula = formula, verbose = FALSE) - R2s[[formula]] <- median(rstanarm::bayes_R2(newfit)) - - - if (!is.null(k_treshold)) { - loo <- loo::loo(newfit, k_treshold = k_treshold) - } else { - loo <- loo::loo(newfit) - } - - - complexities[[formula]] <- length(newfit$coefficients) - loos[[formula]] <- loo - if (K > 1) { - kfold <- loo::kfold(newfit, K = K) - } else { - kfold <- list(elpd_kfold = 0, se_elpd_kfold = 0) - } - kfolds[[formula]] <- kfold - } - - # Model comparison - comparison <- data.frame() - for (formula in names(loos)) { - loo <- loos[[formula]] - kfold <- kfolds[[formula]] - complexity <- complexities[[formula]] - Estimates <- loo[["estimates"]] - model <- data.frame( - formula = formula, - complexity = complexity - 1, - R2 = R2s[[formula]], - looic = Estimates["looic", "Estimate"], - looic_se = Estimates["looic", "SE"], - elpd_loo = Estimates["elpd_loo", "Estimate"], - elpd_loo_se = Estimates["elpd_loo", "SE"], - p_loo = Estimates["p_loo", "Estimate"], - p_loo_se = Estimates["p_loo", "SE"], - elpd_kfold = Estimates["p_loo", "Estimate"], - elpd_kfold_se = Estimates["p_loo", "SE"] - ) - comparison <- rbind(comparison, model) - } - - # Format - comparison <- comparison %>% - dplyr::mutate_( - "looic_d" = "looic - min(looic)", - "elpd_loo_d" = "elpd_loo - max(elpd_loo)", - "elpd_kfold_d" = "elpd_kfold - max(elpd_kfold)" - ) - - # Best model by criterion - best_looic <- dplyr::arrange_(comparison, "looic") %>% - dplyr::select_("formula") %>% - head(1) - best_looic <- as.character(best_looic[[1]]) - - best_elpd_loo <- dplyr::arrange_(comparison, "desc(elpd_loo)") %>% - dplyr::select_("formula") %>% - head(1) - best_elpd_loo <- as.character(best_elpd_loo[[1]]) - - if (K > 1) { - best_elpd_kfold <- dplyr::arrange_(comparison, "desc(elpd_kfold)") %>% - dplyr::select_("formula") %>% - head(1) - best_elpd_kfold <- as.character(best_elpd_kfold[[1]]) - } else { - best_elpd_kfold <- NA - } - - by_criterion <- data.frame(formula = c(best_looic, best_elpd_loo, best_elpd_kfold), criterion = c("looic", "elpd_loo", "elpd_kfold")) - - # Best formula - best <- table(by_criterion$formula) - best <- names(best[which.max(best)]) - - best <- list(formula = best, by_criterion = by_criterion, table = comparison) - return(best) -} - - - - - - - -#' Generate all combinations. -#' -#' Generate all combinations. -#' -#' @param object Object -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_combinations <- function(object, ...) { - UseMethod("find_combinations") -} - - - - - - - - - - - - - - -#' Generate all combinations of predictors of a formula. -#' -#' Generate all combinations of predictors of a formula. -#' -#' @param object Formula. -#' @param interaction Include interaction term. -#' @param fixed Additional formula part to add at the beginning of -#' each combination. -#' @param ... Arguments passed to or from other methods. -#' -#' @return list containing all combinations. -#' -#' @examples -#' library(psycho) -#' -#' f <- as.formula("Y ~ A + B + C + D") -#' f <- as.formula("Y ~ A + B + C + D + (1|E)") -#' f <- as.formula("Y ~ A + B + C + D + (1|E) + (1|F)") -#' -#' find_combinations(f) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @method find_combinations formula -#' @importFrom utils combn -#' @importFrom stats terms -#' @export -find_combinations.formula <- function(object, interaction = TRUE, fixed = NULL, ...) { - - # Extract infos - formula <- object - vars <- attributes(terms(formula))$term.labels - outcome <- all.vars(formula)[1] - pred <- vars[!grepl("\\|", vars)] - if (length(vars[grepl("\\|", vars)]) > 0) { - random <- paste0(" + (", vars[grepl("\\|", vars)], ")") - } else { - random <- "" - } - - if (is.null(fixed)) { - fixed <- "" - } else { - fixed <- fixed - } - - # Generate combinations - n <- length(pred) - - id <- unlist( - lapply( - 1:n, - function(i) combn(1:n, i, simplify = FALSE) - ), - recursive = FALSE - ) - - combinations <- sapply(id, function(i) - paste(paste(pred[i], collapse = " + "))) - - - # Generate interactions - if (interaction == TRUE) { - for (comb in combinations) { - n_signs <- stringr::str_count(comb, "\\+") - if (n_signs > 0) { - new_formula <- comb - for (i in 1:n_signs) { - new_formula <- stringr::str_replace(new_formula, "\\+", "*") - combinations <- c(combinations, new_formula) - } - } - } - } - - combinations <- paste0(outcome, " ~ ", fixed, combinations, paste0(random, collapse = "")) - return(combinations) -} - - - - - - - - -#' Find the distance of a point with its kmean cluster. -#' -#' Find the distance of a point with its kmean cluster. -#' -#' @param df Data -#' @param km kmean object. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_distance_cluster <- function(df, km) { - myDist <- function(p1, p2) sqrt((p1[, 1] - p2[, 1])^2 + (p1[, 2] - p2[, 2])^2) - - data <- df %>% - as.data.frame() %>% - select(one_of(colnames(km$centers))) - - n_clusters <- nrow(km$centers) - - data$Distance <- NA - for (clust in 1:n_clusters) { - data$Distance[km$cluster == clust] <- myDist(data[km$cluster == clust, ], km$centers[clust, , drop = FALSE]) - } - - return(data$Distance) -} - - - - - - - -#' Find the Highest Density Point. -#' -#' Returns the Highest Density Point. -#' -#' @param x Vector. -#' @param precision Number of points in density. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_highest_density_point <- function(x, precision = 1e+03) { - d <- x %>% - density(n = precision) %>% - as.data.frame() - y <- d$x[which.max(d$y)] - return(y) -} - - - - - - -#' Fuzzy string matching. -#' -#' @param x Strings. -#' @param y List of strings to be matched. -#' @param value Return value or the index of the closest string. -#' @param step Step by which decrease the distance. -#' @param ignore.case if FALSE, the pattern matching is case sensitive and if TRUE, case is ignored during matching. -#' -#' @examples -#' library(psycho) -#' find_matching_string("Hwo rea ouy", c("How are you", "Not this word", "Nice to meet you")) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -find_matching_string <- function(x, y, value = TRUE, step = 0.1, ignore.case = TRUE) { - z <- c() - for (i in seq_len(length(x))) { - s <- x[i] - distance <- 0.99 - closest <- agrep(s, y, max.distance = distance, value = value, ignore.case = ignore.case) - - while (length(closest) != 1) { - closest <- agrep(s, closest, max.distance = distance, value = value, ignore.case = ignore.case) - distance <- distance - step - if (distance < 0) { - warning(paste0("Couldn't find matching string for '", s, "'. Try lowering the step parameter.")) - closest <- s - } - } - z <- c(z, closest) - } - return(z) -} - - - - - - - - - - -#' Find random effects in formula. -#' -#' @param formula Formula - -#' @examples -#' library(psycho) -#' find_random_effects("Y ~ X + (1|Group)") -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stringr str_remove_all -#' @importFrom lme4 findbars -#' @export -find_random_effects <- function(formula) { - random <- lme4::findbars(as.formula(formula)) - random <- paste0("(", random, ")") - random <- stringr::str_remove_all(random, " ") - random <- paste(random, collapse = " + ") - return(random) -} - - - - - - -#' Find season of dates. -#' -#' Returns the season of an array of dates. -#' -#' @param dates Array of dates. -#' @param winter month-day of winter solstice. -#' @param spring month-day of spring equinox. -#' @param summer month-day of summer solstice. -#' @param fall month-day of fall equinox. -#' -#' @return season -#' -#' @examples -#' library(psycho) -#' -#' dates <- c("2012-02-15", "2017-05-15", "2009-08-15", "1912-11-15") -#' find_season(dates) -#' @author Josh O'Brien -#' -#' @seealso -#' https://stackoverflow.com/questions/9500114/find-which-season-a-particular-date-belongs-to -#' -#' @export -find_season <- function(dates, winter = "12-21", spring = "3-20", summer = "6-21", fall = "9-22") { - WS <- as.Date(paste0("2012-", winter), format = "%Y-%m-%d") # Winter Solstice - SE <- as.Date(paste0("2012-", spring), format = "%Y-%m-%d") # Spring Equinox - SS <- as.Date(paste0("2012-", summer), format = "%Y-%m-%d") # Summer Solstice - FE <- as.Date(paste0("2012-", fall), format = "%Y-%m-%d") # Fall Equinox - - # Convert dates from any year to 2012 dates - d <- as.Date(strftime(as.character(dates), format = "2012-%m-%d")) - - season <- ifelse(d >= WS | d < SE, "Winter", - ifelse(d >= SE & d < SS, "Spring", - ifelse(d >= SS & d < FE, "Summer", "Fall") - ) - ) - return(season) -} - - - - - - - - - - -#' Tidyverse-friendly sprintf. -#' -#' @param x Values. -#' @param fmt A character vector of format strings, each of up to 8192 bytes. -#' @param ... values to be passed into fmt. Only logical, integer, real and -#' character vectors are supported, but some coercion will be done: see the ‘Details’ section. Up to 100. -#' -#' @export -format_string <- function(x, fmt, ...) { - x <- sprintf(fmt, x, ...) - return(x) -} - - - - - - -#' Format p values. -#' -#' @param pvalues p values (scalar or vector). -#' @param stars Add significance stars. -#' @param stars_only Return only significance stars. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stringr str_remove_all -#' @export -format_p <- function(pvalues, stars = TRUE, stars_only=FALSE) { - p <- ifelse(pvalues < 0.001, "< .001***", - ifelse(pvalues < 0.01, "< .01**", - ifelse(pvalues < 0.05, "< .05*", - ifelse(pvalues < 0.1, paste0("= ", round(pvalues, 2), "\xB0"), - "> .1" - ) - ) - ) - ) - - if (stars_only == TRUE) { - p <- stringr::str_remove_all(p, "[^\\*]") - } else { - if (stars == FALSE) { - p <- stringr::str_remove_all(p, "\\*") - } - } - - return(p) -} - - - - - - - - -#' Clean and format formula. -#' -#' Clean and format formula. -#' -#' @param formula formula -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' fit <- lm(hp ~ wt, data = mtcars) -#' -#' format_formula(get_formula(fit)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -format_formula <- function(formula) { - formula <- tryCatch({ - stringr::str_squish(paste(format(eval(formula)), collapse = "")) - }, error = function(e) { - formula <- stringr::str_squish(paste(format(formula), collapse = "")) - }) - - return(formula) -} - - - - - - - - - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts between factor levels based on a fitted model. -#' See the documentation for your model's class: -#' \itemize{ -#' \item{\link[=get_contrasts.glm]{get_contrasts.glm}} -#' \item{\link[=get_contrasts.lmerModLmerTest]{get_contrasts.merModLmerTest}} -#' \item{\link[=get_contrasts.glmerMod]{get_contrasts.glmerMod}} -#' \item{\link[=get_contrasts.stanreg]{get_contrasts.stanreg}} -#' } -#' -#' -#' @param fit A model. -#' @param ... Arguments passed to or from other methods. -#' -#' @return Estimated contrasts. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' require(lmerTest) -#' require(rstanarm) -#' -#' fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) -#' get_contrasts(fit) -#' -#' fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) -#' get_contrasts(fit, adjust = "bonf") -#' -#' fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) -#' get_contrasts(fit, formula = "Birth_Season") -#' -#' fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) -#' get_contrasts(fit, formula = "Birth_Season", ROPE_bounds = c(-0.1, 0.1)) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_contrasts <- function(fit, ...) { - UseMethod("get_contrasts") -} - - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @param fit A Bayesian model. -#' @param formula A character vector (formula like format, i.e., including -#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. -#' @param CI Determine the confidence or credible interval bounds. -#' @param ROPE_bounds Optional bounds of the ROPE for Bayesian models. -#' @param overlap Set to TRUE to add Overlap index (for Bayesian models). -#' @param ... Arguments passed to or from other methods. -#' @method get_contrasts stanreg -#' @export -get_contrasts.stanreg <- function(fit, formula = NULL, CI = 90, ROPE_bounds = NULL, overlap = FALSE, ...) { - .get_contrasts_bayes(fit, formula, CI, ROPE_bounds, overlap, ...) -} - - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @param fit A frequentist model. -#' @param formula A character vector (formula like format, i.e., including -#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. -#' @param CI Determine the confidence or credible interval bounds. -#' @param adjust P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -#' "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none". -#' @param ... Arguments passed to or from other methods. -#' @method get_contrasts lm -#' @export -get_contrasts.lm <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts glm -#' @export -get_contrasts.glm <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts lmerModLmerTest -#' @export -get_contrasts.lmerModLmerTest <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts glmerMod -#' @export -get_contrasts.glmerMod <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - -#' Compute estimated contrasts from models. -#' -#' Compute estimated contrasts from models. -#' -#' @inheritParams get_contrasts.lm -#' @method get_contrasts lmerMod -#' @export -get_contrasts.lmerMod <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - .get_contrasts_freq(fit, formula, CI, adjust, ...) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom graphics pairs -#' @importFrom stats confint mad -#' @keywords internal -.get_contrasts_bayes <- function(fit, formula = NULL, CI = 90, ROPE_bounds = NULL, overlap = FALSE, ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Contrasts --------------------------------------------------------------- - contrasts_posterior <- fit %>% - emmeans::emmeans(formula) %>% - graphics::pairs() %>% - emmeans::as.mcmc.emmGrid() %>% - as.matrix() %>% - as.data.frame() - - contrasts <- data.frame() - - - for (name in names(contrasts_posterior)) { - posterior <- contrasts_posterior[[name]] - - CI_values <- HDI(posterior, prob = CI / 100) - CI_values <- c(CI_values$values$HDImin, CI_values$values$HDImax) - - var <- data.frame( - Contrast = stringr::str_remove(name, "contrast "), - Median = median(posterior), - MAD = mad(posterior), - CI_lower = CI_values[seq(1, length(CI_values), 2)], - CI_higher = CI_values[seq(2, length(CI_values), 2)], - MPE = mpe(posterior)$MPE - ) - - if (overlap == TRUE) { - var$Overlap <- 100 * overlap( - posterior, - rnorm_perfect( - length(posterior), - 0, - sd(posterior) - ) - ) - } - - if (!is.null(ROPE_bounds)) { - var$ROPE <- rope(posterior, ROPE_bounds, CI = 95)$rope_probability - } - - contrasts <- rbind(contrasts, var) - } - - - return(contrasts) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom graphics pairs -#' @importFrom stats confint -#' @keywords internal -.get_contrasts_freq <- function(fit, formula = NULL, CI = 95, adjust = "tukey", ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Contrasts --------------------------------------------------------------- - contrasts <- fit %>% - emmeans::emmeans(formula) %>% - graphics::pairs(adjust = adjust) - - # Confint - CI <- contrasts %>% - confint(CI / 100) %>% - select(contains("CL")) - - - contrasts <- contrasts %>% - as.data.frame() %>% - cbind(CI) %>% - dplyr::rename_( - "Contrast" = "contrast", - "Difference" = "estimate", - "p" = "p.value" - ) - names(contrasts) <- stringr::str_replace(names(contrasts), "lower.CL", "CI_lower") - names(contrasts) <- stringr::str_replace(names(contrasts), "upper.CL", "CI_higher") - names(contrasts) <- stringr::str_replace(names(contrasts), "asymp.LCL", "CI_lower") - names(contrasts) <- stringr::str_replace(names(contrasts), "asymp.UCL", "CI_higher") - names(contrasts) <- stringr::str_replace(names(contrasts), "t.ratio", "t") - names(contrasts) <- stringr::str_replace(names(contrasts), "z.ratio", "z") - - return(contrasts) -} - - - - - - - - -#' Extract the dataframe used in a model. -#' -#' Extract the dataframe used in a model. -#' -#' @param fit A model. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(tidyverse) -#' library(psycho) -#' -#' df <- mtcars %>% -#' mutate( -#' cyl = as.factor(cyl), -#' gear = as.factor(gear) -#' ) -#' -#' fit <- lm(wt ~ mpg, data = df) -#' fit <- lm(wt ~ cyl, data = df) -#' fit <- lm(wt ~ mpg * cyl, data = df) -#' fit <- lm(wt ~ cyl * gear, data = df) -#' fit <- lmerTest::lmer(wt ~ mpg * gear + (1 | cyl), data = df) -#' fit <- rstanarm::stan_lmer(wt ~ mpg * gear + (1 | cyl), data = df) -#' -#' get_data(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -get_data <- function(fit, ...) { - UseMethod("get_data") -} - - -#' @importFrom stats getCall -#' @importFrom utils data -#' @export -get_data.lm <- function(fit, ...) { - tryCatch({ - data <- eval(getCall(fit)$data, environment(formula(fit))) - return(data) - }) - - info <- get_info(fit) - - outcome <- info$outcome - predictors <- info$predictors - - data <- as.data.frame(model.frame(fit)) - - - effects <- names(MuMIn::coeffs(fit)) - effects <- unique(unlist(stringr::str_split(effects, ":"))) - numerics <- predictors[predictors %in% effects] - - numerics <- numerics[!is.na(numerics)] - if (length(unique(model.response(model.frame(fit)))) > 2) { - numerics <- c(outcome, numerics) - } - - - data[!names(data) %in% numerics] <- lapply(data[!names(data) %in% numerics], as.factor) - data[names(data) %in% numerics] <- lapply(data[names(data) %in% numerics], as.numeric) - - return(as.data.frame(data)) -} - -#' @export -get_data.merMod <- get_data.lm - - - - - -#' @export -get_data.stanreg <- function(fit, ...) { - data <- fit$data - return(data) -} - - - - - - - - - - -#' Get formula of models. -#' -#' Get formula of models. Implemented for: -#' \itemize{ -#' \item{analyze.merModLmerTest} -#' \item{analyze.glmerMod} -#' \item{analyze.lm} -#' \item{analyze.glm} -#' \item{analyze.stanreg} -#' } -#' -#' @param x Object. -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' fit <- lm(hp ~ wt, data = mtcars) -#' -#' get_formula(fit) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_formula <- function(x, ...) { - UseMethod("get_formula") -} - - -#' @export -get_formula.lmerModLmerTest <- function(x, ...) { - return(x@call$formula) -} -#' @export -get_formula.glmerMod <- get_formula.lmerModLmerTest -#' @export -get_formula.lmerMod <- get_formula.lmerModLmerTest - - -#' @export -get_formula.lm <- function(x, ...) { - return(stats::formula(x)) -} -#' @export -get_formula.glm <- get_formula.lm - - - -#' @export -get_formula.stanreg <- function(x, ...) { - return(x$formula) -} - - - - - - - - - - -#' Get graph data. -#' -#' To be used with tidygraph::tbl_graph. See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=get_graph.lavaan]{get_graph.lavaan}} -#' \item{\link[=get_graph.fa]{get_graph.fa}} -#' \item{\link[=get_graph.psychobject_correlation]{get_graph.psychobject_correlation}} -#' } -#' -#' @param fit Object from which to extract the graph data. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_graph <- function(fit, ...) { - UseMethod("get_graph") -} - - - - - - - - - - - - - - - - - - -#' Get graph data from lavaan or blavaan objects. -#' -#' Get graph data from lavaan or blavaan objects. -#' -#' @param fit lavaan object. -#' @param links Which links to include? A list including at least one of "Regression", "Loading" or "Correlation". -#' @param standardize Use standardized coefs. -#' @param threshold_Coef Omit all links with a Coefs below this value. -#' @param threshold_p Omit all links with a p value above this value. -#' @param threshold_MPE In case of a blavaan model, omit all links with a MPE value below this value. -#' @param digits Edges' labels rounding. -#' @param CI CI level. -#' @param labels_CI Add the CI in the edge label. -#' @param ... Arguments passed to or from other methods. -#' -#' @return A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_graph.lavaan <- function(fit, links = c("Regression", "Correlation", "Loading"), standardize = FALSE, threshold_Coef = NULL, threshold_p = NULL, threshold_MPE = NULL, digits = 2, CI = "default", labels_CI = TRUE, ...) { - # https://www.r-bloggers.com/ggplot2-sem-models-with-tidygraph-and-ggraph/ - - - if (labels_CI == TRUE) { - if (CI != "default") { - results <- analyze(fit, CI = CI, standardize = standardize) - } else { - results <- analyze(fit, standardize = standardize) - } - } else { - results <- analyze(fit, standardize = standardize) - } - - summary <- summary(results) - CI <- results$values$CI - - # Check what type of model - if (class(fit) %in% c("blavaan")) { - summary$Coef <- summary$Median - if (is.null(threshold_MPE)) { - threshold_MPE <- -1 - } - summary <- summary %>% - filter_("MPE >= threshold_MPE") - } else if (class(fit) %in% c("lavaan")) { - if (is.null(threshold_p)) { - threshold_p <- 1.1 - } - summary <- summary %>% - filter_("p <= threshold_p") - } else { - stop(paste("Error in UseMethod('plot_lavaan') : no applicable method for 'plot_lavaan' applied to an object of class", class(fit))) - } - - # Deal with thresholds - if (is.null(threshold_Coef)) { - threshold_Coef <- min(abs(summary$Coef)) - 1 - } - - # Edge properties - edges <- summary %>% - mutate_("abs_coef" = "abs(Coef)") %>% - filter_( - "Type %in% c(links)", - "From != To", - "abs_coef >= threshold_Coef" - ) %>% - select(-one_of("abs_coef")) %>% - rename_( - "to" = "To", - "from" = "From" - ) - - # Labels - if (labels_CI == TRUE) { - edges <- edges %>% - mutate_("Label" = 'paste0(format_digit(Coef, digits), - ", ", CI, "% CI [", format_digit(CI_lower, digits), - ", ", format_digit(CI_higher, digits), "]")') - } else { - edges <- edges %>% - mutate_("Label" = "format_digit(Coef, digits)") - } - edges <- edges %>% - mutate_( - "Label_Regression" = "ifelse(Type=='Regression', Label, '')", - "Label_Correlation" = "ifelse(Type=='Correlation', Label, '')", - "Label_Loading" = "ifelse(Type=='Loading', Label, '')" - ) - edges <- edges[colSums(!is.na(edges)) > 0] - - # Identify latent variables for nodes - latent_nodes <- edges %>% - filter_('Type == "Loading"') %>% - distinct_("to") %>% - transmute_("Name" = "to", "Latent" = TRUE) - - nodes_list <- unique(c(edges$from, edges$to)) - - # Node properties - nodes <- summary %>% - filter_( - "From == To", - "From %in% nodes_list" - ) %>% - mutate_("Name" = "From") %>% - left_join(latent_nodes, by = "Name") %>% - mutate_("Latent" = "if_else(is.na(Latent), FALSE, Latent)") %>% - select(one_of(c("Name", "Latent"))) - - return(list(nodes = nodes, edges = edges)) -} - - - - - -#' Get graph data from factor analysis. -#' -#' Get graph data from fa objects. -#' -#' @param fit psych::fa object. -#' @param threshold_Coef Omit all links with a Coefs below this value. -#' @param digits Edges' labels rounding. -#' @param ... Arguments passed to or from other methods. -#' -#' @return A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_graph.fa <- function(fit, threshold_Coef = NULL, digits = 2, ...) { - edges <- summary(analyze(fit)) %>% - gather("To", "Coef", -one_of("N", "Item", "Label")) %>% - rename_("From" = "Item") %>% - mutate_("Label" = "format_digit(Coef, digits)") %>% - select(one_of("From", "To", "Coef", "Label"), everything()) %>% - filter() - - # Deal with thresholds - if (is.null(threshold_Coef)) { - threshold_Coef <- min(abs(edges$Coef)) - 1 - } - - edges <- edges %>% - filter_("Coef > threshold_Coef") - - nodes <- data.frame("Name" = c(edges$From, edges$To)) %>% - distinct_("Name") - - return(list(nodes = nodes, edges = edges)) -} - - - - -#' Get graph data from correlation. -#' -#' Get graph data from correlation. -#' -#' @param fit Object from psycho::correlation. -#' @param ... Arguments passed to or from other methods. -#' -#' @return A list containing nodes and edges data to be used by `igraph::graph_from_data_frame()`. -#' -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' -#' @export -get_graph.psychobject_correlation <- function(fit, ...) { - vars <- row.names(fit$values$r) - - r <- fit$values$r %>% - as.data.frame() %>% - tibble::rownames_to_column("from") %>% - tidyr::gather("to", "r", vars) - - if ("p" %in% names(fit$values)) { - r <- r %>% - full_join( - fit$values$p %>% - as.data.frame() %>% - tibble::rownames_to_column("from") %>% - tidyr::gather("to", "p", vars), - by = c("from", "to") - ) - } - - r <- filter_(r, "!from == to") - return(r) -} - - - - - - - - - - - - - -#' Get information about objects. -#' -#' Get information about models. -#' -#' -#' @param x object. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' -#' info <- get_info(fit) -#' info -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_info <- function(x, ...) { - UseMethod("get_info") -} - - - - - - - - - - -#' Get information about models. -#' -#' Get information about models. -#' -#' @param x object. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' -#' info <- get_info(fit) -#' info -#' -#' # -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_info.lmerModLmerTest <- function(x, ...) { - fit <- x - - info <- tryCatch({ - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- all.vars(formula) - outcome <- predictors[[1]] - predictors <- tail(predictors, -1) - random <- names(lme4::ranef(fit))[names(lme4::ranef(fit)) %in% predictors] - predictors <- predictors[!predictors %in% random] - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome, - random = random - )) - }, error = function(e) { - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- NA - outcome <- "Y" - random <- NA - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome, - random = random - )) - }) - - return(info) -} -#' @export -get_info.glmerMod <- get_info.lmerModLmerTest -#' @export -get_info.lmerMod <- get_info.lmerModLmerTest - - - -#' Get information about models. -#' -#' Get information about models. -#' -#' @param x object. -#' @param ... Arguments passed to or from other methods. -#' -#' @return output -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lm(vs ~ wt, data = mtcars, family = "binomial") -#' -#' info <- get_info(fit) -#' info -#' -#' # -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_info.lm <- function(x, ...) { - fit <- x - - info <- tryCatch({ - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- all.vars(formula) - outcome <- predictors[[1]] - predictors <- tail(predictors, -1) - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome - )) - }, error = function(e) { - - # Get formula - formula <- get_formula(fit) - # Get variables - predictors <- NA - outcome <- "Y" - random <- NA - - return(list( - formula = formula, - predictors = predictors, - outcome = outcome - )) - }) - - return(info) -} - -#' @export -get_info.stanreg <- get_info.lm -#' @export -get_info.lm <- get_info.lm -#' @export -get_info.glm <- get_info.lm - - - - - - - - - - - - -#' Compute estimated means from models. -#' -#' Compute estimated means of factor levels based on a fitted model. -#' -#' @param fit A model (lm, lme4 or rstanarm). -#' @param formula A character vector (formula like format, i.e., including -#' interactions or nesting terms) specifying the names of the predictors over which EMMs are desired. -#' @param CI Determine the confidence or credible interval bounds. -#' @param ... Arguments passed to or from other methods. For instance, transform="response". -#' -#' -#' @return Estimated means (or median of means for Bayesian models) -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' require(lmerTest) -#' require(rstanarm) -#' -#' -#' fit <- glm(Sex ~ Birth_Season, data = affective, family = "binomial") -#' get_means(fit) -#' -#' fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) -#' get_means(fit, formula = "Birth_Season") -#' -#' fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) -#' get_means(fit, formula = "Birth_Season") -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_means <- function(fit, formula = NULL, CI = 90, ...) { - UseMethod("get_means") -} - - -#' @method get_means stanreg -#' @export -get_means.stanreg <- function(fit, formula = NULL, CI = 90, ...) { - .get_means_bayes(fit, formula, CI, ...) -} - -#' @method get_means lm -#' @export -get_means.lm <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means glm -#' @export -get_means.glm <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means lmerModLmerTest -#' @export -get_means.lmerModLmerTest <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means glmerMod -#' @export -get_means.glmerMod <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - -#' @method get_means lmerMod -#' @export -get_means.lmerMod <- function(fit, formula = NULL, CI = 95, ...) { - .get_means_freq(fit, formula, CI, ...) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom stats confint mad -#' @keywords internal -.get_means_bayes <- function(fit, formula = NULL, CI = 90, ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Means --------------------------------------------------------------- - means_posterior <- fit %>% - emmeans::emmeans(formula) %>% - emmeans::as.mcmc.emmGrid() %>% - as.matrix() %>% - as.data.frame() - - means <- data.frame() - - for (name in names(means_posterior)) { - var <- means_posterior[[name]] - - CI_values <- HDI(var, prob = CI / 100) - CI_values <- c(CI_values$values$HDImin, CI_values$values$HDImax) - - var <- data.frame( - Level = name, - Median = median(var), - MAD = mad(var), - CI_lower = CI_values[seq(1, length(CI_values), 2)], - CI_higher = CI_values[seq(2, length(CI_values), 2)] - ) - - means <- rbind(means, var) - } - - return(means) -} - - - - -#' @import dplyr -#' @importFrom emmeans emmeans -#' @importFrom stats confint -#' @keywords internal -.get_means_freq <- function(fit, formula = NULL, CI = 95, ...) { - if (is.null(formula)) { - formula <- paste(get_info(fit)$predictors, collapse = " * ") - } - - if (is.character(formula)) { - formula <- as.formula(paste0("~ ", formula)) - } - - # Means --------------------------------------------------------------- - means <- fit %>% - emmeans::emmeans(formula, ...) %>% - confint(CI / 100) %>% - as.data.frame() - - names(means) <- stringr::str_replace(names(means), "emmean", "Mean") - names(means) <- stringr::str_replace(names(means), "lower.CL", "CI_lower") - names(means) <- stringr::str_replace(names(means), "upper.CL", "CI_higher") - names(means) <- stringr::str_replace(names(means), "asymp.LCL", "CI_lower") - names(means) <- stringr::str_replace(names(means), "asymp.UCL", "CI_higher") - - return(means) -} - - - - - - - - - -#' Compute predicted values of lm models. -#' -#' Compute predicted from a lm model. -#' -#' @param fit An lm model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of confidence intervals (0.9 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). -#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' -#' fit <- glm(Sex ~ Adjusting, data = affective, family = "binomial") -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Sex_CI_2.5, -#' ymax = Sex_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.glm <- function(fit, newdata = "model", prob = 0.95, odds_to_probs = TRUE, ...) { - - - # Extract names - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- fit$data[predictors] - newdata <- na.omit(fit$data[predictors]) - } - } - } - - - # Compute ---------------------------------------------------------- - - # Predicted Y - prediction <- as.data.frame(predict(fit, newdata = newdata, type = "link", se.fit = TRUE)) - SE <- as.data.frame(prediction$se.fit) - pred_y <- as.data.frame(prediction$fit) - names(pred_y) <- paste0(outcome, "_Predicted") - - # Credible Interval - for (CI in c(prob)) { - pred_y_interval <- data.frame( - lwr = prediction$fit - (qnorm(CI) * SE), - upr = prediction$fit + (qnorm(CI) * SE) - ) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - - - # Transform odds to probs ---------------------------------------------------------- - - if (family(fit)$family == "binomial" & family(fit)$link == "logit") { - if (odds_to_probs == TRUE) { - pred_y <- odds_to_probs(pred_y) - } - } - - - # Add predictors ---------------------------------------------------------- - - - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit$data[!names(fit$data) %in% predictors] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} - - - - - - - - - -#' Compute predicted values of lm models. -#' -#' Compute predicted from a lm model. -#' -#' @param fit An lm model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of confidence intervals (0.95 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' -#' fit <- lm(Tolerating ~ Adjusting, data = affective) -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Tolerating_CI_2.5, -#' ymax = Tolerating_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.lm <- function(fit, newdata = "model", prob = 0.95, ...) { - - - # Extract names - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- as.data.frame(fit$model[predictors]) - newdata <- na.omit(fit$model[predictors]) - } - } - } - - - # Compute ---------------------------------------------------------- - - # Predicted Y - pred_y <- as.data.frame(predict(fit, newdata)) - names(pred_y) <- paste0(outcome, "_Predicted") - - # Credible Interval - for (CI in c(prob)) { - pred_y_interval <- as.data.frame(predict(fit, newdata, interval = "confidence", level = CI)[, -1]) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - - - - # Add predictors ---------------------------------------------------------- - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit$model[!names(fit$model) %in% predictors] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} - - - - - - - - - -#' Compute predicted values of lm models. -#' -#' Compute predicted from a lm model. -#' -#' @param fit An lm model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of confidence intervals (0.95 will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). Default to NULL as it takes a very long time to compute (see \link[lme4]{bootMer}). -#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. -#' @param iter An integer indicating the number of iterations for bootstrapping (when prob is not null). -#' @param seed An optional seed to use. -#' @param re.form Formula for random effects to condition on. If NULL, include all random effects; if NA or ~0, include no random effects (see \link[lme4]{predict.merMod}). If "default", then will ne NULL if the random are present in the data, and NA if not. -#' @param use.u logical, indicating whether the spherical random effects should be simulated / bootstrapped as well. If TRUE, they are not changed, and all inference is conditional on these values. If FALSE, new normal deviates are drawn (see\link[lme4]{bootMer}). -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' -#' fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + -#' geom_line() -#' -#' predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Tolerating_CI_2.5, -#' ymax = Tolerating_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' -#' -#' -#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = affective, family = "binomial") -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + -#' geom_line() -#' -#' predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Sex_CI_2.5, -#' ymax = Sex_CI_97.5 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.merMod <- function(fit, newdata = "model", prob = NULL, odds_to_probs = TRUE, iter = 100, seed = NULL, re.form = "default", use.u = FALSE, ...) { - - - # Extract names - info <- get_info(fit) - outcome <- info$outcome - predictors <- info$predictors - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- na.omit(fit@frame) - } - } - } - - - # Deal with random - if (!is.na(re.form)) { - if (re.form == "default") { - # Check if all predictors are in variables - if (all(get_info(fit)$predictors %in% names(newdata))) { - re.form <- NULL - } else { - re.form <- NA - } - } - } - - - - # Compute ---------------------------------------------------------- - - pred_y <- as.data.frame(predict(fit, newdata = newdata, re.form = re.form)) - names(pred_y) <- paste0(outcome, "_Predicted") - - if (!is.null(prob)) { - predFun <- function(fit) { - predict(fit, newdata, newdata = newdata, re.form = re.form) - } - predMat <- lme4::bootMer(fit, nsim = iter, FUN = predFun, use.u = use.u, seed = seed)$t - - for (CI in c(prob)) { - pred_y_interval <- as.data.frame(t(apply(predMat, 2, quantile, c((1 - CI) / 2, CI + (1 - CI) / 2), na.rm = TRUE))) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - } - - - # Transform odds to probs ---------------------------------------------------------- - - if (family(fit)$family == "binomial" & family(fit)$link == "logit") { - if (odds_to_probs == TRUE) { - pred_y <- odds_to_probs(pred_y) - } - } - - - # Add predictors ---------------------------------------------------------- - - - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit@frame[!names(fit@frame) %in% names(newdata)] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} - - - - - - -#' Compute predicted values from models. -#' -#' Compute predicted values from models. See the -#' documentation for your model's class: -#' \itemize{ -#' \item{\link[=get_predicted.stanreg]{get_predicted.stanreg}} -#' \item{\link[=get_predicted.merMod]{get_predicted.merMod}} -#' \item{\link[=get_predicted.lm]{get_predicted.lm}} -#' \item{\link[=get_predicted.glm]{get_predicted.glm}} -#' } -#' -#' @param fit Model. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_predicted <- function(fit, ...) { - UseMethod("get_predicted") -} - - - - - - - - -#' Compute predicted values of stanreg models. -#' -#' Compute predicted from a stanreg model. -#' -#' @param fit A stanreg model. -#' @param newdata A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used. -#' @param prob Probability of credible intervals (0.9 (default) will compute 5-95\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). -#' @param odds_to_probs Transform log odds ratios in logistic models to probabilies. -#' @param keep_iterations Keep all prediction iterations. -#' @param draws An integer indicating the number of draws to return. The default and maximum number of draws is the size of the posterior sample. -#' @param posterior_predict Posterior draws of the outcome instead of the link function (i.e., the regression "line"). -#' @param seed An optional seed to use. -#' @param transform If posterior_predict is False, should the linear predictor be transformed using the inverse-link function? The default is FALSE, in which case the untransformed linear predictor is returned. -#' @param re.form If object contains group-level parameters, a formula indicating which group-level parameters to condition on when making predictions. re.form is specified in the same form as for predict.merMod. NULL indicates that all estimated group-level parameters are conditioned on. To refrain from conditioning on any group-level parameters, specify NA or ~0. The newdata argument may include new levels of the grouping factors that were specified when the model was estimated, in which case the resulting posterior predictions marginalize over the relevant variables (see \link[rstanarm]{posterior_predict.stanreg}). If "default", then will ne NULL if the random are present in the data, and NA if not. -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @return dataframe with predicted values. -#' -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(ggplot2) -#' require(rstanarm) -#' -#' fit <- rstanarm::stan_glm(Tolerating ~ Adjusting, data = affective) -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Tolerating_Median)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Tolerating_CI_5, -#' ymax = Tolerating_CI_95 -#' ), -#' alpha = 0.1 -#' ) -#' -#' fit <- rstanarm::stan_glm(Sex ~ Adjusting, data = affective, family = "binomial") -#' -#' refgrid <- psycho::refdata(affective, "Adjusting") -#' predicted <- get_predicted(fit, newdata = refgrid) -#' -#' ggplot(predicted, aes(x = Adjusting, y = Sex_Median)) + -#' geom_line() + -#' geom_ribbon(aes( -#' ymin = Sex_CI_5, -#' ymax = Sex_CI_95 -#' ), -#' alpha = 0.1 -#' ) -#' } -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats median family model.matrix -#' @importFrom dplyr bind_cols -#' @importFrom tibble rownames_to_column -#' @export -get_predicted.stanreg <- function(fit, newdata = "model", prob = 0.9, odds_to_probs = TRUE, keep_iterations = FALSE, draws = NULL, posterior_predict = FALSE, seed = NULL, transform = FALSE, re.form = "default", ...) { - - # Extract names - predictors <- all.vars(as.formula(fit$formula)) - outcome <- predictors[[1]] - predictors <- tail(predictors, -1) - - # Set newdata if refgrid - if ("emmGrid" %in% class(newdata)) { - newdata <- newdata@grid - newdata[".wgt."] <- NULL - } - - # Set newdata to actual data - original_data <- FALSE - if (!is.null(newdata)) { - if (is.character(newdata)) { - if (newdata == "model") { - original_data <- TRUE - newdata <- fit$data[predictors] - newdata <- na.omit(fit$data[predictors]) - } - } - } - - # Deal with potential random - if (!is.na(re.form)) { - if (re.form == "default") { - if (is.mixed(fit)) { - # Check if all predictors are in variables - if (all(get_info(fit)$predictors %in% names(newdata))) { - re.form <- NULL - } else { - re.form <- NA - } - } - } - } - - # Generate draws ------------------------------------------------------- - if (posterior_predict == FALSE) { - posterior <- rstanarm::posterior_linpred(fit, newdata = newdata, re.form = re.form, seed = seed, draws = draws, transform = transform) - } else { - posterior <- rstanarm::posterior_predict(fit, newdata = newdata, re.form = re.form, seed = seed, draws = draws) - } - - # Format ------------------------------------------------------- - - # Predicted Y - pred_y <- as.data.frame(apply(posterior, 2, median)) - names(pred_y) <- paste0(outcome, "_Median") - - # Credible Interval - for (CI in c(prob)) { - pred_y_interval <- HDI(posterior, prob = CI) - names(pred_y_interval) <- paste(outcome, "CI", c((1 - CI) / 2 * 100, 100 - ((1 - CI) / 2 * 100)), sep = "_") - pred_y <- cbind(pred_y, pred_y_interval) - } - - - # Keep iterations --------------------------------------------------------- - - if (keep_iterations == TRUE) { - iterations <- as.data.frame(t(posterior)) - names(iterations) <- paste0("iter_", seq_len(length(names(iterations)))) - pred_y <- cbind(pred_y, iterations) - } - - # Transform odds to probs ---------------------------------------------------------- - - if (family(fit)$family == "binomial" & family(fit)$link == "logit") { - if (odds_to_probs == TRUE) { - pred_y <- odds_to_probs(pred_y) - } - } - - - # Add predictors ---------------------------------------------------------- - - - if (!is.null(newdata)) { - if (original_data) { - predicted <- newdata %>% - tibble::rownames_to_column() %>% - dplyr::bind_cols(pred_y) %>% - dplyr::right_join(fit$data[!names(fit$data) %in% predictors] %>% - tibble::rownames_to_column(), - by = "rowname" - ) %>% - select_("-rowname") - } else { - predicted <- dplyr::bind_cols(newdata, pred_y) - } - } else { - predicted <- dplyr::bind_cols(as.data.frame(model.matrix(fit)), pred_y) - } - - - return(predicted) -} - - - - - - - - -#' Get Indices of Explanatory Power. -#' -#' See the documentation for your object's class: -#' \itemize{ -#' \item{\link[=get_R2.lm]{get_R2.lm}} -#' \item{\link[=get_R2.glm]{get_R2.glm}} -#' \item{\link[=get_R2.stanreg]{get_R2.stanreg}} -#' } -#' -#' @param fit Object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_R2 <- function(fit, ...) { - UseMethod("get_R2") -} - - -#' R2 and adjusted R2 for Linear Models. -#' -#' R2 and adjusted R2 for Linear Models. -#' -#' @param fit A linear model. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -get_R2.lm <- function(fit, ...) { - R2 <- summary(fit)$r.squared - R2.adj <- summary(fit)$adj.r.squared - - out <- list(R2 = R2, R2.adj = R2.adj) - return(out) -} - - - -#' Pseudo-R-squared for Logistic Models. -#' -#' Pseudo-R-squared for Logistic Models. -#' -#' @param fit A logistic model. -#' @param method Can be \link[=R2_nakagawa]{"nakagawa"} or \link[=R2_tjur]{"tjur"}. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- glm(vs ~ wt, data = mtcars, family = "binomial") -#' fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -get_R2.glm <- function(fit, method = "nakagawa", ...) { - if (method == "nakagawa") { - R2 <- as.numeric(R2_nakagawa(fit)$R2m) - } else if (method == "tjur") { - R2 <- R2_tjur(fit) - } else { - stop("Method must be 'nakagawa' or 'tjur'.") - } - return(R2) -} - - - - -#' R2 or Bayesian Models. -#' -#' Computes R2 and \link[=R2_LOO_Adjusted]{LOO-adjusted R2}. -#' -#' @param fit A stanreg model. -#' @param silent If R2 not available, throw warning. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' fit <- rstanarm::stan_glm(Adjusting ~ Tolerating, data = psycho::affective) -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso \link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} -#' -#' @export -get_R2.stanreg <- function(fit, silent = FALSE, ...) { - tryCatch({ - R2 <- rstanarm::bayes_R2(fit) - }, error = function(e) { - R2 <- "NA" - }) - - if (!is.numeric(R2)) { - if (silent) { - return(R2) - } else { - stop("Couldn't compute R2 for this model.") - } - } - - out <- list( - R2_median = median(R2), - R2_MAD = mad(R2), - R2_posterior = R2 - ) - - if (fit$family$family == "gaussian") { - out$R2.adj <- R2_LOO_Adjusted(fit) - } else { - out$R2.adj <- NA - } - - return(out) -} - - - -#' R2 and adjusted R2 for GLMMs. -#' -#' R2 and adjusted R2 for GLMMs. -#' -#' @param fit A GLMM. -#' @param ... Arguments passed to or from other methods. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), -#' data = psycho::affective -#' ) -#' fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), -#' data = na.omit(psycho::affective), family = "binomial" -#' ) -#' -#' get_R2(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @export -get_R2.merMod <- function(fit, ...) { - out <- suppressMessages(R2_nakagawa(fit)) - return(out) -} - - - - - -#' Pseudo-R-squared for Generalized Mixed-Effect models. -#' -#' For mixed-effects models, R² can be categorized into two types. Marginal R_GLMM² represents the variance explained by fixed factors, and Conditional R_GLMM² is interpreted as variance explained by both fixed and random factors (i.e. the entire model). IMPORTANT: Looking for help to reimplement this method. -#' -#' @param fit A mixed model. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' -#' fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -#' -#' R2_nakagawa(fit) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references -#' Nakagawa, S., Johnson, P. C., & Schielzeth, H. (2017). The coefficient of determination R2 and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. Journal of the Royal Society Interface, 14(134), 20170213. -#' Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -#' -#' @export -R2_nakagawa <- function(fit) { - out <- MuMIn::r.squaredGLMM(fit) - out <- list( - R2m = as.numeric(out[1]), - R2c = as.numeric(out[2]) - ) - return(out) -} - - - -#' Compute LOO-adjusted R2. -#' -#' Compute LOO-adjusted R2. -#' -#' @param fit A stanreg model. -#' -#' @examples -#' \dontrun{ -#' library(psycho) -#' library(rstanarm) -#' -#' data <- attitude -#' fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) -#' -#' R2_LOO_Adjusted(fit) -#' } -#' -#' @author \href{https://github.com/strengejacke}{Daniel Luedecke} -#' -#' @import rstantools -#' -#' @export -R2_LOO_Adjusted <- function(fit) { - predictors <- all.vars(as.formula(fit$formula)) - y <- fit$data[[predictors[[1]]]] - ypred <- rstantools::posterior_linpred(fit) - ll <- rstantools::log_lik(fit) - - nsamples <- 0 - nchains <- length(fit$stanfit@stan_args) - for (chain in fit$stanfit@stan_args) { - nsamples <- nsamples + (chain$iter - chain$warmup) - } - - - r_eff <- loo::relative_eff(exp(ll), - chain_id = rep(1:nchains, each = nsamples / nchains) - ) - - psis_object <- loo::psis(log_ratios = -ll, r_eff = r_eff) - ypredloo <- loo::E_loo(ypred, psis_object, log_ratios = -ll)$value - if (length(ypredloo) != length(y)) { - warning("Something went wrong in the Loo-adjusted R2 computation.") - return(NA) - } - eloo <- ypredloo - y - - adj_r_squared <- 1 - stats::var(eloo) / stats::var(y) - return(adj_r_squared) -} - - - - -#' Tjur's (2009) coefficient of determination. -#' -#' Computes Tjur's (2009) coefficient of determination. -#' -#' @param fit Logistic Model. -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -#' R2_tjur(fit) -#' @author \href{https://github.com/strengejacke}{Daniel Lüdecke} -#' -#' @import dplyr -#' @importFrom stats predict residuals -#' @importFrom lme4 getME -#' -#' @references Tjur, T. (2009). Coefficients of determination in logistic regression models—A new proposal: The coefficient of discrimination. The American Statistician, 63(4), 366-372. -#' -#' @export -R2_tjur <- function(fit) { - # check for valid object class - if (!inherits(fit, c("glmerMod", "glm"))) { - stop("`x` must be an object of class `glm` or `glmerMod`.", call. = F) - } - - # mixed models (lme4) - if (inherits(fit, "glmerMod")) { - # check for package availability - y <- lme4::getME(fit, "y") - pred <- stats::predict(fit, type = "response", re.form = NULL) - } else { - y <- fit$y - pred <- stats::predict.glm(fit, type = "response") - } - - # delete pred for cases with missing residuals - if (anyNA(stats::residuals(fit))) pred <- pred[!is.na(stats::residuals(fit))] - - categories <- unique(y) - m1 <- mean(pred[which(y == categories[1])], na.rm = T) - m2 <- mean(pred[which(y == categories[2])], na.rm = T) - - D <- abs(m2 - m1) - names(D) <- "Tjur's D" - - return(D) -} - - - - - - - - -#' Golden Ratio. -#' -#' Returns the golden ratio (1.618034...). -#' -#' @param x A number to be multiplied by the golden ratio. The default (x=1) returns the value of the golden ratio. -#' -#' @examples -#' library(psycho) -#' -#' golden() -#' golden(8) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -golden <- function(x = 1) { - return(x * (1 + sqrt(5)) / 2) -} - - - - - - - - - -#' Highest Density Intervals (HDI). -#' -#' Compute the Highest Density Intervals (HDI) of a distribution. -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' -#' @examples -#' library(psycho) -#' -#' distribution <- rnorm(1000, 0, 1) -#' HDI_values <- HDI(distribution) -#' print(HDI_values) -#' plot(HDI_values) -#' summary(HDI_values) -#' -#' x <- matrix(rexp(200), 100) -#' HDI_values <- HDI(x) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -HDI <- function(x, prob = .95) { - - # From CI to prob if necessary - if (prob > 1 & prob <= 100) { - prob <- prob / 100 - } - - # If x is a matrix - if (ncol(as.matrix(x)) > 1) { - HDImin <- c() - HDImax <- c() - for (col in seq_len(ncol(x))) { - HDI <- .HDI(x[, col], prob = prob) - HDImin <- c(HDImin, HDI[1]) - HDImax <- c(HDImax, HDI[2]) - } - return(data.frame(HDImin = HDImin, HDImax = HDImax)) - - - # If x is a vector - } else { - # Process - # ------------- - HDI <- .HDI(x, prob = prob) - HDImin <- HDI[1] - HDImax <- HDI[2] - - # Store results - # ------------- - values <- list(HDImin = HDImin, HDImax = HDImax, prob = prob) - text <- paste( - prob * 100, - "% CI [", - format_string(HDImin, "%.2f"), - ", ", - format_string(HDImax, "%.2f"), - "]", - sep = "" - ) - summary <- data.frame(Probability = prob, HDImin = HDImin, HDImax = HDImax) - - - # Plot - # ------------- - data <- as.data.frame(x = x) - plot <- ggplot(data = data, aes(x)) + - geom_density(fill = "#2196F3") + - geom_vline( - data = data, aes(xintercept = HDImin), - linetype = "dashed", color = "#E91E63", size = 1 - ) + - geom_vline( - data = data, aes(xintercept = HDImax), - linetype = "dashed", color = "#E91E63", size = 1 - ) + - theme_minimal() - - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - - class(output) <- c("psychobject", "list") - return(output) - } -} - - - - -#' Highest Density Intervals (HDI) -#' -#' See \link[=HDI]{HDI} -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' -#' @export -HDImin <- function(x, prob = .95) { - HDImin <- HDI(x, prob = prob)$values$HDImin - return(HDImin) -} - -#' Highest Density Intervals (HDI) -#' -#' See \link[=HDI]{HDI} -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param prob Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' -#' @export -HDImax <- function(x, prob = .95) { - HDImax <- HDI(x, prob = prob)$values$HDImax - return(HDImax) -} - - - - - - -#' @keywords internal -.HDI <- function(x, prob) { - x <- sort(x) - ci.index <- ceiling(prob * length(x)) - nCIs <- length(x) - ci.index - ci.width <- purrr::map_dbl(1:nCIs, ~ x[.x + ci.index] - x[.x]) - HDImin <- x[which.min(ci.width)] - HDImax <- x[which.min(ci.width) + ci.index] - return(c(HDImin, HDImax)) -} - - - - - - - - -#' Bayes Factor Interpretation -#' -#' Return the interpretation of a Bayes Factor. -#' -#' @param x Bayes Factor. -#' @param direction Include direction (against / in favour). -#' @param bf Include Bayes Factor. -#' @param rules Can be "jeffreys1961" (default), "raftery1995", or a custom list. -#' -#' -#' @examples -#' library(psycho) -#' interpret_bf(x = 10) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @references -#' \itemize{ -#' \item{Jeffreys, H. (1961), Theory of Probability, 3rd ed., Oxford University Press, Oxford.} -#' \item{Jarosz, A. F., & Wiley, J. (2014). What are the odds? A practical guide to computing and reporting Bayes factors. The Journal of Problem Solving, 7(1), 2.} -#' } -#' @export -interpret_bf <- function(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961") { - interpretation <- sapply(x, .interpret_bf, direction = direction, bf = bf, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - -#' Bayes factor formatting -#' -#' Bayes factor formatting -#' -#' @param bf Bayes Factor. -#' @param max Treshold for maximum. -#' -#' @export -format_bf <- function(bf, max = 100) { - if (bf > max) { - bf <- paste0("BF > ", max) - } else { - bf <- paste0("BF = ", format_digit(bf)) - } - return(bf) -} - - - - - - - - - - -#' @keywords internal -.interpret_bf <- function(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961", return_rules = TRUE) { - if (x < 1) { - x <- 1 / abs(x) - dir <- "against" - } else { - dir <- "in favour of" - } - - - if (!is.list(rules)) { - if (rules == "jeffreys1961") { - rules <- list( - "no" = 0, - "anecdotal" = 1, - "moderate" = 3, - "strong" = 10, - "very strong" = 30, - "extreme" = 100 - ) - } else if (rules == "raftery1995") { - rules <- list( - "no" = 0, - "weak" = 1, - "positive" = 3, - "strong" = 20, - "very strong" = 150 - ) - } else { - stop("rules must be either a list or 'jeffreys1961' or 'raftery1995'.") - } - } - - - - s <- (abs(x) - unlist(rules)) - s <- names(which.min(s[s >= 0])) - if (is.null(s)) { - s <- NA - } else { - s <- paste(s, "evidence") - } - - - - - if (bf == TRUE) { - bf <- paste0("(", format_bf(x), ")") - s <- paste(s, bf) - } - if (direction == TRUE) { - s <- paste(s, dir) - } - - return(s) -} - - - - - - - - -#' Standardized difference (Cohen's d) interpreation. -#' -#' Interpret d with a set of rules. -#' -#' @param x Standardized difference. -#' @param direction Return direction. -#' @param rules Can be "cohen1988" (default), "sawilowsky2009", or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_d(-0.42) -#' interpret_d(-0.62) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_d <- function(x, direction = FALSE, rules = "cohen1988") { - interpretation <- sapply(x, .interpret_d, direction = direction, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - - - -#' Standardized difference (Cohen's d) interpreation for a posterior distribution. -#' -#' Interpret d with a set of rules. -#' -#' @param posterior Posterior distribution of standardized differences. -#' @param rules Can be "cohen1988" (default), "sawilowsky2009", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.6, 0.05) -#' interpret_d_posterior(posterior) -#' interpret_d_posterior(rnorm(1000, 0.1, 1)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_d_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_d, rules = rules, direction = TRUE, return_rules = TRUE) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") %>% - tidyr::separate("Interpretation", - c("Size", "Direction"), - " and ", - remove = FALSE - ) %>% - mutate_( - "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', - "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", - "Size" = "factor(Size)" - ) %>% - arrange_("Size") - - values <- list() - for (size in names(sort(rules, decreasing = TRUE))) { - if (size %in% summary$Size) { - if (nrow(summary[summary$Size == size & summary$Opposite == FALSE, ]) == 0) { - values[size] <- 0 - } else { - values[size] <- summary[summary$Size == size & summary$Opposite == FALSE, ]$Probability - } - } else { - values[size] <- 0 - } - } - values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) - - - # Text - if (length(summary[summary$Opposite == FALSE, ]$Size) > 1) { - text_sizes <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Size, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Size, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary[summary$Opposite == FALSE, ]$Size - text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - -#' @keywords internal -.interpret_d <- function(x, direction = FALSE, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.2, - "medium" = 0.5, - "large" = 0.8 - ) - } else if (rules == "sawilowsky2009") { - rules <- list( - "tiny" = 0, - "very small" = 0.1, - "small" = 0.2, - "medium" = 0.5, - "large" = 0.8, - "very large" = 1.2, - "huge" = 2.0 - ) - } else { - stop("rules must be either a list or 'cohen1988' or 'sawilowsky2009'.") - } - } - - - if (x > 0) { - d <- "positive" - } else { - d <- "negative" - } - - x <- (abs(x) - unlist(rules)) - s <- names(which.min(x[x >= 0])) - if (is.null(s)) { - s <- NA - } - - - if (direction) { - interpretation <- paste(s, "and", d) - } else { - interpretation <- s - } - - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} - - - - - - - -#' Interpret fit measures of lavaan or blavaan objects -#' -#' Interpret fit measures of lavaan or blavaan objects -#' -#' @param fit lavaan or blavaan object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_lavaan <- function(fit, ...) { - UseMethod("interpret_lavaan") -} - - - - - - -#' Interpret fit measures of lavaan objects -#' -#' Interpret fit measures of lavaan objects -#' -#' @param fit lavaan or blavaan object. -#' @param ... Arguments passed to or from other methods. -#' -#' @importFrom lavaan fitmeasures -#' @export -interpret_lavaan.lavaan <- function(fit, ...) { - values <- list() - - indices <- lavaan::fitmeasures(fit) - - - for (index in names(indices)) { - values[index] <- indices[index] - } - - # awang2012 - # https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM - if (values$cfi >= 0.9) { - cfi <- "satisfactory" - } else { - cfi <- "poor" - } - if (values$rmsea <= 0.08) { - rmsea <- "satisfactory" - } else { - rmsea <- "poor" - } - if (values$gfi >= 0.9) { - gfi <- "satisfactory" - } else { - gfi <- "poor" - } - if (values$tli >= 0.9) { - tli <- "satisfactory" - } else { - tli <- "poor" - } - if (values$nfi >= 0.9) { - nfi <- "satisfactory" - } else { - nfi <- "poor" - } - - # Summary - summary <- data.frame( - Index = c("RMSEA", "CFI", "GFI", "TLI", "NFI", "Chisq"), - Value = c(values$rmsea, values$cfi, values$gfi, values$tli, values$nfi, values$chisq), - Interpretation = c(rmsea, cfi, gfi, tli, nfi, NA), - Treshold = c("< .08", "> .90", "> 0.90", "> 0.90", "> 0.90", NA) - ) - - # Text - if ("satisfactory" %in% summary$Interpretation) { - satisfactory <- summary %>% - filter_("Interpretation == 'satisfactory'") %>% - mutate_("Index" = "paste0(Index, ' (', format_digit(Value), ' ', Treshold, ')')") %>% - select_("Index") %>% - pull() %>% - paste0(collapse = ", ") - satisfactory <- paste0("The ", satisfactory, " show satisfactory indices of fit.") - } else { - satisfactory <- "" - } - if ("poor" %in% summary$Interpretation) { - poor <- summary %>% - filter_("Interpretation == 'poor'") %>% - mutate_( - "Treshold" = 'stringr::str_replace(Treshold, "<", "SUP")', - "Treshold" = 'stringr::str_replace(Treshold, ">", "INF")', - "Treshold" = 'stringr::str_replace(Treshold, "SUP", ">")', - "Treshold" = 'stringr::str_replace(Treshold, "INF", "<")' - ) %>% - mutate_("Index" = "paste0(Index, ' (', format_digit(Value), ' ', Treshold, ')')") %>% - select_("Index") %>% - pull() %>% - paste0(collapse = ", ") - poor <- paste0("The ", poor, " show poor indices of fit.") - } else { - poor <- "" - } - text <- paste(satisfactory, poor) - - output <- list(text = text, summary = summary, values = values, plot = "Not available yet") - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - -#' Interpret fit measures of blavaan objects -#' -#' Interpret fit measures of blavaan objects -#' -#' @param indices Vector of strings indicating which indices to report. Only works for bayesian objects for now. -#' @inheritParams interpret_lavaan -#' @export -interpret_lavaan.blavaan <- function(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) { - values <- list() - - indices <- lavaan::fitmeasures(fit) - - - for (index in names(indices)) { - values[index] <- indices[index] - } - - # Summary - summary <- as.data.frame(indices) %>% - rownames_to_column("Index") %>% - rename_("Value" = "indices") %>% - mutate_("Index" = "str_to_upper(Index)") - - # Text - relevant_indices <- summary[summary$Index %in% c("BIC", "DIC", "WAIC", "LOOIC"), ] - text <- paste0(relevant_indices$Index, " = ", format_digit(relevant_indices$Value), collapse = ", ") - - output <- list(text = text, summary = summary, values = values, plot = "Not available yet") - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - -#' Odds ratio interpreation for a posterior distribution. -#' -#' Interpret odds with a set of rules. -#' -#' @param x Odds ratio. -#' @param log Are these log odds ratio? -#' @param direction Return direction. -#' @param rules Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_odds(x = 2) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize -#' -#' @references -#' \itemize{ -#' \item{Chen, H., Cohen, P., & Chen, S. (2010). How big is a big odds ratio? Interpreting the magnitudes of odds ratios in epidemiological studies. Communications in Statistics—Simulation and Computation, 39(4), 860-864.} -#' } -#' @export -interpret_odds <- function(x, log = FALSE, direction = FALSE, rules = "chen2010") { - if (rules %in% c("cohen1988", "sawilowsky2009")) { - interpretation <- sapply(odds_to_d(x, log = log), .interpret_d, direction = direction, rules = rules, return_rules = FALSE) - } else { - interpretation <- sapply(x, .interpret_odds, log = log, direction = direction, rules = rules, return_rules = FALSE) - } - return(interpretation) -} - - - - - - - - - - -#' Odds ratio interpreation for a posterior distribution. -#' -#' Interpret odds with a set of rules. -#' -#' @param posterior Posterior distribution of odds ratio. -#' @param log Are these log odds ratio? -#' @param rules Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.6, 0.05) -#' interpret_odds_posterior(posterior) -#' interpret_odds_posterior(rnorm(1000, 0.1, 1)) -#' interpret_odds_posterior(rnorm(1000, 3, 1.5)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_odds_posterior <- function(posterior, log = FALSE, rules = "chen2010") { - if (rules %in% c("cohen1988", "sawilowsky2009")) { - posterior <- odds_to_d(posterior, log = log) - interpretation <- sapply(posterior, .interpret_d, direction = TRUE, rules = rules, return_rules = TRUE) - } else { - interpretation <- sapply(posterior, .interpret_odds, log = log, direction = TRUE, rules = rules, return_rules = TRUE) - } - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") %>% - tidyr::separate("Interpretation", - c("Size", "Direction"), - " and ", - remove = FALSE - ) %>% - mutate_( - "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', - "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", - "Size" = "factor(Size)" - ) %>% - arrange_("Size") - - values <- list() - for (size in names(sort(rules, decreasing = TRUE))) { - if (size %in% summary$Size) { - if (nrow(summary[summary$Size == size & summary$Opposite == FALSE, ]) == 0) { - values[size] <- 0 - } else { - values[size] <- summary[summary$Size == size & summary$Opposite == FALSE, ]$Probability - } - } else { - values[size] <- 0 - } - } - values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) - - - # Text - if (length(summary[summary$Opposite == FALSE, ]$Size) > 1) { - text_sizes <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Size, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Size, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary[summary$Opposite == FALSE, ]$Size - text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") - - text <- paste0( - "The effect's size can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - - - -#' @keywords internal -.interpret_odds <- function(x, log = FALSE, direction = FALSE, rules = "chen2010", return_rules = TRUE) { - if (x > 0) { - d <- "positive" - } else { - d <- "negative" - } - - if (log == TRUE) { - x <- exp(abs(x)) - } - - if (!is.list(rules)) { - if (rules == "chen2010") { - rules <- list( - "very small" = 0, - "small" = 1.68, - "medium" = 3.47, - "large" = 6.71 - ) - } else { - stop("rules must be either a list or 'chen2010'.") - } - } - - - s <- (abs(x) - unlist(rules)) - s <- names(which.min(s[s >= 0])) - if (is.null(s)) { - s <- NA - } - - if (direction) { - interpretation <- paste(s, "and", d) - } else { - interpretation <- s - } - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} - - - - - - - - - - - - - - - - - -#' (Log) odds ratio to Cohen's d -#' -#' (Log) odds ratio to Cohen's d. -#' -#' @param x Odds ratio. -#' @param log Are these log odds ratio? -#' -#' @examples -#' library(psycho) -#' odds_to_d(x = 2) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso https://www.meta-analysis.com/downloads/Meta-analysis%20Converting%20among%20effect%20sizes.pdf -#' -#' @references -#' \itemize{ -#' \item{Sánchez-Meca, J., Marín-Martínez, F., & Chacón-Moscoso, S. (2003). Effect-size indices for dichotomized outcomes in meta-analysis. Psychological methods, 8(4), 448.} -#' } -#' @export -odds_to_d <- function(x, log = TRUE) { - if (log == FALSE) { - x <- log(x) - } - d <- x * (sqrt(3) / pi) - return(d) -} - - - - - - - - - - -#' Omega Squared Interpretation -#' -#' Return the interpretation of Omegas Squared. -#' -#' @param x Omega Squared. -#' @param rules Can be "field2013" (default), or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_omega_sq(x = 0.05) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize -#' -#' @references -#' \itemize{ -#' \item{Field, A (2013) Discovering statistics using IBM SPSS Statistics. Fourth Edition. Sage:London.} -#' } -#' @export -interpret_omega_sq <- function(x, rules = "field2013") { - interpretation <- sapply(x, .interpret_omega_sq, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - - -#' @keywords internal -.interpret_omega_sq <- function(x, rules = "field2013", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "field2013") { - rules <- list( - "very small" = 0, - "small" = 0.01, - "medium" = 0.06, - "large" = 0.14 - ) - } else { - stop("rules must be either a list or 'field2013'.") - } - } - - - - interpretation <- (abs(x) - unlist(rules)) - interpretation <- names(which.min(interpretation[interpretation >= 0])) - if (is.null(interpretation)) { - interpretation <- NA - } - - return(interpretation) -} - - - - - - - - - -#' Correlation coefficient r interpreation. -#' -#' Interpret r with a set of rules. -#' -#' @param x Correlation coefficient. -#' @param direction Return direction. -#' @param strength Return strength. -#' @param rules Can be "cohen1988" (default), "evans1996", or a custom list. -#' -#' -#' @examples -#' library(psycho) -#' interpret_r(-0.42) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso Page 88 of APA's 6th Edition -#' -#' @export -interpret_r <- function(x, direction = TRUE, strength = TRUE, rules = "cohen1988") { - interpretation <- sapply(x, .interpret_r, direction = direction, strength = strength, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - - - - - -#' Correlation coefficient r interpreation for a posterior distribution. -#' -#' Interpret r with a set of rules. -#' -#' @param posterior Posterior distribution of correlation coefficient. -#' @param rules Can be "cohen1988" (default) or "evans1996", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.5, 0.5) -#' interpret_r_posterior(posterior) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @seealso Page 88 of APA's 6th Edition -#' -#' @export -interpret_r_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_r, rules = rules) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") %>% - separate("Interpretation", - c("Strength", "Direction"), - ", and ", - remove = FALSE - ) %>% - mutate_( - "Median" = 'ifelse(median(posterior) > 0, "positive", "negative")', - "Opposite" = "ifelse(Median == Direction, FALSE, TRUE)", - "Strength" = "factor(Strength)" - ) %>% - arrange_("Strength") - - values <- list() - for (strength in names(sort(rules, decreasing = TRUE))) { - if (strength %in% summary$Strength) { - values[strength] <- summary[summary$Strength == strength & summary$Opposite == FALSE, ]$Probability - } else { - values[strength] <- 0 - } - } - values$opposite <- sum(summary[summary$Opposite == TRUE, ]$Probability) - - # Text - if (length(summary[summary$Opposite == FALSE, ]$Strength) > 1) { - text_strength <- paste0(paste0(head(summary[summary$Opposite == FALSE, ]$Strength, -1), collapse = ", "), " or ", tail(summary[summary$Opposite == FALSE, ]$Strength, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary[summary$Opposite == FALSE, ]$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary[summary$Opposite == FALSE, ]$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The correlation can be considered as ", - text_strength, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary[summary$Opposite == FALSE, ]$Strength - text_effects <- paste0(format_digit(summary[summary$Opposite == FALSE, ]$Probability * 100), "%") - - text <- paste0( - "The correlation can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - - - - - - - - - - - -#' @keywords internal -.interpret_r <- function(x, direction = TRUE, strength = TRUE, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "evans1996") { - rules <- list( - "very weak" = 0, - "weak" = 0.20, - "moderate" = 0.40, - "strong" = 0.60, - "very strong" = 0.80 - ) - } else if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.10, - "moderate" = 0.30, - "large" = 0.50 - ) - } else { - stop("rules must be either a list or 'cohen1988' or 'evans1996'.") - } - } - - - if (x > 0) { - d <- "positive" - } else { - d <- "negative" - } - - x <- (abs(x) - unlist(rules)) - s <- names(which.min(x[x >= 0])) - if (is.null(s)) { - s <- NA - } - - - - if (strength & direction) { - interpretation <- paste0(s, ", and ", d) - } else if (strength & direction == FALSE) { - interpretation <- s - } else { - interpretation <- d - } - - - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} - - - - - - - - -#' R2 interpreation. -#' -#' Interpret R2 with a set of rules. -#' -#' @param x Value. -#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_R2(x = 0.42) -#' interpret_R2(x = c(0.42, 0.2, 0.9, 0)) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_R2 <- function(x, rules = "cohen1988") { - interpretation <- sapply(x, .interpret_R2, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - -#' R2 interpreation for a posterior distribution. -#' -#' Interpret R2 with a set of rules. -#' -#' @param posterior Distribution of R2. -#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.4, 0.1) -#' interpret_R2_posterior(posterior) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_R2_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_R2, rules = rules) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") - - values <- list() - for (value in names(sort(rules, decreasing = TRUE))) { - if (value %in% summary$Interpretation) { - values[value] <- summary[summary$Interpretation == value, ]$Probability - } else { - values[value] <- 0 - } - } - - # Text - if (length(summary$Interpretation) > 1) { - text_strength <- paste0(paste0(head(summary$Interpretation, -1), collapse = ", "), " or ", tail(summary$Interpretation, 1)) - text_effects <- paste0( - paste0(paste0(format_digit(head(summary$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(format_digit(tail(summary$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The R2 can be considered as ", - text_strength, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary$Interpretation - text_effects <- paste0(format_digit(summary$Probability * 100), "%") - - text <- paste0( - "The R2 can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - - - - - -#' @keywords internal -.interpret_R2 <- function(x, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.02, - "medium" = 0.13, - "large" = 0.26 - ) - } else if (rules == "chin1998") { - rules <- list( - "very small" = 0, - "small" = 0.19, - "medium" = 0.33, - "large" = 0.67 - ) - } else if (rules == "hair2013") { - rules <- list( - "very small" = 0, - "small" = 0.25, - "medium" = 0.50, - "large" = 0.75 - ) - } else { - stop("rules must be either a list or 'cohen1988', 'chin1998' or 'hair2013'.") - } - } - - x <- (x - unlist(rules)) - interpretation <- names(which.min(x[x >= 0])) - if (is.null(interpretation)) { - interpretation <- NA - } - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} - - - - - - -#' RMSEA interpreation. -#' -#' Interpret RMSEA with a set of rules. -#' -#' @param x RMSEA. -#' @param rules Can be "awang2012", or a custom list. -#' -#' @examples -#' library(psycho) -#' interpret_RMSEA(0.04) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -interpret_RMSEA <- function(x, rules = "awang2012") { - interpretation <- sapply(x, .interpret_RMSEA, rules = rules, return_rules = FALSE) - return(interpretation) -} - - - - - -#' @keywords internal -.interpret_RMSEA <- function(x, rules = "awang2012", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "awang2012") { - rules <- list( - "good" = 0, - "acceptable" = 0.05, - "poor" = 0.08 - ) - } else { - stop("rules must be either a list or 'awang2012'.") - } - } - - x <- (abs(x) - unlist(rules)) - s <- names(which.min(x[x >= 0])) - if (is.null(s)) { - s <- NA - } - - if (return_rules) { - return(list(interpretation = s, rules = rules)) - } else { - return(s) - } -} - - - - - -#' Check if model includes random effects. -#' -#' Check if model is mixed. See the -#' documentation for your model's class: -#' \itemize{ -#' \item{\link[=is.mixed.stanreg]{is.mixed.stanreg}} -#' } -#' -#' @param fit Model. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -is.mixed <- function(fit, ...) { - UseMethod("is.mixed") -} - - - - - - - - - - - - - -#' Check if model includes random effects. -#' -#' Check if model is mixed. -#' -#' @param fit Model. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -is.mixed.stanreg <- function(fit, ...) { - mixed <- tryCatch({ - broom::tidy(fit, parameters = "varying") - TRUE - }, error = function(e) { - FALSE - }) - return(mixed) -} - - - - - - - - - -#' Check if a dataframe is standardized. -#' -#' Check if a dataframe is standardized. -#' -#' @param df A dataframe. -#' @param tol The error treshold. -#' -#' @examples -#' library(psycho) -#' -#' df <- psycho::affective -#' is.standardized(df) -#' -#' dfZ <- psycho::standardize(df) -#' is.standardized(dfZ) -#' @return bool. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import purrr -#' @export -is.standardized <- function(df, tol = 0.1) { - dfZ <- standardize(df) - dfZnum <- purrr::keep(dfZ, is.numeric) - - dfnum <- purrr::keep(df, is.numeric) - - error <- as.matrix(dfnum) - as.matrix(dfZnum) - error <- as.data.frame(error) - names(error) <- names(dfnum) - - error_mean <- error %>% - summarise_all(mean) - - if (TRUE %in% as.character(error_mean[1, ] > tol)) { - standardized <- FALSE - } else { - standardized <- TRUE - } - return(standardized) -} - - - - - - - -#' Mellenbergh & van den Brink (1998) test for pre-post comparison. -#' -#' Test for comparing post-test to baseline for a single participant. -#' -#' @param t0 Single value (pretest or baseline score). -#' @param t1 Single value (posttest score). -#' @param controls Vector of scores of the control group OR single value corresponding to the control SD of the score. -#' -#' @return Returns a data frame containing the z-value and p-value. If significant, the difference between pre and post tests is significant. -#' -#' @examples -#' library(psycho) -#' -#' mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) -#' mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) -#' @author Dominique Makowski -#' -#' @importFrom stats pnorm sd -#' @export -mellenbergh.test <- function(t0, t1, controls) { - if (length(controls) > 1) { - sd <- sd(controls) * sqrt(2) - } else { - sd <- controls * sqrt(2) - } - - diff <- t1 - t0 - - diff_CI_bottom <- diff - 1.65 * sd - diff_CI_top <- diff + 1.65 * sd - z <- diff / sd - pval <- 2 * pnorm(-abs(z)) - # One-tailed p value - if (pval > .05 & pval / 2 < .05) { - one_tailed <- paste0( - " However, the null hypothesis of no change can be rejected at a one-tailed 5% significance level (one-tailed p ", - format_p(pval / 2), - ")." - ) - } else { - one_tailed <- "" - } - p_interpretation <- ifelse(pval < 0.05, " ", " not ") - text <- paste0( - "The Mellenbergh & van den Brink (1998) test suggests that the change is", - p_interpretation, - "significant (d = ", - format_digit(diff), - ", 90% CI [", - format_digit(diff_CI_bottom), - ", ", - format_digit(diff_CI_top), - "], z = ", - format_digit(z), - ", p ", - format_p(pval), - ").", - one_tailed - ) - values <- list( - text = text, - diff = diff, - diff_90_CI_lower = diff_CI_bottom, - diff_90_CI_higher = diff_CI_top, - z = z, - p = pval - ) - summary <- data.frame(diff = diff, diff_90_CI_lower = diff_CI_bottom, diff_90_CI_higher = diff_CI_top, z = z, p = pval) - plot <- "Not available yet" - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) - # return("The method for no-controls is not implemented yet.") -} @@ -9283,105 +331,11 @@ mellenbergh.test <- function(t0, t1, controls) { -#' Model to Prior. -#' -#' Convert a Bayesian model's results to priors. -#' -#' @param fit A stanreg model. -#' @param autoscale Set autoscale. -#' @examples -#' \dontrun{ -#' library(rstanarm) -#' library(psycho) -#' -#' fit <- stan_glm(Sepal.Length ~ Petal.Width, data = iris) -#' priors <- model_to_priors(fit) -#' update(fit, prior = priors$prior) -#' -#' fit <- stan_glmer(Subjective_Valence ~ Emotion_Condition + (1 | Participant_ID), -#' data = psycho::emotion -#' ) -#' priors <- model_to_priors(fit) -#' -#' fit1 <- stan_glm(Subjective_Valence ~ Emotion_Condition, -#' data = filter(psycho::emotion, Participant_ID == "1S") -#' ) -#' -#' fit2 <- stan_glm(Subjective_Valence ~ Emotion_Condition, -#' data = filter(psycho::emotion, Participant_ID == "1S"), -#' prior = priors$prior, prior_intercept = priors$prior_intercept -#' ) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' @importFrom stats update -#' @importFrom rstanarm normal -#' @export -model_to_priors <- function(fit, autoscale = FALSE) { - posteriors <- as.data.frame(fit) - - # Varnames - varnames <- names(posteriors) - varnames <- varnames[grepl("b\\[", varnames) == FALSE] - - fixed_effects <- names(fit$coefficients) - fixed_effects <- fixed_effects[grepl("b\\[", fixed_effects) == FALSE] - fixed_effects <- fixed_effects[fixed_effects != "(Intercept)"] - - # Get priors - prior_intercept <- list() - priors <- list() - prior_aux <- list() - for (prior in varnames) { - if (prior == "(Intercept)") { - prior_intercept$mean <- mean(posteriors[[prior]]) - prior_intercept$sd <- sd(posteriors[[prior]]) - } else if (prior %in% fixed_effects) { - priors[[prior]] <- list() - priors[[prior]]$mean <- mean(posteriors[[prior]]) - priors[[prior]]$sd <- sd(posteriors[[prior]]) - } else { - prior_aux[[prior]] <- list() - prior_aux[[prior]]$mean <- mean(posteriors[[prior]]) - prior_aux[[prior]]$sd <- sd(posteriors[[prior]]) - } - } - prior_intercept <- rstanarm::normal( - prior_intercept$mean, - prior_intercept$sd, - autoscale = autoscale - ) - prior <- .format_priors(priors, autoscale = autoscale) - prior_aux <- .format_priors(prior_aux, autoscale = autoscale) - return(list(prior_intercept = prior_intercept, prior = prior, priox_aux = prior_aux)) -} -#' @keywords internal -.format_priors <- function(priors, autoscale = FALSE) { - prior_mean <- data.frame(priors) %>% - select(contains("mean")) %>% - gather() %>% - select_("value") %>% - pull() - - prior_sd <- data.frame(priors) %>% - select(contains("sd")) %>% - gather() %>% - select_("value") %>% - pull() - - prior <- rstanarm::normal( - prior_mean, - prior_sd, - autoscale = autoscale - ) -} @@ -9389,359 +343,124 @@ model_to_priors <- function(fit, autoscale = FALSE) { -#' Compute Maximum Probability of Effect (MPE). -#' -#' Compute the Maximum Probability of Effect (MPE), i.e., the proportion of posterior distribution that is of the same sign as the median. In other words, it corresponds to the maximum probability that the effect is different from 0 in the median’s direction. -#' -#' @param posterior Posterior Distribution. + + +#' Generate all combinations. #' -#' @return list containing the MPE and its values. +#' Generate all combinations. #' -#' @examples -#' library(psycho) -#' library(rstanarm) +#' @param object Object +#' @param ... Arguments passed to or from other methods. #' -#' fit <- rstanarm::stan_glm(rating ~ advance, data = attitude) -#' posterior <- psycho::analyze(fit)$values$effects$advance$posterior -#' mpe <- psycho::mpe(posterior) -#' print(mpe$MPE) -#' print(mpe$values) #' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} #' #' @export -mpe <- function(posterior) { - median <- median(posterior) - if (median >= 0) { - MPE <- length(posterior[posterior >= 0]) / length(posterior) * 100 - if (MPE == 100) { - MPE_values <- c(min(posterior), max(posterior)) - } else { - MPE_values <- c(0, max(posterior)) - } - } else { - MPE <- length(posterior[posterior < 0]) / length(posterior) * 100 - if (MPE == 100) { - MPE_values <- c(min(posterior), max(posterior)) - } else { - MPE_values <- c(min(posterior), 0) - } - } - - MPE <- list(MPE = MPE, values = MPE_values) - return(MPE) +find_combinations <- function(object, ...) { + UseMethod("find_combinations") } - - - - - -#' Find Optimal Factor Number. +#' Generate all combinations of predictors of a formula. #' -#' Find optimal components number using maximum method aggreement. +#' Generate all combinations of predictors of a formula. #' -#' @param df A dataframe or correlation matrix -#' @param rotate What rotation to use c("none", "varimax", "oblimin","promax") -#' @param fm Factoring method: "pa" for Principal Axis Factor Analysis, -#' "minres" (default) for minimum residual (OLS) factoring, "mle" for -#' Maximum Likelihood FA and "pc" for Principal Components -#' @param n If correlation matrix is passed, the sample size. +#' @param object Formula. +#' @param interaction Include interaction term. +#' @param fixed Additional formula part to add at the beginning of +#' each combination. +#' @param ... Arguments passed to or from other methods. #' -#' @return output +#' @return list containing all combinations. #' #' @examples -#' df <- dplyr::select_if(attitude, is.numeric) -#' results <- psycho::n_factors(df) +#' library(psycho) #' -#' summary(results) -#' plot(results) +#' f <- as.formula("Y ~ A + B + C + D") +#' f <- as.formula("Y ~ A + B + C + D + (1|E)") +#' f <- as.formula("Y ~ A + B + C + D + (1|E) + (1|F)") #' -#' # See details on methods -#' psycho::values(results)$methods +#' find_combinations(f) #' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} #' -#' @importFrom qgraph cor_auto -#' @importFrom psych VSS -#' @importFrom MASS mvrnorm -#' @importFrom MASS ginv -#' @importFrom nFactors moreStats -#' @importFrom nFactors nScree -#' @importFrom stats cov -#' @importFrom stats dnorm -#' @importFrom stats qnorm +#' @method find_combinations formula +#' @importFrom utils combn +#' @importFrom stats terms #' @export -n_factors <- function(df, rotate = "varimax", fm = "minres", n = NULL) { - - # Copy the parallel function from nFactors to correct the use of mvrnorm - parallel <- function(subject = 100, var = 10, rep = 100, cent = 0.05, - quantile = cent, model = "components", - sd = diag(1, var), ...) { - r <- subject - c <- var - y <- matrix(c(1:r * c), nrow = r, ncol = c) - evpea <- NULL - for (k in c(1:rep)) { - y <- MASS::mvrnorm(n = r, mu = rep(0, var), Sigma = sd, empirical = FALSE) - corY <- cov(y, ...) - if (model == "components") { - diag(corY) <- diag(sd) - } - if (model == "factors") { - corY <- corY - MASS::ginv(diag(diag(MASS::ginv(corY)))) - } - evpea <- rbind(evpea, eigen(corY)[[1]]) - } - SEcentile <- function(sd, n = 100, p = 0.95) { - return(sd / sqrt(n) * sqrt(p * (1 - p)) / dnorm(qnorm(p))) - } - mevpea <- sapply(as.data.frame(evpea), mean) - sevpea <- sapply(as.data.frame(evpea), sd) - qevpea <- nFactors::moreStats(evpea, quantile = quantile)[3, ] - sqevpea <- sevpea - sqevpea <- sapply( - as.data.frame(sqevpea), SEcentile, - n = rep, - p = cent - ) - result <- list( - eigen = data.frame( - mevpea, sevpea, qevpea, - sqevpea - ), - subject = r, - variables = c, - centile = cent - ) - class(result) <- "parallel" - return(result) - } +find_combinations.formula <- function(object, interaction = TRUE, fixed = NULL, ...) { - # Detect if df us a correlation matrix - if (length(setdiff(names(df), rownames(df))) != 0) { - cor <- qgraph::cor_auto(df, forcePD = FALSE) - n <- nrow(df) + # Extract infos + formula <- object + vars <- attributes(terms(formula))$term.labels + outcome <- all.vars(formula)[1] + pred <- vars[!grepl("\\|", vars)] + if (length(vars[grepl("\\|", vars)]) > 0) { + random <- paste0(" + (", vars[grepl("\\|", vars)], ")") } else { - if (is.null(n)) { - stop("A correlation matrix was passed. You must provided the sample size (n).") - } - cor <- df + random <- "" } + if (is.null(fixed)) { + fixed <- "" + } else { + fixed <- fixed + } - ap <- parallel(subject = n, var = ncol(cor)) - nS <- nFactors::nScree(x = eigen(cor)$values, aparallel = ap$eigen$qevpea) - - # Eigeinvalues data - eigenvalues <- nS$Analysis %>% - dplyr::select_( - "Eigenvalues", - "Exp.Variance" = "Prop", - "Cum.Variance" = "Cumu" - ) %>% - mutate_("n.Factors" = ~ seq_len(nrow(nS$Analysis))) - - - - + # Generate combinations + n <- length(pred) - # Processing - # ------------------- - results <- data.frame( - Method = c( - "Optimal Coordinates", - "Acceleration Factor", - "Parallel Analysis", - "Eigenvalues (Kaiser Criterion)" + id <- unlist( + lapply( + 1:n, + function(i) combn(1:n, i, simplify = FALSE) ), - n_optimal = as.numeric(nS$Components[1, ]) + recursive = FALSE ) - # EGA Method - # Doesn't really work for now :( - # ega <- EGA::EGA(cor, plot.EGA = F, matrix=TRUE, n = n) - # ega <- EGA::bootEGA(df, n = 1000) - - # VSS - vss <- psych::VSS( - cor, - n.obs = n, - rotate = rotate, - fm = fm, plot = F - ) # fm can be "pa", "pc", "minres", "mle" - stats <- vss$vss.stats - stats$map <- vss$map - stats$n_factors <- seq_len(nrow(stats)) - - # map - if (length(stats$map[!is.na(stats$map)]) > 0) { - min <- min(stats$map[!is.na(stats$map)]) - opt <- stats[stats$map == min, ]$n_factors[!is.na(stats[stats$map == min, ]$n_factors)] - results <- rbind( - results, - data.frame( - Method = c("Velicer MAP"), - n_optimal = c(opt) - ) - ) - } - # bic - if (length(stats$BIC[!is.na(stats$BIC)]) > 0) { - min <- min(stats$BIC[!is.na(stats$BIC)]) - opt <- stats[stats$BIC == min, ]$n_factors[!is.na(stats[stats$BIC == min, ]$n_factors)] - results <- rbind( - results, - data.frame( - Method = c("BIC"), - n_optimal = c(opt) - ) - ) - } - # sabic - if (length(stats$SABIC[!is.na(stats$SABIC)]) > 0) { - min <- min(stats$SABIC[!is.na(stats$SABIC)]) - opt <- stats[stats$SABIC == min, ]$n_factors[!is.na(stats[stats$SABIC == min, ]$n_factors)] - results <- rbind( - results, - data.frame( - Method = c("Sample Size Adjusted BIC"), - n_optimal = c(opt) - ) - ) + combinations <- sapply(id, function(i) + paste(paste(pred[i], collapse = " + "))) + + + # Generate interactions + if (interaction == TRUE) { + for (comb in combinations) { + n_signs <- stringr::str_count(comb, "\\+") + if (n_signs > 0) { + new_formula <- comb + for (i in 1:n_signs) { + new_formula <- stringr::str_replace(new_formula, "\\+", "*") + combinations <- c(combinations, new_formula) + } + } + } } + combinations <- paste0(outcome, " ~ ", fixed, combinations, paste0(random, collapse = "")) + return(combinations) +} + - cfits <- vss[grep("cfit", names(vss))] - for (name in names(cfits)) { - cfit <- cfits[[name]] - cfit <- data.frame(cfit = cfit, n_factors = seq_len(length(cfit))) - result3 <- data.frame( - Method = c(gsub("cfit.", "VSS Complexity ", name)), - n_optimal = c(na.omit(cfit[cfit$cfit == max(cfit$cfit, na.rm = TRUE), ])$n_factors) - ) - results <- rbind(results, result3) - } - eigenvalues <- results %>% - group_by_("n_optimal") %>% - summarise_("n_method" = ~ n()) %>% - mutate_("n_optimal" = ~ factor(n_optimal, levels = seq_len(nrow(eigenvalues)))) %>% - complete_("n_optimal", fill = list(n_method = 0)) %>% - arrange_("n_optimal") %>% - rename_( - "n.Factors" = "n_optimal", - "n.Methods" = "n_method" - ) %>% - mutate_("n.Factors" = ~ as.integer(n.Factors)) %>% - left_join(eigenvalues, by = "n.Factors") %>% - select_("-Exp.Variance") - # Summary - # ------------- - summary <- eigenvalues - # Values - # ------------- - best_n_df <- filter_(summary, "n.Methods == max(n.Methods)") - best_n <- best_n_df$n.Factors - best_n_methods <- list() - for (i in as.list(best_n)) { - methods_list <- results[results$n_optimal %in% as.list(i), ] - methods_list <- as.character(methods_list$Method) - best_n_methods[[paste0("n_", i)]] <- paste(methods_list, collapse = ", ") - } - values <- list(summary = summary, methods = results, best_n_df = best_n) - # Text - # ------------- - # Deal with equality - if (length(best_n) > 1) { - best_n <- head(best_n, length(best_n) - 1) %>% - paste(collapse = ", ") %>% - paste(best_n[length(best_n)], sep = " and ") - factor_text <- " factors " - n_methods <- unique(best_n_df$n.Methods) - best_n_methods <- paste0(paste(best_n_methods, collapse = "; "), "; respectively") - } else { - n_methods <- best_n_df$n.Methods - # Plural - if (best_n == 1) { - factor_text <- " factor " - } else { - factor_text <- " factors " - } - } - text <- paste0( - "The choice of ", - best_n, - factor_text, - "is supported by ", - n_methods, - " (out of ", - round(nrow(results)), - "; ", - round(n_methods / nrow(results) * 100, 2), - "%) methods (", - best_n_methods, - ")." - ) - # Plot - # ------------- - plot_data <- summary - plot_data$n.Methods.Ratio <- plot_data$n.Methods / sum(plot_data$n.Methods) - plot_data$n.Methods.Ratio <- plot_data$n.Methods.Ratio * (1 / max(plot_data$n.Methods.Ratio)) - plot_data$area <- plot_data$n.Methods.Ratio / (max(plot_data$n.Methods.Ratio) / max(plot_data$Eigenvalues)) - plot_data$var <- plot_data$Cum.Variance / (max(plot_data$Cum.Variance) / max(plot_data$Eigenvalues)) - - plot <- plot_data %>% - ggplot(aes_string(x = "n.Factors", y = "Eigenvalues")) + - geom_area( - aes_string(y = "area"), - fill = "#FFC107", - alpha = 0.5 - ) + - geom_line( - colour = "#E91E63", - size = 1 - ) + - geom_hline(yintercept = 1, linetype = "dashed", colour = "#607D8B") + - geom_line( - aes_string(y = "var"), - colour = "#2196F3", - size = 1 - ) + - scale_y_continuous(sec.axis = sec_axis( - trans = ~ . * (max(plot_data$Cum.Variance) / max(plot_data$Eigenvalues)), - name = "Cumulative Variance\n" - )) + - ylab("Eigenvalues\n") + - xlab("\nNumber of Factors") + - theme_minimal() - - # Output - # ------------- - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - return(output) -} @@ -9751,87 +470,45 @@ n_factors <- function(df, rotate = "varimax", fm = "minres", n = NULL) { -#' Convert (log)odds to probabilies. +#' Clean and format formula. +#' +#' Clean and format formula. +#' +#' @param formula formula +#' @param ... Arguments passed to or from other methods. #' -#' @param odds Odds values in vector or dataframe. -#' @param subset Character or list of characters of column names to be -#' transformed. -#' @param except Character or list of characters of column names to be excluded -#' from transformation. -#' @param log Are these Log odds (such as in logistic models)? #' #' @examples #' library(psycho) -#' odds_to_probs(-1.45) +#' library(lme4) +#' +#' fit <- lm(hp ~ wt, data = mtcars) +#' +#' format_formula(fit$call$formula) #' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} #' -#' @importFrom purrr keep discard #' @export -odds_to_probs <- function(odds, subset = NULL, except = NULL, log = TRUE) { +format_formula <- function(formula) { + formula <- tryCatch({ + stringr::str_squish(paste(format(eval(formula)), collapse = "")) + }, error = function(e) { + formula <- stringr::str_squish(paste(format(formula), collapse = "")) + }) - # If vector - if (ncol(as.matrix(odds)) == 1) { - return(.odds_to_probs(odds, log = log)) - } else { - df <- odds - } + return(formula) +} - # Variable order - var_order <- names(df) - # Keep subset - if (!is.null(subset) && subset %in% names(df)) { - to_keep <- as.data.frame(df[!names(df) %in% c(subset)]) - df <- df[names(df) %in% c(subset)] - } else { - to_keep <- NULL - } - # Remove exceptions - if (!is.null(except) && except %in% names(df)) { - if (is.null(to_keep)) { - to_keep <- as.data.frame(df[except]) - } else { - to_keep <- cbind(to_keep, as.data.frame(df[except])) - } - df <- df[!names(df) %in% c(except)] - } - # Remove non-numerics - dfother <- purrr::discard(df, is.numeric) - dfnum <- purrr::keep(df, is.numeric) - # Tranform - dfnum <- .odds_to_probs(dfnum, log = log) - # Add non-numerics - if (is.null(ncol(dfother))) { - df <- dfnum - } else { - df <- dplyr::bind_cols(dfother, dfnum) - } - # Add exceptions - if (!is.null(subset) | !is.null(except) && exists("to_keep")) { - df <- dplyr::bind_cols(df, to_keep) - } - # Reorder - df <- df[var_order] - return(df) -} -#' @keywords internal -.odds_to_probs <- function(odds, log = TRUE) { - if (log == TRUE) { - odds <- exp(odds) - } - probs <- odds / (1 + odds) - return(probs) -} @@ -9840,46 +517,6 @@ odds_to_probs <- function(odds, subset = NULL, except = NULL, log = TRUE) { -#' Overlap of Two Empirical Distributions. -#' -#' A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). -#' -#' @param x A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling). -#' @param y Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated. -#' @param method Method of AUC computation. Can be "trapezoid" (default), "step" or "spline". -#' -#' @examples -#' library(psycho) -#' -#' x <- rnorm(100, 1, 0.5) -#' y <- rnorm(100, 0, 1) -#' overlap(x, y) -#' @author S. Venne -#' -#' @importFrom stats density -#' @importFrom DescTools AUC -#' @export -overlap <- function(x, y, method = "trapezoid") { - # define limits of a common grid, adding a buffer so that tails aren't cut off - lower <- min(c(x, y)) - 1 - upper <- max(c(x, y)) + 1 - - # generate kernel densities - da <- stats::density(x, from = lower, to = upper) - db <- stats::density(y, from = lower, to = upper) - d <- data.frame(x = da$x, a = da$y, b = db$y) - - # calculate intersection densities - d$w <- pmin(d$a, d$b) - - # integrate areas under curves - total <- DescTools::AUC(d$x, d$a, method = method) + DescTools::AUC(d$x, d$b, method = method) - intersection <- DescTools::AUC(d$x, d$w, method = method) - - # compute overlap coefficient - overlap <- 2 * intersection / total - return(overlap) -} @@ -9891,66 +528,160 @@ overlap <- function(x, y, method = "trapezoid") { -#' Transform z score to percentile. -#' -#' @param z_score Z score. -#' -#' @examples -#' library(psycho) -#' percentile(-1.96) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats pnorm -#' @export -percentile <- function(z_score) { - perc <- pnorm(z_score) * 100 - return(perc) -} -#' Transform a percentile to a z score. -#' -#' @param percentile Percentile -#' -#' @examples -#' library(psycho) -#' percentile_to_z(95) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats pnorm -#' @export -percentile_to_z <- function(percentile) { - z <- qnorm(percentile / 100) - return(z) -} +# get_graph.lavaan <- function(fit, links = c("Regression", "Correlation", "Loading"), standardize = FALSE, threshold_Coef = NULL, threshold_p = NULL, threshold_MPE = NULL, digits = 2, CI = "default", labels_CI = TRUE, ...) { +# # https://www.r-bloggers.com/ggplot2-sem-models-with-tidygraph-and-ggraph/ +# +# +# if (labels_CI == TRUE) { +# if (CI != "default") { +# results <- analyze(fit, CI = CI, standardize = standardize) +# } else { +# results <- analyze(fit, standardize = standardize) +# } +# } else { +# results <- analyze(fit, standardize = standardize) +# } +# +# summary <- summary(results) +# CI <- results$values$CI +# +# # Check what type of model +# if (class(fit) %in% c("blavaan")) { +# summary$Coef <- summary$Median +# if (is.null(threshold_MPE)) { +# threshold_MPE <- -1 +# } +# summary <- summary %>% +# filter_("MPE >= threshold_MPE") +# } else if (class(fit) %in% c("lavaan")) { +# if (is.null(threshold_p)) { +# threshold_p <- 1.1 +# } +# summary <- summary %>% +# filter_("p <= threshold_p") +# } else { +# stop(paste("Error in UseMethod('plot_lavaan') : no applicable method for 'plot_lavaan' applied to an object of class", class(fit))) +# } +# +# # Deal with thresholds +# if (is.null(threshold_Coef)) { +# threshold_Coef <- min(abs(summary$Coef)) - 1 +# } +# +# # Edge properties +# edges <- summary %>% +# mutate_("abs_coef" = "abs(Coef)") %>% +# filter_( +# "Type %in% c(links)", +# "From != To", +# "abs_coef >= threshold_Coef" +# ) %>% +# select(-one_of("abs_coef")) %>% +# rename_( +# "to" = "To", +# "from" = "From" +# ) +# +# # Labels +# if (labels_CI == TRUE) { +# edges <- edges %>% +# mutate_("Label" = 'paste0(insight::format_value(Coef, digits), +# ", ", CI, "% CI [", insight::format_value(CI_lower, digits), +# ", ", insight::format_value(CI_higher, digits), "]")') +# } else { +# edges <- edges %>% +# mutate_("Label" = "insight::format_value(Coef, digits)") +# } +# edges <- edges %>% +# mutate_( +# "Label_Regression" = "ifelse(Type=='Regression', Label, '')", +# "Label_Correlation" = "ifelse(Type=='Correlation', Label, '')", +# "Label_Loading" = "ifelse(Type=='Loading', Label, '')" +# ) +# edges <- edges[colSums(!is.na(edges)) > 0] +# +# # Identify latent variables for nodes +# latent_nodes <- edges %>% +# filter_('Type == "Loading"') %>% +# distinct_("to") %>% +# transmute_("Name" = "to", "Latent" = TRUE) +# +# nodes_list <- unique(c(edges$from, edges$to)) +# +# # Node properties +# nodes <- summary %>% +# filter_( +# "From == To", +# "From %in% nodes_list" +# ) %>% +# mutate_("Name" = "From") %>% +# left_join(latent_nodes, by = "Name") %>% +# mutate_("Latent" = "if_else(is.na(Latent), FALSE, Latent)") %>% +# select(one_of(c("Name", "Latent"))) +# +# return(list(nodes = nodes, edges = edges)) +# } -#' Plot the results. -#' -#' @param x A psychobject class object. -#' @param ... Arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -plot.psychobject <- function(x, ...) { - plot <- x$plot - return(plot) -} +# get_graph.fa <- function(fit, threshold_Coef = NULL, digits = 2, ...) { +# edges <- summary(analyze(fit)) %>% +# tidyr::gather("To", "Coef", -one_of("N", "Item", "Label")) %>% +# rename_("From" = "Item") %>% +# mutate_("Label" = "insight::format_value(Coef, digits)") %>% +# select(one_of("From", "To", "Coef", "Label"), everything()) %>% +# dplyr::filter() +# +# # Deal with thresholds +# if (is.null(threshold_Coef)) { +# threshold_Coef <- min(abs(edges$Coef)) - 1 +# } +# +# edges <- edges %>% +# filter_("Coef > threshold_Coef") +# +# nodes <- data.frame("Name" = c(edges$From, edges$To)) %>% +# distinct_("Name") +# +# return(list(nodes = nodes, edges = edges)) +# } +# get_graph.psychobject_correlation <- function(fit, ...) { +# vars <- row.names(fit$values$r) +# +# r <- fit$values$r %>% +# as.data.frame() %>% +# tibble::rownames_to_column("from") %>% +# tidyr::gather("to", "r", vars) +# +# if ("p" %in% names(fit$values)) { +# r <- r %>% +# full_join( +# fit$values$p %>% +# as.data.frame() %>% +# tibble::rownames_to_column("from") %>% +# tidyr::gather("to", "p", vars), +# by = c("from", "to") +# ) +# } +# +# r <- filter_(r, "!from == to") +# return(r) +# } @@ -9958,95 +689,15 @@ plot.psychobject <- function(x, ...) { -#' Power analysis for fitted models. -#' -#' Compute the n models based on n sampling of data. -#' -#' @param fit A lm or stanreg model. -#' @param n_max Max sample size. -#' @param n_min Min sample size. If null, take current nrow. -#' @param step Increment of the sequence. -#' @param n_batch Number of iterations at each sample size. -#' @param groups Grouping variable name (string) to preserve proportions. Can be a list of strings. -#' @param verbose Print progress. -#' @param CI Argument for \link[=analyze]{analyze}. -#' @param effsize Argument for \link[=analyze]{analyze}. -#' @param effsize_rules Argument for \link[=analyze]{analyze}. -#' @param bayes_factor Argument for \link[=analyze]{analyze}. -#' @param overlap rgument for \link[=analyze]{analyze}. -#' -#' @return A dataframe containing the summary of all models for all iterations. -#' -#' @examples -#' \dontrun{ -#' library(dplyr) -#' library(psycho) -#' -#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) -#' -#' results <- power_analysis(fit, n_max = 300, n_min = 100, step = 5, n_batch = 20) -#' -#' results %>% -#' filter(Variable == "Sepal.Width") %>% -#' select(n, p) %>% -#' group_by(n) %>% -#' summarise( -#' p_median = median(p), -#' p_mad = mad(p) -#' ) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @importFrom stats model.frame -#' @import dplyr -#' @export -power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, groups = NULL, verbose = TRUE, CI = 90, effsize = FALSE, effsize_rules = "cohen1988", bayes_factor = FALSE, overlap = FALSE) { - # Parameters - df <- model.frame(fit) - if (is.null(n_min)) { - n_min <- nrow(df) - } - results <- data.frame() - for (n in seq(n_min, n_max, step)) { - for (batch in 1:n_batch) { - # Progress - if (verbose == TRUE) { - cat(".") - } - # Sample data.frame - if (!is.null(groups)) { - newdf <- df %>% - group_by_(groups) %>% - dplyr::sample_frac(n / nrow(df), replace = TRUE) - } else { - newdf <- dplyr::sample_frac(df, n / nrow(df), replace = TRUE) - } - # Fit new model - newfit <- update(fit, data = newdf) - newfit <- analyze(newfit, CI = CI, effsize = effsize, bayes_factor = bayes_factor, overlap = overlap, effsize_rules = effsize_rules) - # Store results - newresults <- summary(newfit) - newresults$n <- n - newresults$batch <- batch - results <- rbind(results, newresults) - } - # Progress - if (verbose == TRUE) { - cat(paste0(format_digit(round((n - n_min) / (n_max - n_min) * 100)), "%\n")) - } - } - return(results) -} @@ -10058,19 +709,6 @@ power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, grou -#' Print the results. -#' -#' @param x A psychobject class object. -#' @param ... Further arguments passed to or from other methods. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -print.psychobject <- function(x, ...) { - text <- x$text - cat(text, sep = "\n") - invisible(text) -} @@ -10080,35 +718,42 @@ print.psychobject <- function(x, ...) { -#' Convert probabilities to (log)odds. -#' -#' @param probs Probabilities values in vector or dataframe. -#' @param log Compute log odds (such as in logistic models)? + + + + + +#' Interpret fit measures of blavaan objects #' -#' @examples -#' library(psycho) -#' probs_to_odds(0.75) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' Interpret fit measures of blavaan objects #' +#' @param indices Vector of strings indicating which indices to report. Only works for bayesian objects for now. +#' @param fit A blavaan model. +#' @param ... Other arguments. #' @export -probs_to_odds <- function(probs, log = FALSE) { +interpret_blavaan <- function(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) { + values <- list() - # If vector - if (ncol(as.matrix(probs)) == 1) { - return(.probs_to_odds(probs, log = log)) - } else { - warning("Provide single value or vector.") - } -} + indices <- lavaan::fitmeasures(fit) -#' @keywords internal -.probs_to_odds <- function(probs, log = FALSE) { - odds <- probs / (1 - probs) - if (log == TRUE) { - odds <- log(odds) + for (index in names(indices)) { + values[index] <- indices[index] } - return(odds) + + # Summary + summary <- as.data.frame(indices) %>% + tibble::rownames_to_column("Index") %>% + rename_("Value" = "indices") %>% + mutate_("Index" = "str_to_upper(Index)") + + # Text + relevant_indices <- summary[summary$Index %in% c("BIC", "DIC", "WAIC", "LOOIC"), ] + text <- paste0(relevant_indices$Index, " = ", insight::format_value(relevant_indices$Value), collapse = ", ") + + output <- list(text = text, summary = summary, values = values, plot = "Not available yet") + class(output) <- c("psychobject", "list") + return(output) } @@ -10116,3 +761,11 @@ probs_to_odds <- function(probs, log = FALSE) { + + + + + + + + diff --git a/R/dprime.R b/R/dprime.R new file mode 100644 index 0000000..d8f3156 --- /dev/null +++ b/R/dprime.R @@ -0,0 +1,138 @@ +#' Dprime (d') and Other Signal Detection Theory indices. +#' +#' Computes Signal Detection Theory indices, including d', beta, A', B''D and c. +#' +#' @param n_hit Number of hits. +#' @param n_fa Number of false alarms. +#' @param n_miss Number of misses. +#' @param n_cr Number of correct rejections. +#' @param n_targets Number of targets (n_hit + n_miss). +#' @param n_distractors Number of distractors (n_fa + n_cr). +#' @param adjusted Should it use the Hautus (1995) adjustments for extreme values. +#' +#' @return Calculates the d', the beta, the A' and the B''D based on the signal detection theory (SRT). See Pallier (2002) for the algorithms. +#' +#' Returns a list containing the following indices: +#' \itemize{ +#' \item{\strong{dprime (d')}: }{The sensitivity. Reflects the distance between the two distributions: signal, and signal+noise and corresponds to the Z value of the hit-rate minus that of the false-alarm rate.} +#' \item{\strong{beta}: }{The bias (criterion). The value for beta is the ratio of the normal density functions at the criterion of the Z values used in the computation of d'. This reflects an observer's bias to say 'yes' or 'no' with the unbiased observer having a value around 1.0. As the bias to say 'yes' increases (liberal), resulting in a higher hit-rate and false-alarm-rate, beta approaches 0.0. As the bias to say 'no' increases (conservative), resulting in a lower hit-rate and false-alarm rate, beta increases over 1.0 on an open-ended scale.} +#' \item{\strong{c}: }{Another index of bias. the number of standard deviations from the midpoint between these two distributions, i.e., a measure on a continuum from "conservative" to "liberal".} +#' \item{\strong{aprime (A')}: }{Non-parametric estimate of discriminability. An A' near 1.0 indicates good discriminability, while a value near 0.5 means chance performance.} +#' \item{\strong{bppd (B''D)}: }{Non-parametric estimate of bias. A B''D equal to 0.0 indicates no bias, positive numbers represent conservative bias (i.e., a tendency to answer 'no'), negative numbers represent liberal bias (i.e. a tendency to answer 'yes'). The maximum absolute value is 1.0.} +#' } +#' +#' +#' Note that for d' and beta, adjustement for extreme values are made following the recommandations of Hautus (1995). +#' +#' @examples +#' library(psycho) +#' +#' n_hit <- 9 +#' n_fa <- 2 +#' n_miss <- 1 +#' n_cr <- 7 +#' +#' indices <- psycho::dprime(n_hit, n_fa, n_miss, n_cr) +#' +#' +#' df <- data.frame( +#' Participant = c("A", "B", "C"), +#' n_hit = c(1, 2, 5), +#' n_fa = c(6, 8, 1) +#' ) +#' +#' indices <- psycho::dprime( +#' n_hit = df$n_hit, +#' n_fa = df$n_fa, +#' n_targets = 10, +#' n_distractors = 10, +#' adjusted = FALSE +#' ) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats qnorm +#' @export +dprime <- function(n_hit, n_fa, n_miss = NULL, n_cr = NULL, n_targets = NULL, n_distractors = NULL, adjusted = TRUE) { + + # Initialize + if (is.null(n_targets)) { + n_targets <- n_hit + n_miss + } + + if (is.null(n_distractors)) { + n_distractors <- n_fa + n_cr + } + + + + # Parametric Indices ------------------------------------------------------ + + + if (adjusted == TRUE) { + if (is.null(n_miss) | is.null(n_cr)) { + warning("Please provide n_miss and n_cr in order to compute adjusted ratios. Computing indices anyway with non-adjusted ratios...") + + # Non-Adjusted ratios + hit_rate_adjusted <- n_hit / n_targets + fa_rate_adjusted <- n_fa / n_distractors + } else { + # Adjusted ratios + hit_rate_adjusted <- (n_hit + 0.5)/(n_hit + n_miss + 1) + fa_rate_adjusted <- (n_fa + 0.5)/(n_fa + n_cr + 1) + } + + # dprime + dprime <- qnorm(hit_rate_adjusted) - qnorm(fa_rate_adjusted) + + # beta + zhr <- qnorm(hit_rate_adjusted) + zfar <- qnorm(fa_rate_adjusted) + beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) + + # c + c <- -(qnorm(hit_rate_adjusted) + qnorm(fa_rate_adjusted)) / 2 + } else { + # Ratios + hit_rate <- n_hit / n_targets + fa_rate <- n_fa / n_distractors + + # dprime + dprime <- qnorm(hit_rate) - qnorm(fa_rate) + + # beta + zhr <- qnorm(hit_rate) + zfar <- qnorm(fa_rate) + beta <- exp(-zhr * zhr / 2 + zfar * zfar / 2) + + # c + c <- -(qnorm(hit_rate) + qnorm(fa_rate)) / 2 + } + + # Non-Parametric Indices ------------------------------------------------------ + + if(any(n_distractors == 0)){ + warning("Oops, it seems like tehre are observations with 0 distractors. It's impossible to compute non-parametric indices :(") + return(list(dprime = dprime, beta = beta, aprime = NA, bppd = NA, c = c)) + } + + # Ratios + hit_rate <- n_hit / n_targets + fa_rate <- n_fa / n_distractors + + # aprime + a <- 1 / 2 + ((hit_rate - fa_rate) * (1 + hit_rate - fa_rate) / (4 * hit_rate * (1 - fa_rate))) + b <- 1 / 2 - ((fa_rate - hit_rate) * (1 + fa_rate - hit_rate) / (4 * fa_rate * (1 - hit_rate))) + + a[fa_rate > hit_rate] <- b[fa_rate > hit_rate] + a[fa_rate == hit_rate] <- .5 + aprime <- a + + # bppd + bppd <- (hit_rate * (1 - hit_rate) - fa_rate * (1 - fa_rate)) / (hit_rate * (1 - hit_rate) + fa_rate * (1 - fa_rate)) + bppd_b <- (fa_rate * (1 - fa_rate) - hit_rate * (1 - hit_rate)) / (fa_rate * (1 - fa_rate) + hit_rate * (1 - hit_rate)) + bppd[fa_rate > hit_rate] <- bppd_b[fa_rate > hit_rate] + + + + list(dprime = dprime, beta = beta, aprime = aprime, bppd = bppd, c = c) +} diff --git a/R/interpret_posterior.R b/R/interpret_posterior.R new file mode 100644 index 0000000..6f4d308 --- /dev/null +++ b/R/interpret_posterior.R @@ -0,0 +1,119 @@ + + +#' R2 interpreation for a posterior distribution. +#' +#' Interpret R2 with a set of rules. +#' +#' @param posterior Distribution of R2. +#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. +#' +#' @examples +#' library(psycho) +#' posterior <- rnorm(1000, 0.4, 0.1) +#' interpret_R2_posterior(posterior) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' @importFrom stats na.omit +#' @importFrom utils head tail +#' @export +interpret_R2_posterior <- function(posterior, rules = "cohen1988") { + interpretation <- sapply(posterior, .interpret_R2, rules = rules) + rules <- unlist(interpretation[, 1]$rules) + interpretation <- as.data.frame(unlist(interpretation[1, ])) + interpretation <- na.omit(interpretation) + names(interpretation) <- "Interpretation" + + summary <- interpretation %>% + group_by_("Interpretation") %>% + summarise_("Probability" = "n() / length(posterior)") + + values <- list() + for (value in names(sort(rules, decreasing = TRUE))) { + if (value %in% summary$Interpretation) { + values[value] <- summary[summary$Interpretation == value, ]$Probability + } else { + values[value] <- 0 + } + } + + # Text + if (length(summary$Interpretation) > 1) { + text_strength <- paste0(paste0(head(summary$Interpretation, -1), collapse = ", "), " or ", tail(summary$Interpretation, 1)) + text_effects <- paste0( + paste0(paste0(insight::format_value(head(summary$Probability * 100, -1)), "%"), collapse = ", "), + " and ", + paste0(insight::format_value(tail(summary$Probability, 1) * 100), "%") + ) + + text <- paste0( + "The R2 can be considered as ", + text_strength, + " with respective probabilities of ", + text_effects, + "." + ) + } else { + text_sizes <- summary$Interpretation + text_effects <- paste0(insight::format_value(summary$Probability * 100), "%") + + text <- paste0( + "The R2 can be considered as ", + text_sizes, + " with a probability of ", + text_effects, + "." + ) + } + + + plot <- "Not available." + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + + return(output) +} + + +#' @keywords internal +.interpret_R2 <- function(x, rules = "cohen1988", return_rules = TRUE) { + if (!is.list(rules)) { + if (rules == "cohen1988") { + rules <- list( + "very small" = 0, + "small" = 0.02, + "medium" = 0.13, + "large" = 0.26 + ) + } else if (rules == "chin1998") { + rules <- list( + "very small" = 0, + "small" = 0.19, + "medium" = 0.33, + "large" = 0.67 + ) + } else if (rules == "hair2013") { + rules <- list( + "very small" = 0, + "small" = 0.25, + "medium" = 0.50, + "large" = 0.75 + ) + } else { + stop("rules must be either a list or 'cohen1988', 'chin1998' or 'hair2013'.") + } + } + + x <- (x - unlist(rules)) + interpretation <- names(which.min(x[x >= 0])) + if (is.null(interpretation)) { + interpretation <- NA + } + + if (return_rules) { + return(list(interpretation = interpretation, rules = rules)) + } else { + return(interpretation) + } +} + + diff --git a/R/mellenbergh.test.R b/R/mellenbergh.test.R new file mode 100644 index 0000000..8836d1f --- /dev/null +++ b/R/mellenbergh.test.R @@ -0,0 +1,83 @@ +#' Mellenbergh & van den Brink (1998) test for pre-post comparison. +#' +#' Test for comparing post-test to baseline for a single participant. +#' +#' @param t0 Single value (pretest or baseline score). +#' @param t1 Single value (posttest score). +#' @param controls Vector of scores of the control group OR single value corresponding to the control SD of the score. +#' +#' @return Returns a data frame containing the z-value and p-value. If significant, the difference between pre and post tests is significant. +#' +#' @examples +#' library(psycho) +#' +#' mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) +#' mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) +#' @author Dominique Makowski +#' +#' @importFrom stats pnorm sd +#' @export +mellenbergh.test <- function(t0, t1, controls) { + if (length(controls) > 1) { + sd <- sd(controls) * sqrt(2) + } else { + sd <- controls * sqrt(2) + } + + diff <- t1 - t0 + + diff_CI_bottom <- diff - 1.65 * sd + diff_CI_top <- diff + 1.65 * sd + + z <- diff / sd + pval <- 2 * pnorm(-abs(z)) + + # One-tailed p value + if (pval > .05 & pval / 2 < .05) { + one_tailed <- paste0( + " However, the null hypothesis of no change can be rejected at a one-tailed 5% significance level (one-tailed p ", + parameters::format_p(pval / 2), + ")." + ) + } else { + one_tailed <- "" + } + + + + p_interpretation <- ifelse(pval < 0.05, " ", " not ") + text <- paste0( + "The Mellenbergh & van den Brink (1998) test suggests that the change is", + p_interpretation, + "significant (d = ", + insight::format_value(diff), + ", 90% CI [", + insight::format_value(diff_CI_bottom), + ", ", + insight::format_value(diff_CI_top), + "], z = ", + insight::format_value(z), + ", p ", + parameters::format_p(pval), + ").", + one_tailed + ) + + + values <- list( + text = text, + diff = diff, + diff_90_CI_lower = diff_CI_bottom, + diff_90_CI_higher = diff_CI_top, + z = z, + p = pval + ) + summary <- data.frame(diff = diff, diff_90_CI_lower = diff_CI_bottom, diff_90_CI_higher = diff_CI_top, z = z, p = pval) + plot <- "Not available yet" + + + output <- list(text = text, plot = plot, summary = summary, values = values) + class(output) <- c("psychobject", "list") + return(output) + # return("The method for no-controls is not implemented yet.") +} diff --git a/R/miscellaneous.R b/R/miscellaneous.R new file mode 100644 index 0000000..6ef70da --- /dev/null +++ b/R/miscellaneous.R @@ -0,0 +1,418 @@ + +#' Check if a dataframe is standardized. +#' +#' Check if a dataframe is standardized. +#' +#' @param df A dataframe. +#' @param tol The error treshold. +#' +#' @examples +#' library(psycho) +#' library(effectsize) +#' +#' df <- psycho::affective +#' is.standardized(df) +#' +#' dfZ <- effectsize::standardize(df) +#' is.standardized(dfZ) +#' @return bool. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import purrr +#' @export +is.standardized <- function(df, tol = 0.1) { + dfZ <- effectsize::standardize(df) + dfZnum <- purrr::keep(dfZ, is.numeric) + + dfnum <- purrr::keep(df, is.numeric) + + error <- as.matrix(dfnum) - as.matrix(dfZnum) + error <- as.data.frame(error) + names(error) <- names(dfnum) + + error_mean <- error %>% + summarise_all(mean) + + if (TRUE %in% as.character(error_mean[1, ] > tol)) { + standardized <- FALSE + } else { + standardized <- TRUE + } + return(standardized) +} + + + + + + + + + +#' Model to Prior. +#' +#' Convert a Bayesian model's results to priors. +#' +#' @param fit A stanreg model. +#' @param autoscale Set autoscale. +#' @examples +#' \dontrun{ +#' library(rstanarm) +#' library(psycho) +#' +#' fit <- stan_glm(Sepal.Length ~ Petal.Width, data = iris) +#' priors <- model_to_priors(fit) +#' update(fit, prior = priors$prior) +#' +#' fit <- stan_glmer(Subjective_Valence ~ Emotion_Condition + (1 | Participant_ID), +#' data = psycho::emotion +#' ) +#' priors <- model_to_priors(fit) +#' +#' fit1 <- stan_glm(Subjective_Valence ~ Emotion_Condition, +#' data = filter(psycho::emotion, Participant_ID == "1S") +#' ) +#' +#' fit2 <- stan_glm(Subjective_Valence ~ Emotion_Condition, +#' data = filter(psycho::emotion, Participant_ID == "1S"), +#' prior = priors$prior, prior_intercept = priors$prior_intercept +#' ) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @import dplyr +#' @importFrom stats update +#' @importFrom rstanarm normal +#' @export +model_to_priors <- function(fit, autoscale = FALSE) { + posteriors <- as.data.frame(fit) + + # Varnames + varnames <- names(posteriors) + varnames <- varnames[grepl("b\\[", varnames) == FALSE] + + fixed_effects <- names(fit$coefficients) + fixed_effects <- fixed_effects[grepl("b\\[", fixed_effects) == FALSE] + fixed_effects <- fixed_effects[fixed_effects != "(Intercept)"] + + # Get priors + prior_intercept <- list() + priors <- list() + prior_aux <- list() + for (prior in varnames) { + if (prior == "(Intercept)") { + prior_intercept$mean <- mean(posteriors[[prior]]) + prior_intercept$sd <- sd(posteriors[[prior]]) + } else if (prior %in% fixed_effects) { + priors[[prior]] <- list() + priors[[prior]]$mean <- mean(posteriors[[prior]]) + priors[[prior]]$sd <- sd(posteriors[[prior]]) + } else { + prior_aux[[prior]] <- list() + prior_aux[[prior]]$mean <- mean(posteriors[[prior]]) + prior_aux[[prior]]$sd <- sd(posteriors[[prior]]) + } + } + + + prior_intercept <- rstanarm::normal( + prior_intercept$mean, + prior_intercept$sd, + autoscale = autoscale + ) + prior <- .format_priors(priors, autoscale = autoscale) + prior_aux <- .format_priors(prior_aux, autoscale = autoscale) + + return(list(prior_intercept = prior_intercept, prior = prior, priox_aux = prior_aux)) +} + + +#' @keywords internal +.format_priors <- function(priors, autoscale = FALSE) { + prior_mean <- data.frame(priors) %>% + select(contains("mean")) %>% + tidyr::gather() %>% + select_("value") %>% + pull() + + prior_sd <- data.frame(priors) %>% + select(contains("sd")) %>% + tidyr::gather() %>% + select_("value") %>% + pull() + + prior <- rstanarm::normal( + prior_mean, + prior_sd, + autoscale = autoscale + ) +} + + + + + + + + + + + + +#' Transform z score to percentile. +#' +#' @param z_score Z score. +#' +#' @examples +#' library(psycho) +#' percentile(-1.96) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats pnorm +#' @export +percentile <- function(z_score) { + perc <- pnorm(z_score) * 100 + return(perc) +} + + + +#' Transform a percentile to a z score. +#' +#' @param percentile Percentile +#' +#' @examples +#' library(psycho) +#' percentile_to_z(95) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats pnorm +#' @export +percentile_to_z <- function(percentile) { + z <- qnorm(percentile / 100) + return(z) +} + + + + + + + + + +#' Power analysis for fitted models. +#' +#' Compute the n models based on n sampling of data. +#' +#' @param fit A lm or stanreg model. +#' @param n_max Max sample size. +#' @param n_min Min sample size. If null, take current nrow. +#' @param step Increment of the sequence. +#' @param n_batch Number of iterations at each sample size. +#' @param groups Grouping variable name (string) to preserve proportions. Can be a list of strings. +#' @param verbose Print progress. +#' @param CI Confidence level. +#' +#' @return A dataframe containing the summary of all models for all iterations. +#' +#' @examples +#' \dontrun{ +#' library(dplyr) +#' library(psycho) +#' +#' fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) +#' +#' results <- power_analysis(fit, n_max = 300, n_min = 100, step = 5, n_batch = 20) +#' +#' results %>% +#' filter(Variable == "Sepal.Width") %>% +#' select(n, p) %>% +#' group_by(n) %>% +#' summarise( +#' p_median = median(p), +#' p_mad = mad(p) +#' ) +#' } +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @importFrom stats model.frame +#' @import dplyr +#' @export +power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, groups = NULL, verbose = TRUE, CI = 90) { + + # Parameters + df <- model.frame(fit) + + if (is.null(n_min)) { + n_min <- nrow(df) + } + + + results <- data.frame() + for (n in seq(n_min, n_max, step)) { + for (batch in 1:n_batch) { + + # Progress + if (verbose == TRUE) { + cat(".") + } + + + # Sample data.frame + if (!is.null(groups)) { + newdf <- df %>% + group_by_(groups) %>% + dplyr::sample_frac(n / nrow(df), replace = TRUE) + } else { + newdf <- dplyr::sample_frac(df, n / nrow(df), replace = TRUE) + } + + # Fit new model + newfit <- update(fit, data = newdf) + newresults <- parameters::model_parameters(newfit, ci = CI / 100) + + # Store results + newresults$n <- n + newresults$batch <- batch + results <- rbind(results, newresults) + } + # Progress + if (verbose == TRUE) { + cat(paste0(format_digit(round((n - n_min) / (n_max - n_min) * 100)), "%\n")) + } + } + return(results) +} + + + + + + + + + + + + + + + + + + +#' Golden Ratio. +#' +#' Returns the golden ratio (1.618034...). +#' +#' @param x A number to be multiplied by the golden ratio. The default (x=1) returns the value of the golden ratio. +#' +#' @examples +#' library(psycho) +#' +#' golden() +#' golden(8) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +golden <- function(x = 1) { + return(x * (1 + sqrt(5)) / 2) +} + + + + + + + + + +#' Find season of dates. +#' +#' Returns the season of an array of dates. +#' +#' @param dates Array of dates. +#' @param winter month-day of winter solstice. +#' @param spring month-day of spring equinox. +#' @param summer month-day of summer solstice. +#' @param fall month-day of fall equinox. +#' +#' @return season +#' +#' @examples +#' library(psycho) +#' +#' dates <- c("2012-02-15", "2017-05-15", "2009-08-15", "1912-11-15") +#' find_season(dates) +#' @author Josh O'Brien +#' +#' @seealso +#' https://stackoverflow.com/questions/9500114/find-which-season-a-particular-date-belongs-to +#' +#' @export +find_season <- function(dates, winter = "12-21", spring = "3-20", summer = "6-21", fall = "9-22") { + WS <- as.Date(paste0("2012-", winter), format = "%Y-%m-%d") # Winter Solstice + SE <- as.Date(paste0("2012-", spring), format = "%Y-%m-%d") # Spring Equinox + SS <- as.Date(paste0("2012-", summer), format = "%Y-%m-%d") # Summer Solstice + FE <- as.Date(paste0("2012-", fall), format = "%Y-%m-%d") # Fall Equinox + + # Convert dates from any year to 2012 dates + d <- as.Date(strftime(as.character(dates), format = "2012-%m-%d")) + + season <- ifelse(d >= WS | d < SE, "Winter", + ifelse(d >= SE & d < SS, "Spring", + ifelse(d >= SS & d < FE, "Summer", "Fall") + ) + ) + season +} + + + + + + + + +#' Fuzzy string matching. +#' +#' @param x Strings. +#' @param y List of strings to be matched. +#' @param value Return value or the index of the closest string. +#' @param step Step by which decrease the distance. +#' @param ignore.case if FALSE, the pattern matching is case sensitive and if TRUE, case is ignored during matching. +#' +#' @examples +#' library(psycho) +#' find_matching_string("Hwo rea ouy", c("How are you", "Not this word", "Nice to meet you")) +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +find_matching_string <- function(x, y, value = TRUE, step = 0.1, ignore.case = TRUE) { + z <- c() + for (i in seq_len(length(x))) { + s <- x[i] + distance <- 0.99 + closest <- agrep(s, y, max.distance = distance, value = value, ignore.case = ignore.case) + + while (length(closest) != 1) { + closest <- agrep(s, closest, max.distance = distance, value = value, ignore.case = ignore.case) + distance <- distance - step + if (distance < 0) { + warning(paste0("Couldn't find matching string for '", s, "'. Try lowering the step parameter.")) + closest <- s + } + } + z <- c(z, closest) + } + z +} + + + + + diff --git a/R/psychobject.R b/R/psychobject.R new file mode 100644 index 0000000..8858d44 --- /dev/null +++ b/R/psychobject.R @@ -0,0 +1,76 @@ + +#' Plot the results. +#' +#' @param x A psychobject class object. +#' @param ... Arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +plot.psychobject <- function(x, ...) { + plot <- x$plot + return(plot) +} + + +#' Print the results. +#' +#' @param x A psychobject class object. +#' @param ... Further arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +print.psychobject <- function(x, ...) { + text <- x$text + cat(text, sep = "\n") + invisible(text) +} + + + + + + +#' Print the results. +#' +#' Print the results. +#' +#' @param object A psychobject class object. +#' @param round Round the ouput. +#' @param ... Further arguments passed to or from other methods. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @method summary psychobject +#' @export +summary.psychobject <- function(object, round = NULL, ...) { + summary <- object$summary + + if (!is.null(round)) { + nums <- dplyr::select_if(summary, is.numeric) + nums <- round(nums, round) + fact <- dplyr::select_if(summary, is.character) + fact <- cbind(fact, dplyr::select_if(summary, is.factor)) + summary <- cbind(fact, nums) + } + + return(summary) +} + + + + + + +#' Extract values as list. +#' +#' @param x A psychobject class object. +#' +#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} +#' +#' @export +values <- function(x) { + values <- x$values + return(values) +} diff --git a/R/startup_message.R b/R/startup_message.R index 3b8a37d..613a53c 100644 --- a/R/startup_message.R +++ b/R/startup_message.R @@ -1,3 +1,3 @@ .onAttach <- function(libname, pkgname) { - packageStartupMessage("message: psycho's `analyze()` is deprecated in favour of the report package. Check it out at https://github.com/easystats/report") + packageStartupMessage("message: Many functions of the psycho package have been (improved and) moved to other packages of the new 'easystats' collection (https://github.com/easystats). If you don't find where a function is gone, please open an issue at: https://github.com/easystats/easystats/issues") } diff --git a/man/HDImax.Rd b/man/HDImax.Rd deleted file mode 100644 index eb2a78b..0000000 --- a/man/HDImax.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{HDImax} -\alias{HDImax} -\title{Highest Density Intervals (HDI)} -\usage{ -HDImax(x, prob = 0.95) -} -\arguments{ -\item{x}{A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling).} - -\item{prob}{Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated.} -} -\description{ -See \link[=HDI]{HDI} -} diff --git a/man/HDImin.Rd b/man/HDImin.Rd deleted file mode 100644 index 52e2c15..0000000 --- a/man/HDImin.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{HDImin} -\alias{HDImin} -\title{Highest Density Intervals (HDI)} -\usage{ -HDImin(x, prob = 0.95) -} -\arguments{ -\item{x}{A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling).} - -\item{prob}{Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated.} -} -\description{ -See \link[=HDI]{HDI} -} diff --git a/man/R2_LOO_Adjusted.Rd b/man/R2_LOO_Adjusted.Rd deleted file mode 100644 index e7d5e56..0000000 --- a/man/R2_LOO_Adjusted.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{R2_LOO_Adjusted} -\alias{R2_LOO_Adjusted} -\title{Compute LOO-adjusted R2.} -\usage{ -R2_LOO_Adjusted(fit) -} -\arguments{ -\item{fit}{A stanreg model.} -} -\description{ -Compute LOO-adjusted R2. -} -\examples{ -\dontrun{ -library(psycho) -library(rstanarm) - -data <- attitude -fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) - -R2_LOO_Adjusted(fit) -} - -} -\author{ -\href{https://github.com/strengejacke}{Daniel Luedecke} -} diff --git a/man/R2_nakagawa.Rd b/man/R2_nakagawa.Rd deleted file mode 100644 index db8a858..0000000 --- a/man/R2_nakagawa.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{R2_nakagawa} -\alias{R2_nakagawa} -\title{Pseudo-R-squared for Generalized Mixed-Effect models.} -\usage{ -R2_nakagawa(fit) -} -\arguments{ -\item{fit}{A mixed model.} -} -\description{ -For mixed-effects models, R² can be categorized into two types. Marginal R_GLMM² represents the variance explained by fixed factors, and Conditional R_GLMM² is interpreted as variance explained by both fixed and random factors (i.e. the entire model). IMPORTANT: Looking for help to reimplement this method. -} -\examples{ -\dontrun{ -library(psycho) - -fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) - -R2_nakagawa(fit) -} - -} -\references{ -Nakagawa, S., Johnson, P. C., & Schielzeth, H. (2017). The coefficient of determination R2 and intra-class correlation coefficient from generalized linear mixed-effects models revisited and expanded. Journal of the Royal Society Interface, 14(134), 20170213. -Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/R2_tjur.Rd b/man/R2_tjur.Rd deleted file mode 100644 index c6acaad..0000000 --- a/man/R2_tjur.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{R2_tjur} -\alias{R2_tjur} -\title{Tjur's (2009) coefficient of determination.} -\usage{ -R2_tjur(fit) -} -\arguments{ -\item{fit}{Logistic Model.} -} -\description{ -Computes Tjur's (2009) coefficient of determination. -} -\examples{ -library(psycho) -library(lme4) - -fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -R2_tjur(fit) -} -\references{ -Tjur, T. (2009). Coefficients of determination in logistic regression models—A new proposal: The coefficient of discrimination. The American Statistician, 63(4), 366-372. -} -\author{ -\href{https://github.com/strengejacke}{Daniel Lüdecke} -} diff --git a/man/analyze.Rd b/man/analyze.Rd deleted file mode 100644 index 6fafb94..0000000 --- a/man/analyze.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze} -\alias{analyze} -\title{Analyze objects.} -\usage{ -analyze(x, ...) -} -\arguments{ -\item{x}{object to analyze.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Analyze objects. See the documentation for your object's class: -\itemize{ - \item{\link[=analyze.stanreg]{analyze.stanreg}} - \item{\link[=analyze.lmerModLmerTest]{analyze.merModLmerTest}} - \item{\link[=analyze.glmerMod]{analyze.glmerMod}} - \item{\link[=analyze.lm]{analyze.lm}} - \item{\link[=analyze.glm]{analyze.glm}} - } - \itemize{ - \item{\link[=analyze.htest]{analyze.htest}} - \item{\link[=analyze.aov]{analyze.aov}} - } -\itemize{ - \item{\link[=analyze.fa]{analyze.fa}} - \item{\link[=analyze.principal]{analyze.principal}} - \item{\link[=analyze.lavaan]{analyze.lavaan}} - \item{\link[=analyze.blavaan]{analyze.blavaan}} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.aov.Rd b/man/analyze.aov.Rd deleted file mode 100644 index 47b2447..0000000 --- a/man/analyze.aov.Rd +++ /dev/null @@ -1,60 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.aov} -\alias{analyze.aov} -\title{Analyze aov and anova objects} -\usage{ -\method{analyze}{aov}(x, effsize_rules = "field2013", ...) -} -\arguments{ -\item{x}{aov object.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_omega_sq]{interpret_omega_sq}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze aov and anova objects. -} -\examples{ -\dontrun{ -library(psycho) - -df <- psycho::affective - -x <- aov(df$Tolerating ~ df$Salary) -x <- aov(df$Tolerating ~ df$Salary * df$Sex) - -x <- anova(lm(df$Tolerating ~ df$Salary * df$Sex)) - - -summary(analyze(x)) -print(analyze(x)) - -df <- psycho::emotion \%>\% - mutate(Recall = ifelse(Recall == TRUE, 1, 0)) \%>\% - group_by(Participant_ID, Emotion_Condition) \%>\% - summarise(Recall = sum(Recall) / n()) - -x <- aov(Recall ~ Emotion_Condition + Error(Participant_ID), data = df) -x <- anova(lmerTest::lmer(Recall ~ Emotion_Condition + (1 | Participant_ID), data = df)) -analyze(x) -summary(x) -} - -} -\references{ -\itemize{ - \item{Levine, T. R., & Hullett, C. R. (2002). Eta squared, partial eta squared, and misreporting of effect size in communication research. Human Communication Research, 28(4), 612-625.} - \item{Pierce, C. A., Block, R. A., & Aguinis, H. (2004). Cautionary note on reporting eta-squared values from multifactor ANOVA designs. Educational and psychological measurement, 64(6), 916-924.} -} -} -\seealso{ -http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/os2 -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.blavaan.Rd b/man/analyze.blavaan.Rd deleted file mode 100644 index 3d4710c..0000000 --- a/man/analyze.blavaan.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.blavaan} -\alias{analyze.blavaan} -\title{Analyze blavaan (SEM or CFA) objects.} -\usage{ -\method{analyze}{blavaan}(x, CI = 90, standardize = FALSE, ...) -} -\arguments{ -\item{x}{lavaan object.} - -\item{CI}{Credible interval level.} - -\item{standardize}{Compute standardized coefs.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze blavaan (SEM or CFA) objects. -} -\examples{ -library(psycho) -library(lavaan) - -model <- " visual =~ x1 + x2 + x3\\ntextual =~ x4 + x5 + x6\\nspeed =~ x7 + x8 + x9 " -x <- lavaan::cfa(model, data = HolzingerSwineford1939) - -rez <- analyze(x) -print(rez) -} -\seealso{ -https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.fa.Rd b/man/analyze.fa.Rd deleted file mode 100644 index 4109828..0000000 --- a/man/analyze.fa.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.fa} -\alias{analyze.fa} -\title{Analyze fa objects.} -\usage{ -\method{analyze}{fa}(x, labels = NULL, treshold = "max", ...) -} -\arguments{ -\item{x}{An psych object.} - -\item{labels}{Supply a additional column with e.g. item labels.} - -\item{treshold}{'max' or numeric. The treshold over which to associate an item with its component.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze fa objects. -} -\examples{ -library(psycho) -library(psych) - -x <- psych::fa(psych::Thurstone.33, 2) - -results <- analyze(x) -print(results) -summary(results) - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.glm.Rd b/man/analyze.glm.Rd deleted file mode 100644 index e813715..0000000 --- a/man/analyze.glm.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.glm} -\alias{analyze.glm} -\title{Analyze glm objects.} -\usage{ -\method{analyze}{glm}(x, CI = 95, effsize_rules = "cohen1988", ...) -} -\arguments{ -\item{x}{glm object.} - -\item{CI}{Confidence interval bounds. Set to NULL turn off their computation.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze glm objects. -} -\examples{ -library(psycho) -fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") - -results <- analyze(fit) -summary(results) -print(results) -} -\references{ -Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -} -\seealso{ -\link[=get_R2.glm]{"get_R2.glm"} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.glmerMod.Rd b/man/analyze.glmerMod.Rd deleted file mode 100644 index 71a11ac..0000000 --- a/man/analyze.glmerMod.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.glmerMod} -\alias{analyze.glmerMod} -\title{Analyze glmerMod objects.} -\usage{ -\method{analyze}{glmerMod}(x, CI = 95, effsize_rules = "cohen1988", - ...) -} -\arguments{ -\item{x}{merModLmerTest object.} - -\item{CI}{Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_odds]{interpret_odds}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze glmerMod objects. -} -\examples{ -\dontrun{ -library(psycho) -library(lme4) - -fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") - -results <- analyze(fit) -summary(results) -print(results) -} - -} -\references{ -Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.htest.Rd b/man/analyze.htest.Rd deleted file mode 100644 index a585568..0000000 --- a/man/analyze.htest.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.htest} -\alias{analyze.htest} -\title{Analyze htest (correlation, t-test...) objects.} -\usage{ -\method{analyze}{htest}(x, effsize_rules = "cohen1988", ...) -} -\arguments{ -\item{x}{htest object.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze htest (correlation, t-test...) objects. -} -\examples{ -library(psycho) - -df <- psycho::affective - -x <- t.test(df$Tolerating, df$Adjusting) -x <- t.test(df$Tolerating ~ df$Sex) -x <- t.test(df$Tolerating, mu = 2) -x <- cor.test(df$Tolerating, df$Adjusting) - -results <- analyze(x) -summary(results) -print(results) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.lavaan.Rd b/man/analyze.lavaan.Rd deleted file mode 100644 index c368f19..0000000 --- a/man/analyze.lavaan.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.lavaan} -\alias{analyze.lavaan} -\title{Analyze lavaan SEM or CFA) objects.} -\usage{ -\method{analyze}{lavaan}(x, CI = 95, standardize = FALSE, ...) -} -\arguments{ -\item{x}{lavaan object.} - -\item{CI}{Confidence interval level.} - -\item{standardize}{Compute standardized coefs.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze lavaan (SEM or CFA) objects. -} -\examples{ -library(psycho) -library(lavaan) - -model <- " visual =~ x1 + x2 + x3\\ntextual =~ x4 + x5 + x6\\nspeed =~ x7 + x8 + x9 " -x <- lavaan::cfa(model, data = HolzingerSwineford1939) - -rez <- analyze(x) -print(rez) -} -\seealso{ -https://www.researchgate.net/post/Whats_the_standard_of_fit_indices_in_SEM -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.lm.Rd b/man/analyze.lm.Rd deleted file mode 100644 index 376a077..0000000 --- a/man/analyze.lm.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.lm} -\alias{analyze.lm} -\title{Analyze lm objects.} -\usage{ -\method{analyze}{lm}(x, CI = 95, effsize_rules = "cohen1988", ...) -} -\arguments{ -\item{x}{lm object.} - -\item{CI}{Confidence interval bounds. Set to NULL turn off their computation.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze lm objects. -} -\examples{ -library(psycho) -fit <- lm(Sepal.Length ~ Sepal.Width, data = iris) -fit <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris) - -results <- analyze(fit) -summary(results) -print(results) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.lmerModLmerTest.Rd b/man/analyze.lmerModLmerTest.Rd deleted file mode 100644 index 5b18e3f..0000000 --- a/man/analyze.lmerModLmerTest.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.lmerModLmerTest} -\alias{analyze.lmerModLmerTest} -\title{Analyze lmerModLmerTest objects.} -\usage{ -\method{analyze}{lmerModLmerTest}(x, CI = 95, - effsize_rules = "cohen1988", ...) -} -\arguments{ -\item{x}{lmerModLmerTest object.} - -\item{CI}{Bootsrapped confidence interval bounds (slow). Set to NULL turn off their computation.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze lmerModLmerTest objects. -} -\examples{ -library(psycho) -library(lmerTest) -fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) - -results <- analyze(fit) -summary(results) -print(results) -} -\references{ -Nakagawa, S., & Schielzeth, H. (2013). A general and simple method for obtaining R2 from generalized linear mixed-effects models. Methods in Ecology and Evolution, 4(2), 133-142. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.principal.Rd b/man/analyze.principal.Rd deleted file mode 100644 index 3bf21e2..0000000 --- a/man/analyze.principal.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.principal} -\alias{analyze.principal} -\title{Analyze fa objects.} -\usage{ -\method{analyze}{principal}(x, labels = NULL, treshold = "max", ...) -} -\arguments{ -\item{x}{An psych object.} - -\item{labels}{Supply a additional column with e.g. item labels.} - -\item{treshold}{'max' or numeric. The treshold over which to associate an item with its component.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Analyze fa objects. -} -\examples{ -library(psycho) -library(psych) - -x <- psych::pca(psych::Thurstone.33, 2) - -results <- analyze(x) -print(results) -summary(results) - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/analyze.stanreg.Rd b/man/analyze.stanreg.Rd deleted file mode 100644 index 932a78b..0000000 --- a/man/analyze.stanreg.Rd +++ /dev/null @@ -1,79 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{analyze.stanreg} -\alias{analyze.stanreg} -\title{Analyze stanreg objects.} -\usage{ -\method{analyze}{stanreg}(x, CI = 90, index = "overlap", - ROPE_bounds = NULL, effsize = FALSE, effsize_rules = "cohen1988", - ...) -} -\arguments{ -\item{x}{A stanreg model.} - -\item{CI}{Credible interval bounds.} - -\item{index}{Index of effect existence to report. Can be 'overlap' or 'ROPE'.} - -\item{ROPE_bounds}{Bounds of the ROPE. If NULL and effsize is TRUE, than the ROPE. -will have default values c(-0.1, 0.1) and computed on the standardized posteriors.} - -\item{effsize}{Compute Effect Sizes according to Cohen (1988). For linear models only.} - -\item{effsize_rules}{Grid for effect size interpretation. See \link[=interpret_d]{interpret_d}.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -Contains the following indices: -\itemize{ - \item{the Median of the posterior distribution of the parameter (can be used as a point estimate, similar to the beta of frequentist models).} - \item{the Median Absolute Deviation (MAD), a robust measure of dispertion (could be seen as a robust version of SD).} - \item{the Credible Interval (CI) (by default, the 90\% CI; see Kruschke, 2018), representing a range of possible parameter.} - \item{the Maximum Probability of Effect (MPE), the probability that the effect is positive or negative (depending on the median’s direction).} - \item{the Overlap (O), the percentage of overlap between the posterior distribution and a normal distribution of mean 0 and same SD than the posterior. Can be interpreted as the probability that a value from the posterior distribution comes from a null distribution.} - \item{the ROPE, the proportion of the 95\% CI of the posterior distribution that lies within the region of practical equivalence.} - } -} -\description{ -Analyze stanreg objects. -} -\examples{ -\dontrun{ -library(psycho) -library(rstanarm) - -data <- attitude -fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) - -results <- analyze(fit, effsize = TRUE) -summary(results) -print(results) -plot(results) - - -fit <- rstanarm::stan_lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) -results <- analyze(fit) -summary(results) - -fit <- rstanarm::stan_glm(Sex ~ Adjusting, - data = psycho::affective, family = "binomial" -) -results <- analyze(fit) -summary(results) - -fit <- rstanarm::stan_glmer(Sex ~ Adjusting + (1 | Salary), - data = psycho::affective, family = "binomial" -) -results <- analyze(fit) -summary(results) -} - -} -\seealso{ -\link[=get_R2.stanreg]{"get_R2.stanreg"} -\link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/as.data.frame.density.Rd b/man/as.data.frame.density.Rd deleted file mode 100644 index 53a09e1..0000000 --- a/man/as.data.frame.density.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{as.data.frame.density} -\alias{as.data.frame.density} -\title{Coerce to a Data Frame.} -\usage{ -\method{as.data.frame}{density}(x, ...) -} -\arguments{ -\item{x}{any R object.} - -\item{...}{additional arguments to be passed to or from methods.} -} -\description{ -Functions to check if an object is a data frame, or coerce it if possible. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/assess.Rd b/man/assess.Rd index 6d2b180..68c0ceb 100644 --- a/man/assess.Rd +++ b/man/assess.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/assess.R \name{assess} \alias{assess} \title{Compare a patient's score to a control group} diff --git a/man/bayes_cor.Rd b/man/bayes_cor.Rd deleted file mode 100644 index 5e1c6e8..0000000 --- a/man/bayes_cor.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{bayes_cor} -\alias{bayes_cor} -\title{Bayesian Correlation Matrix.} -\usage{ -bayes_cor(df, df2 = NULL, reorder = TRUE) -} -\arguments{ -\item{df}{The dataframe.} - -\item{df2}{Optional dataframe to correlate with the first one.} - -\item{reorder}{Reorder matrix by correlation strength. Only for square matrices.} -} -\value{ -A list of dataframes -} -\description{ -Bayesian Correlation Matrix. -} -\examples{ -\dontrun{ -library(psycho) - -df <- psycho::affective -cor <- bayes_cor(df) -summary(cor) -print(cor) -plot(cor) - -df <- select(psycho::affective, Adjusting, Tolerating) -df2 <- select(psycho::affective, -Adjusting, -Tolerating) -cor <- bayes_cor(df, df2) -summary(cor) -print(cor) -plot(cor) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/bayes_cor.test.Rd b/man/bayes_cor.test.Rd deleted file mode 100644 index fdba52b..0000000 --- a/man/bayes_cor.test.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{bayes_cor.test} -\alias{bayes_cor.test} -\title{Performs a Bayesian correlation.} -\usage{ -bayes_cor.test(x, y, CI = 90, iterations = 10000, - effsize_rules_r = "cohen1988", effsize_rules_bf = "jeffreys1961") -} -\arguments{ -\item{x}{First continuous variable.} - -\item{y}{Second continuous variable.} - -\item{CI}{Credible interval bounds.} - -\item{iterations}{The number of iterations to sample.} - -\item{effsize_rules_r}{Grid for effect size interpretation. See \link[=interpret_r]{interpret_r}.} - -\item{effsize_rules_bf}{Grid for effect size interpretation. See \link[=interpret_bf]{interpret_bf}.} -} -\value{ -A psychobject. -} -\description{ -Performs a Bayesian correlation. -} -\examples{ -\dontrun{ -library(psycho) -x <- psycho::affective$Concealing -y <- psycho::affective$Tolerating - -bayes_cor.test(x, y) -summary(bayes_cor.test(x, y)) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/cite_packages.Rd b/man/cite_packages.Rd deleted file mode 100644 index b7320d7..0000000 --- a/man/cite_packages.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{cite_packages} -\alias{cite_packages} -\title{Citations of loaded packages.} -\usage{ -cite_packages(session) -} -\arguments{ -\item{session}{A `devtools::sessionInfo()` object.} -} -\description{ -Get the citations of loaded packages. -} -\examples{ -\dontrun{ -library(psycho) -cite_packages(sessionInfo()) -} - -} -\author{ -\href{https://github.com/DominiqueMakowski}{Dominique Makowski} -} diff --git a/man/correlation.Rd b/man/correlation.Rd deleted file mode 100644 index 09d64c3..0000000 --- a/man/correlation.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{correlation} -\alias{correlation} -\title{Multiple Correlations.} -\usage{ -correlation(df, df2 = NULL, type = "full", method = "pearson", - adjust = "holm", i_am_cheating = FALSE) -} -\arguments{ -\item{df}{The dataframe.} - -\item{df2}{Optional dataframe to correlate with the first one.} - -\item{type}{A character string indicating which correlation type is to be -computed. One of "full" (default), "partial" (partial correlations), -"semi" (semi-partial correlations), "glasso" -(Graphical lasso- estimation of Gaussian graphical models) or "cor_auto" -(will use the qgraph::cor_auto function to return pychoric or polyserial -correlations if needed).} - -\item{method}{A character string indicating which correlation coefficient is -to be computed. One of "pearson" (default), "kendall", or "spearman" can be -abbreviated.} - -\item{adjust}{What adjustment for multiple tests should be used? ("holm", -"hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"). See -\link[stats]{p.adjust} for details about why to use "holm" rather than -"bonferroni").} - -\item{i_am_cheating}{Set to TRUE to run many uncorrected correlations.} -} -\value{ -output -} -\description{ -Compute different kinds of correlation matrices. -} -\examples{ -df <- attitude - -# Normal correlations -results <- psycho::correlation(df) -print(results) -plot(results) - -# Partial correlations with correction -results <- psycho::correlation(df, - type = "partial", - method = "spearman", - adjust = "holm" -) -print(results) -plot(results) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/crawford.test.Rd b/man/crawford.test.Rd index 81f8965..717bd8d 100644 --- a/man/crawford.test.Rd +++ b/man/crawford.test.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/crawford.test.R \name{crawford.test} \alias{crawford.test} \title{Crawford-Garthwaite (2007) Bayesian test for single-case analysis.} diff --git a/man/crawford.test.freq.Rd b/man/crawford.test.freq.Rd index 258635f..e20fcdb 100644 --- a/man/crawford.test.freq.Rd +++ b/man/crawford.test.freq.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/crawford.test.R \name{crawford.test.freq} \alias{crawford.test.freq} \title{Crawford-Howell (1998) frequentist t-test for single-case analysis.} diff --git a/man/crawford_dissociation.test.Rd b/man/crawford_dissociation.test.Rd index db2473d..35c3199 100644 --- a/man/crawford_dissociation.test.Rd +++ b/man/crawford_dissociation.test.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/crawford_dissociation.test.R \name{crawford_dissociation.test} \alias{crawford_dissociation.test} \title{Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks.} diff --git a/man/create_intervals.Rd b/man/create_intervals.Rd deleted file mode 100644 index 45678fd..0000000 --- a/man/create_intervals.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{create_intervals} -\alias{create_intervals} -\title{Overlap of Two Empirical Distributions.} -\usage{ -create_intervals(x, n = NULL, length = NULL, equal_range = TRUE, - labels = NULL, dig.lab = 3) -} -\arguments{ -\item{x}{A vector of numerics.} - -\item{n}{Number of intervals to create, OR} - -\item{length}{Length of each interval.} - -\item{equal_range}{Makes n groups with with equal range (TRUE) or (approximately) equal numbers of observations (FALSE).} - -\item{labels}{Can be a custom list, "NULL", "FALSE" or "median".} - -\item{dig.lab}{Integer which is used when labels are not given. It determines the number of digits used in formatting the break numbers.} -} -\description{ -A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). -} -\examples{ -library(psycho) - -x <- rnorm(100, 0, 1) - -create_intervals(x, n = 4) -create_intervals(x, n = 4, equal_range = FALSE) -create_intervals(x, length = 1) - -create_intervals(x, n = 4, labels = "median") -create_intervals(x, n = 4, labels = FALSE) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/dprime.Rd b/man/dprime.Rd index 37cc694..0dfcb30 100644 --- a/man/dprime.Rd +++ b/man/dprime.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/dprime.R \name{dprime} \alias{dprime} -\title{Dprime and Other Signal Detection Theory indices.} +\title{Dprime (d') and Other Signal Detection Theory indices.} \usage{ dprime(n_hit, n_fa, n_miss = NULL, n_cr = NULL, n_targets = NULL, n_distractors = NULL, adjusted = TRUE) @@ -38,7 +38,7 @@ Returns a list containing the following indices: Note that for d' and beta, adjustement for extreme values are made following the recommandations of Hautus (1995). } \description{ -Computes Signal Detection Theory indices (d', beta, A', B''D, c). +Computes Signal Detection Theory indices, including d', beta, A', B''D and c. } \examples{ library(psycho) diff --git a/man/find_best_model.Rd b/man/find_best_model.Rd deleted file mode 100644 index a33defe..0000000 --- a/man/find_best_model.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_best_model} -\alias{find_best_model} -\title{Returns the best model.} -\usage{ -find_best_model(fit, ...) -} -\arguments{ -\item{fit}{Model} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Returns the best model. See the -documentation for your model's class: -\itemize{ - \item{\link[=find_best_model.stanreg]{find_best_model.stanreg}} - \item{\link[=find_best_model.lmerModLmerTest]{find_best_model.lmerModLmerTest}} - } -} -\seealso{ -\code{\link{find_best_model.stanreg}} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_best_model.lavaan.Rd b/man/find_best_model.lavaan.Rd deleted file mode 100644 index 19d55cf..0000000 --- a/man/find_best_model.lavaan.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_best_model.lavaan} -\alias{find_best_model.lavaan} -\title{Returns all combinations of lavaan models with their indices of fit.} -\usage{ -\method{find_best_model}{lavaan}(fit, latent = "", samples = 1000, - verbose = FALSE, ...) -} -\arguments{ -\item{fit}{A lavaan object.} - -\item{latent}{Copy/paste the part related to latent variables loadings.} - -\item{samples}{Number of random draws.} - -\item{verbose}{Show progress.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -list containing all combinations. -} -\description{ -Returns all combinations of lavaan models with their indices of fit. -} -\examples{ -library(psycho) -library(lavaan) - -model <- " visual =~ x1 + x2 + x3 -textual =~ x4 + x5 + x6 -speed =~ x7 + x8 + x9 -visual ~ textual -textual ~ speed" -fit <- lavaan::sem(model, data = HolzingerSwineford1939) - -models <- find_best_model(fit, latent = "visual =~ x1 + x2 + x3 -textual =~ x4 + x5 + x6 -speed =~ x7 + x8 + x9") -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_best_model.lmerModLmerTest.Rd b/man/find_best_model.lmerModLmerTest.Rd deleted file mode 100644 index f728424..0000000 --- a/man/find_best_model.lmerModLmerTest.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_best_model.lmerModLmerTest} -\alias{find_best_model.lmerModLmerTest} -\title{Returns the best combination of predictors for lmerTest objects.} -\usage{ -\method{find_best_model}{lmerModLmerTest}(fit, interaction = TRUE, - fixed = NULL, ...) -} -\arguments{ -\item{fit}{A merModLmerTest object.} - -\item{interaction}{Include interaction term.} - -\item{fixed}{Additional formula part to add at the beginning of -each formula} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -list containing all combinations. -} -\description{ -Returns the best combination of predictors for lmerTest objects. -} -\examples{ -\dontrun{ -library(psycho) -library(lmerTest) - -data <- standardize(iris) -fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = data) - -best <- find_best_model(fit) -best_formula <- best$formula -best$table -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_best_model.stanreg.Rd b/man/find_best_model.stanreg.Rd deleted file mode 100644 index ab23d36..0000000 --- a/man/find_best_model.stanreg.Rd +++ /dev/null @@ -1,55 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_best_model.stanreg} -\alias{find_best_model.stanreg} -\title{Returns the best combination of predictors based on LOO cross-validation indices.} -\usage{ -\method{find_best_model}{stanreg}(fit, interaction = TRUE, - fixed = NULL, K = 10, k_treshold = NULL, ...) -} -\arguments{ -\item{fit}{A stanreg object.} - -\item{interaction}{Include interaction term.} - -\item{fixed}{Additional formula part to add at the beginning of -each formula} - -\item{K}{For kfold, the number of subsets of equal (if possible) size into -which the data will be randomly partitioned for performing K-fold -cross-validation. The model is refit K times, each time leaving out one of -the K subsets. If K is equal to the total number of observations in the data -then K-fold cross-validation is equivalent to exact leave-one-out -cross-validation.} - -\item{k_treshold}{Threshold for flagging estimates of the Pareto shape -parameters k estimated by loo.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -list containing all combinations. -} -\description{ -Returns the best combination of predictors based on LOO cross-validation indices. -} -\examples{ -\dontrun{ -library(psycho) -library(rstanarm) - -data <- standardize(attitude) -fit <- rstanarm::stan_glm(rating ~ advance + privileges, data = data) - -best <- find_best_model(fit) -best_formula <- best$formula -best$table - -# To deactivate Kfold evaluation -best <- find_best_model(fit, K = 0) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_distance_cluster.Rd b/man/find_distance_cluster.Rd deleted file mode 100644 index 8b00443..0000000 --- a/man/find_distance_cluster.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_distance_cluster} -\alias{find_distance_cluster} -\title{Find the distance of a point with its kmean cluster.} -\usage{ -find_distance_cluster(df, km) -} -\arguments{ -\item{df}{Data} - -\item{km}{kmean object.} -} -\description{ -Find the distance of a point with its kmean cluster. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_highest_density_point.Rd b/man/find_highest_density_point.Rd deleted file mode 100644 index c495cb8..0000000 --- a/man/find_highest_density_point.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_highest_density_point} -\alias{find_highest_density_point} -\title{Find the Highest Density Point.} -\usage{ -find_highest_density_point(x, precision = 1000) -} -\arguments{ -\item{x}{Vector.} - -\item{precision}{Number of points in density.} -} -\description{ -Returns the Highest Density Point. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_matching_string.Rd b/man/find_matching_string.Rd index 979121a..7355950 100644 --- a/man/find_matching_string.Rd +++ b/man/find_matching_string.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{find_matching_string} \alias{find_matching_string} \title{Fuzzy string matching.} diff --git a/man/find_random_effects.Rd b/man/find_random_effects.Rd deleted file mode 100644 index 1546667..0000000 --- a/man/find_random_effects.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{find_random_effects} -\alias{find_random_effects} -\title{Find random effects in formula.} -\usage{ -find_random_effects(formula) -} -\arguments{ -\item{formula}{Formula} -} -\description{ -Find random effects in formula. -} -\examples{ -library(psycho) -find_random_effects("Y ~ X + (1|Group)") -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/find_season.Rd b/man/find_season.Rd index 008ba22..024bc1b 100644 --- a/man/find_season.Rd +++ b/man/find_season.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{find_season} \alias{find_season} \title{Find season of dates.} diff --git a/man/format_bf.Rd b/man/format_bf.Rd deleted file mode 100644 index 02ff281..0000000 --- a/man/format_bf.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{format_bf} -\alias{format_bf} -\title{Bayes factor formatting} -\usage{ -format_bf(bf, max = 100) -} -\arguments{ -\item{bf}{Bayes Factor.} - -\item{max}{Treshold for maximum.} -} -\description{ -Bayes factor formatting -} diff --git a/man/format_formula.Rd b/man/format_formula.Rd index 3421128..05912af 100644 --- a/man/format_formula.Rd +++ b/man/format_formula.Rd @@ -18,10 +18,9 @@ Clean and format formula. library(psycho) library(lme4) -fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") fit <- lm(hp ~ wt, data = mtcars) -format_formula(get_formula(fit)) +format_formula(fit$call$formula) } \author{ \href{https://dominiquemakowski.github.io/}{Dominique Makowski} diff --git a/man/format_loadings.Rd b/man/format_loadings.Rd deleted file mode 100644 index 1913d46..0000000 --- a/man/format_loadings.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{format_loadings} -\alias{format_loadings} -\title{Format the loadings of a factor analysis.} -\usage{ -format_loadings(x, labels = NULL) -} -\arguments{ -\item{x}{An psych object.} - -\item{labels}{Supply a additional column with e.g. item labels.} -} -\description{ -Format the loadings of a factor analysis. -} -\examples{ -\dontrun{ -library(psycho) - -x <- psych::fa(psych::Thurstone.33, 2) -format_loadings(x) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/format_p.Rd b/man/format_p.Rd deleted file mode 100644 index cc1c67d..0000000 --- a/man/format_p.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{format_p} -\alias{format_p} -\title{Format p values.} -\usage{ -format_p(pvalues, stars = TRUE, stars_only = FALSE) -} -\arguments{ -\item{pvalues}{p values (scalar or vector).} - -\item{stars}{Add significance stars.} - -\item{stars_only}{Return only significance stars.} -} -\description{ -Format p values. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/format_string.Rd b/man/format_string.Rd deleted file mode 100644 index aa9a889..0000000 --- a/man/format_string.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{format_string} -\alias{format_string} -\title{Tidyverse-friendly sprintf.} -\usage{ -format_string(x, fmt, ...) -} -\arguments{ -\item{x}{Values.} - -\item{fmt}{A character vector of format strings, each of up to 8192 bytes.} - -\item{...}{values to be passed into fmt. Only logical, integer, real and -character vectors are supported, but some coercion will be done: see the ‘Details’ section. Up to 100.} -} -\description{ -Tidyverse-friendly sprintf. -} diff --git a/man/get_R2.Rd b/man/get_R2.Rd deleted file mode 100644 index 697de7b..0000000 --- a/man/get_R2.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_R2} -\alias{get_R2} -\title{Get Indices of Explanatory Power.} -\usage{ -get_R2(fit, ...) -} -\arguments{ -\item{fit}{Object.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -See the documentation for your object's class: -\itemize{ -\item{\link[=get_R2.lm]{get_R2.lm}} -\item{\link[=get_R2.glm]{get_R2.glm}} -\item{\link[=get_R2.stanreg]{get_R2.stanreg}} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_R2.glm.Rd b/man/get_R2.glm.Rd deleted file mode 100644 index f3b716e..0000000 --- a/man/get_R2.glm.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_R2.glm} -\alias{get_R2.glm} -\title{Pseudo-R-squared for Logistic Models.} -\usage{ -\method{get_R2}{glm}(fit, method = "nakagawa", ...) -} -\arguments{ -\item{fit}{A logistic model.} - -\item{method}{Can be \link[=R2_nakagawa]{"nakagawa"} or \link[=R2_tjur]{"tjur"}.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Pseudo-R-squared for Logistic Models. -} -\examples{ -\dontrun{ -library(psycho) - -fit <- glm(vs ~ wt, data = mtcars, family = "binomial") -fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") - -get_R2(fit) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_R2.lm.Rd b/man/get_R2.lm.Rd deleted file mode 100644 index 095ec16..0000000 --- a/man/get_R2.lm.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_R2.lm} -\alias{get_R2.lm} -\title{R2 and adjusted R2 for Linear Models.} -\usage{ -\method{get_R2}{lm}(fit, ...) -} -\arguments{ -\item{fit}{A linear model.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -R2 and adjusted R2 for Linear Models. -} -\examples{ -\dontrun{ -library(psycho) - -fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) - -get_R2(fit) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_R2.merMod.Rd b/man/get_R2.merMod.Rd deleted file mode 100644 index 7ee8622..0000000 --- a/man/get_R2.merMod.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_R2.merMod} -\alias{get_R2.merMod} -\title{R2 and adjusted R2 for GLMMs.} -\usage{ -\method{get_R2}{merMod}(fit, ...) -} -\arguments{ -\item{fit}{A GLMM.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -R2 and adjusted R2 for GLMMs. -} -\examples{ -\dontrun{ -library(psycho) - -fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), - data = psycho::affective -) -fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), - data = na.omit(psycho::affective), family = "binomial" -) - -get_R2(fit) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_R2.stanreg.Rd b/man/get_R2.stanreg.Rd deleted file mode 100644 index d5339a9..0000000 --- a/man/get_R2.stanreg.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_R2.stanreg} -\alias{get_R2.stanreg} -\title{R2 or Bayesian Models.} -\usage{ -\method{get_R2}{stanreg}(fit, silent = FALSE, ...) -} -\arguments{ -\item{fit}{A stanreg model.} - -\item{silent}{If R2 not available, throw warning.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Computes R2 and \link[=R2_LOO_Adjusted]{LOO-adjusted R2}. -} -\examples{ -\dontrun{ -library(psycho) -library(rstanarm) - -fit <- rstanarm::stan_glm(Adjusting ~ Tolerating, data = psycho::affective) - -get_R2(fit) -} - -} -\seealso{ -\link[=bayes_R2.stanreg]{"bayes_R2.stanreg"} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_cfa_model.Rd b/man/get_cfa_model.Rd deleted file mode 100644 index 18afad5..0000000 --- a/man/get_cfa_model.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_cfa_model} -\alias{get_cfa_model} -\title{Get CFA model.} -\usage{ -get_cfa_model(loadings, treshold = "max") -} -\arguments{ -\item{loadings}{Formatted loadings.} - -\item{treshold}{'max' or numeric. The treshold over which to associate an item with its component.} -} -\description{ -Get CFA model. -} -\examples{ -\dontrun{ -library(psycho) - -x <- psych::fa(psych::Thurstone.33, 2) -loadings <- format_loadings(x)$loadings -get_cfa_model(loadings, treshold = "max") -get_cfa_model(loadings, treshold = 0.1) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_contrasts.Rd b/man/get_contrasts.Rd deleted file mode 100644 index 75311bb..0000000 --- a/man/get_contrasts.Rd +++ /dev/null @@ -1,48 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts} -\alias{get_contrasts} -\title{Compute estimated contrasts from models.} -\usage{ -get_contrasts(fit, ...) -} -\arguments{ -\item{fit}{A model.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -Estimated contrasts. -} -\description{ -Compute estimated contrasts between factor levels based on a fitted model. -See the documentation for your model's class: -\itemize{ - \item{\link[=get_contrasts.glm]{get_contrasts.glm}} - \item{\link[=get_contrasts.lmerModLmerTest]{get_contrasts.merModLmerTest}} - \item{\link[=get_contrasts.glmerMod]{get_contrasts.glmerMod}} - \item{\link[=get_contrasts.stanreg]{get_contrasts.stanreg}} - } -} -\examples{ -\dontrun{ -library(psycho) -require(lmerTest) -require(rstanarm) - -fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) -get_contrasts(fit) - -fit <- lm(Adjusting ~ Birth_Season * Salary, data = affective) -get_contrasts(fit, adjust = "bonf") - -fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) -get_contrasts(fit, formula = "Birth_Season") - -fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) -get_contrasts(fit, formula = "Birth_Season", ROPE_bounds = c(-0.1, 0.1)) -} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_contrasts.glm.Rd b/man/get_contrasts.glm.Rd deleted file mode 100644 index 9e031eb..0000000 --- a/man/get_contrasts.glm.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts.glm} -\alias{get_contrasts.glm} -\title{Compute estimated contrasts from models.} -\usage{ -\method{get_contrasts}{glm}(fit, formula = NULL, CI = 95, - adjust = "tukey", ...) -} -\arguments{ -\item{fit}{A frequentist model.} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{adjust}{P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -"hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none".} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute estimated contrasts from models. -} diff --git a/man/get_contrasts.glmerMod.Rd b/man/get_contrasts.glmerMod.Rd deleted file mode 100644 index 7603f4d..0000000 --- a/man/get_contrasts.glmerMod.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts.glmerMod} -\alias{get_contrasts.glmerMod} -\title{Compute estimated contrasts from models.} -\usage{ -\method{get_contrasts}{glmerMod}(fit, formula = NULL, CI = 95, - adjust = "tukey", ...) -} -\arguments{ -\item{fit}{A frequentist model.} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{adjust}{P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -"hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none".} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute estimated contrasts from models. -} diff --git a/man/get_contrasts.lm.Rd b/man/get_contrasts.lm.Rd deleted file mode 100644 index 52852ac..0000000 --- a/man/get_contrasts.lm.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts.lm} -\alias{get_contrasts.lm} -\title{Compute estimated contrasts from models.} -\usage{ -\method{get_contrasts}{lm}(fit, formula = NULL, CI = 95, - adjust = "tukey", ...) -} -\arguments{ -\item{fit}{A frequentist model.} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{adjust}{P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -"hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none".} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute estimated contrasts from models. -} diff --git a/man/get_contrasts.lmerMod.Rd b/man/get_contrasts.lmerMod.Rd deleted file mode 100644 index a5884e0..0000000 --- a/man/get_contrasts.lmerMod.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts.lmerMod} -\alias{get_contrasts.lmerMod} -\title{Compute estimated contrasts from models.} -\usage{ -\method{get_contrasts}{lmerMod}(fit, formula = NULL, CI = 95, - adjust = "tukey", ...) -} -\arguments{ -\item{fit}{A frequentist model.} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{adjust}{P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -"hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none".} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute estimated contrasts from models. -} diff --git a/man/get_contrasts.lmerModLmerTest.Rd b/man/get_contrasts.lmerModLmerTest.Rd deleted file mode 100644 index e45a9e2..0000000 --- a/man/get_contrasts.lmerModLmerTest.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts.lmerModLmerTest} -\alias{get_contrasts.lmerModLmerTest} -\title{Compute estimated contrasts from models.} -\usage{ -\method{get_contrasts}{lmerModLmerTest}(fit, formula = NULL, CI = 95, - adjust = "tukey", ...) -} -\arguments{ -\item{fit}{A frequentist model.} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{adjust}{P value adjustment method for frequentist models. Default is "tukey". Can be "holm", -"hochberg", "hommel", "bonferroni", "BH", "BY", "fdr" or "none".} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute estimated contrasts from models. -} diff --git a/man/get_contrasts.stanreg.Rd b/man/get_contrasts.stanreg.Rd deleted file mode 100644 index 31da2b5..0000000 --- a/man/get_contrasts.stanreg.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_contrasts.stanreg} -\alias{get_contrasts.stanreg} -\title{Compute estimated contrasts from models.} -\usage{ -\method{get_contrasts}{stanreg}(fit, formula = NULL, CI = 90, - ROPE_bounds = NULL, overlap = FALSE, ...) -} -\arguments{ -\item{fit}{A Bayesian model.} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{ROPE_bounds}{Optional bounds of the ROPE for Bayesian models.} - -\item{overlap}{Set to TRUE to add Overlap index (for Bayesian models).} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute estimated contrasts from models. -} diff --git a/man/get_data.Rd b/man/get_data.Rd deleted file mode 100644 index 7148cd9..0000000 --- a/man/get_data.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_data} -\alias{get_data} -\title{Extract the dataframe used in a model.} -\usage{ -get_data(fit, ...) -} -\arguments{ -\item{fit}{A model.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Extract the dataframe used in a model. -} -\examples{ -\dontrun{ -library(tidyverse) -library(psycho) - -df <- mtcars \%>\% - mutate( - cyl = as.factor(cyl), - gear = as.factor(gear) - ) - -fit <- lm(wt ~ mpg, data = df) -fit <- lm(wt ~ cyl, data = df) -fit <- lm(wt ~ mpg * cyl, data = df) -fit <- lm(wt ~ cyl * gear, data = df) -fit <- lmerTest::lmer(wt ~ mpg * gear + (1 | cyl), data = df) -fit <- rstanarm::stan_lmer(wt ~ mpg * gear + (1 | cyl), data = df) - -get_data(fit) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_formula.Rd b/man/get_formula.Rd deleted file mode 100644 index 8c493fb..0000000 --- a/man/get_formula.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_formula} -\alias{get_formula} -\title{Get formula of models.} -\usage{ -get_formula(x, ...) -} -\arguments{ -\item{x}{Object.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Get formula of models. Implemented for: -\itemize{ - \item{analyze.merModLmerTest} - \item{analyze.glmerMod} - \item{analyze.lm} - \item{analyze.glm} - \item{analyze.stanreg} - } -} -\examples{ -library(psycho) -library(lme4) - -fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") -fit <- lm(hp ~ wt, data = mtcars) - -get_formula(fit) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_graph.Rd b/man/get_graph.Rd deleted file mode 100644 index a0875ca..0000000 --- a/man/get_graph.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_graph} -\alias{get_graph} -\title{Get graph data.} -\usage{ -get_graph(fit, ...) -} -\arguments{ -\item{fit}{Object from which to extract the graph data.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -To be used with tidygraph::tbl_graph. See the documentation for your object's class: -\itemize{ - \item{\link[=get_graph.lavaan]{get_graph.lavaan}} - \item{\link[=get_graph.fa]{get_graph.fa}} - \item{\link[=get_graph.psychobject_correlation]{get_graph.psychobject_correlation}} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_graph.fa.Rd b/man/get_graph.fa.Rd deleted file mode 100644 index b198196..0000000 --- a/man/get_graph.fa.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_graph.fa} -\alias{get_graph.fa} -\title{Get graph data from factor analysis.} -\usage{ -\method{get_graph}{fa}(fit, threshold_Coef = NULL, digits = 2, ...) -} -\arguments{ -\item{fit}{psych::fa object.} - -\item{threshold_Coef}{Omit all links with a Coefs below this value.} - -\item{digits}{Edges' labels rounding.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. -} -\description{ -Get graph data from fa objects. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_graph.lavaan.Rd b/man/get_graph.lavaan.Rd deleted file mode 100644 index 6e5891c..0000000 --- a/man/get_graph.lavaan.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_graph.lavaan} -\alias{get_graph.lavaan} -\title{Get graph data from lavaan or blavaan objects.} -\usage{ -\method{get_graph}{lavaan}(fit, links = c("Regression", "Correlation", - "Loading"), standardize = FALSE, threshold_Coef = NULL, - threshold_p = NULL, threshold_MPE = NULL, digits = 2, - CI = "default", labels_CI = TRUE, ...) -} -\arguments{ -\item{fit}{lavaan object.} - -\item{links}{Which links to include? A list including at least one of "Regression", "Loading" or "Correlation".} - -\item{standardize}{Use standardized coefs.} - -\item{threshold_Coef}{Omit all links with a Coefs below this value.} - -\item{threshold_p}{Omit all links with a p value above this value.} - -\item{threshold_MPE}{In case of a blavaan model, omit all links with a MPE value below this value.} - -\item{digits}{Edges' labels rounding.} - -\item{CI}{CI level.} - -\item{labels_CI}{Add the CI in the edge label.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -A list containing nodes and edges data to be used by `tidygraph::tbl_graph()`. -} -\description{ -Get graph data from lavaan or blavaan objects. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_graph.psychobject_correlation.Rd b/man/get_graph.psychobject_correlation.Rd deleted file mode 100644 index c1402d0..0000000 --- a/man/get_graph.psychobject_correlation.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_graph.psychobject_correlation} -\alias{get_graph.psychobject_correlation} -\title{Get graph data from correlation.} -\usage{ -\method{get_graph}{psychobject_correlation}(fit, ...) -} -\arguments{ -\item{fit}{Object from psycho::correlation.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -A list containing nodes and edges data to be used by `igraph::graph_from_data_frame()`. -} -\description{ -Get graph data from correlation. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_info.Rd b/man/get_info.Rd deleted file mode 100644 index dc6e550..0000000 --- a/man/get_info.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_info} -\alias{get_info} -\title{Get information about objects.} -\usage{ -get_info(x, ...) -} -\arguments{ -\item{x}{object.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Get information about models. -} -\examples{ -library(psycho) -library(lme4) - -fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") - -info <- get_info(fit) -info -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_info.lm.Rd b/man/get_info.lm.Rd deleted file mode 100644 index 6af880e..0000000 --- a/man/get_info.lm.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_info.lm} -\alias{get_info.lm} -\title{Get information about models.} -\usage{ -\method{get_info}{lm}(x, ...) -} -\arguments{ -\item{x}{object.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Get information about models. -} -\examples{ -library(psycho) -library(lme4) - -fit <- lm(vs ~ wt, data = mtcars, family = "binomial") - -info <- get_info(fit) -info - -# -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_info.lmerModLmerTest.Rd b/man/get_info.lmerModLmerTest.Rd deleted file mode 100644 index 0f79246..0000000 --- a/man/get_info.lmerModLmerTest.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_info.lmerModLmerTest} -\alias{get_info.lmerModLmerTest} -\title{Get information about models.} -\usage{ -\method{get_info}{lmerModLmerTest}(x, ...) -} -\arguments{ -\item{x}{object.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -output -} -\description{ -Get information about models. -} -\examples{ -library(psycho) -library(lme4) - -fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") - -info <- get_info(fit) -info - -# -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_loadings_max.Rd b/man/get_loadings_max.Rd deleted file mode 100644 index 54224dc..0000000 --- a/man/get_loadings_max.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_loadings_max} -\alias{get_loadings_max} -\title{Get loadings max.} -\usage{ -get_loadings_max(loadings) -} -\arguments{ -\item{loadings}{Formatted loadings.} -} -\description{ -Get loadings max. -} -\examples{ -\dontrun{ -library(psycho) - -x <- psych::fa(psych::Thurstone.33, 2) -get_loadings_max(format_loadings(x)$loadings) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_means.Rd b/man/get_means.Rd deleted file mode 100644 index b547324..0000000 --- a/man/get_means.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_means} -\alias{get_means} -\title{Compute estimated means from models.} -\usage{ -get_means(fit, formula = NULL, CI = 90, ...) -} -\arguments{ -\item{fit}{A model (lm, lme4 or rstanarm).} - -\item{formula}{A character vector (formula like format, i.e., including -interactions or nesting terms) specifying the names of the predictors over which EMMs are desired.} - -\item{CI}{Determine the confidence or credible interval bounds.} - -\item{...}{Arguments passed to or from other methods. For instance, transform="response".} -} -\value{ -Estimated means (or median of means for Bayesian models) -} -\description{ -Compute estimated means of factor levels based on a fitted model. -} -\examples{ -\dontrun{ -library(psycho) -require(lmerTest) -require(rstanarm) - - -fit <- glm(Sex ~ Birth_Season, data = affective, family = "binomial") -get_means(fit) - -fit <- lmerTest::lmer(Adjusting ~ Birth_Season * Salary + (1 | Salary), data = affective) -get_means(fit, formula = "Birth_Season") - -fit <- rstanarm::stan_glm(Adjusting ~ Birth_Season, data = affective) -get_means(fit, formula = "Birth_Season") -} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_predicted.Rd b/man/get_predicted.Rd deleted file mode 100644 index 9723c76..0000000 --- a/man/get_predicted.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_predicted} -\alias{get_predicted} -\title{Compute predicted values from models.} -\usage{ -get_predicted(fit, ...) -} -\arguments{ -\item{fit}{Model.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute predicted values from models. See the -documentation for your model's class: -\itemize{ - \item{\link[=get_predicted.stanreg]{get_predicted.stanreg}} - \item{\link[=get_predicted.merMod]{get_predicted.merMod}} - \item{\link[=get_predicted.lm]{get_predicted.lm}} - \item{\link[=get_predicted.glm]{get_predicted.glm}} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_predicted.glm.Rd b/man/get_predicted.glm.Rd deleted file mode 100644 index 9b08d68..0000000 --- a/man/get_predicted.glm.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_predicted.glm} -\alias{get_predicted.glm} -\title{Compute predicted values of lm models.} -\usage{ -\method{get_predicted}{glm}(fit, newdata = "model", prob = 0.95, - odds_to_probs = TRUE, ...) -} -\arguments{ -\item{fit}{An lm model.} - -\item{newdata}{A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used.} - -\item{prob}{Probability of confidence intervals (0.9 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)).} - -\item{odds_to_probs}{Transform log odds ratios in logistic models to probabilies.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -dataframe with predicted values. -} -\description{ -Compute predicted from a lm model. -} -\examples{ -\dontrun{ -library(psycho) -library(ggplot2) - -fit <- glm(Sex ~ Adjusting, data = affective, family = "binomial") - -refgrid <- psycho::refdata(affective, "Adjusting") -predicted <- get_predicted(fit, newdata = refgrid) - -ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + - geom_line() + - geom_ribbon(aes( - ymin = Sex_CI_2.5, - ymax = Sex_CI_97.5 - ), - alpha = 0.1 - ) -} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_predicted.lm.Rd b/man/get_predicted.lm.Rd deleted file mode 100644 index e247775..0000000 --- a/man/get_predicted.lm.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_predicted.lm} -\alias{get_predicted.lm} -\title{Compute predicted values of lm models.} -\usage{ -\method{get_predicted}{lm}(fit, newdata = "model", prob = 0.95, ...) -} -\arguments{ -\item{fit}{An lm model.} - -\item{newdata}{A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used.} - -\item{prob}{Probability of confidence intervals (0.95 (default) will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)).} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -dataframe with predicted values. -} -\description{ -Compute predicted from a lm model. -} -\examples{ -\dontrun{ -library(psycho) -library(ggplot2) - -fit <- lm(Tolerating ~ Adjusting, data = affective) - -refgrid <- psycho::refdata(affective, "Adjusting") -predicted <- get_predicted(fit, newdata = refgrid) - -ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + - geom_line() + - geom_ribbon(aes( - ymin = Tolerating_CI_2.5, - ymax = Tolerating_CI_97.5 - ), - alpha = 0.1 - ) -} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_predicted.merMod.Rd b/man/get_predicted.merMod.Rd deleted file mode 100644 index 37d4329..0000000 --- a/man/get_predicted.merMod.Rd +++ /dev/null @@ -1,84 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_predicted.merMod} -\alias{get_predicted.merMod} -\title{Compute predicted values of lm models.} -\usage{ -\method{get_predicted}{merMod}(fit, newdata = "model", prob = NULL, - odds_to_probs = TRUE, iter = 100, seed = NULL, - re.form = "default", use.u = FALSE, ...) -} -\arguments{ -\item{fit}{An lm model.} - -\item{newdata}{A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used.} - -\item{prob}{Probability of confidence intervals (0.95 will compute 2.5-97.5\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)). Default to NULL as it takes a very long time to compute (see \link[lme4]{bootMer}).} - -\item{odds_to_probs}{Transform log odds ratios in logistic models to probabilies.} - -\item{iter}{An integer indicating the number of iterations for bootstrapping (when prob is not null).} - -\item{seed}{An optional seed to use.} - -\item{re.form}{Formula for random effects to condition on. If NULL, include all random effects; if NA or ~0, include no random effects (see \link[lme4]{predict.merMod}). If "default", then will ne NULL if the random are present in the data, and NA if not.} - -\item{use.u}{logical, indicating whether the spherical random effects should be simulated / bootstrapped as well. If TRUE, they are not changed, and all inference is conditional on these values. If FALSE, new normal deviates are drawn (see\link[lme4]{bootMer}).} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -dataframe with predicted values. -} -\description{ -Compute predicted from a lm model. -} -\examples{ -\dontrun{ -library(psycho) -library(ggplot2) - -fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) - -refgrid <- psycho::refdata(affective, "Adjusting") -predicted <- get_predicted(fit, newdata = refgrid) - -ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + - geom_line() - -predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time - -ggplot(predicted, aes(x = Adjusting, y = Tolerating_Predicted)) + - geom_line() + - geom_ribbon(aes( - ymin = Tolerating_CI_2.5, - ymax = Tolerating_CI_97.5 - ), - alpha = 0.1 - ) - - - -fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = affective, family = "binomial") - -refgrid <- psycho::refdata(affective, "Adjusting") -predicted <- get_predicted(fit, newdata = refgrid) - -ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + - geom_line() - -predicted <- get_predicted(fit, newdata = refgrid, prob = 0.95, iter = 100) # Takes a long time - -ggplot(predicted, aes(x = Adjusting, y = Sex_Predicted)) + - geom_line() + - geom_ribbon(aes( - ymin = Sex_CI_2.5, - ymax = Sex_CI_97.5 - ), - alpha = 0.1 - ) -} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/get_predicted.stanreg.Rd b/man/get_predicted.stanreg.Rd deleted file mode 100644 index 7152274..0000000 --- a/man/get_predicted.stanreg.Rd +++ /dev/null @@ -1,78 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{get_predicted.stanreg} -\alias{get_predicted.stanreg} -\title{Compute predicted values of stanreg models.} -\usage{ -\method{get_predicted}{stanreg}(fit, newdata = "model", prob = 0.9, - odds_to_probs = TRUE, keep_iterations = FALSE, draws = NULL, - posterior_predict = FALSE, seed = NULL, transform = FALSE, - re.form = "default", ...) -} -\arguments{ -\item{fit}{A stanreg model.} - -\item{newdata}{A data frame in which to look for variables with which to predict. If omitted, the model matrix is used. If "model", the model's data is used.} - -\item{prob}{Probability of credible intervals (0.9 (default) will compute 5-95\% CI). Can also be a list of probs (e.g., c(0.90, 0.95)).} - -\item{odds_to_probs}{Transform log odds ratios in logistic models to probabilies.} - -\item{keep_iterations}{Keep all prediction iterations.} - -\item{draws}{An integer indicating the number of draws to return. The default and maximum number of draws is the size of the posterior sample.} - -\item{posterior_predict}{Posterior draws of the outcome instead of the link function (i.e., the regression "line").} - -\item{seed}{An optional seed to use.} - -\item{transform}{If posterior_predict is False, should the linear predictor be transformed using the inverse-link function? The default is FALSE, in which case the untransformed linear predictor is returned.} - -\item{re.form}{If object contains group-level parameters, a formula indicating which group-level parameters to condition on when making predictions. re.form is specified in the same form as for predict.merMod. NULL indicates that all estimated group-level parameters are conditioned on. To refrain from conditioning on any group-level parameters, specify NA or ~0. The newdata argument may include new levels of the grouping factors that were specified when the model was estimated, in which case the resulting posterior predictions marginalize over the relevant variables (see \link[rstanarm]{posterior_predict.stanreg}). If "default", then will ne NULL if the random are present in the data, and NA if not.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -dataframe with predicted values. -} -\description{ -Compute predicted from a stanreg model. -} -\examples{ -\dontrun{ -library(psycho) -library(ggplot2) -require(rstanarm) - -fit <- rstanarm::stan_glm(Tolerating ~ Adjusting, data = affective) - -refgrid <- psycho::refdata(affective, "Adjusting") -predicted <- get_predicted(fit, newdata = refgrid) - -ggplot(predicted, aes(x = Adjusting, y = Tolerating_Median)) + - geom_line() + - geom_ribbon(aes( - ymin = Tolerating_CI_5, - ymax = Tolerating_CI_95 - ), - alpha = 0.1 - ) - -fit <- rstanarm::stan_glm(Sex ~ Adjusting, data = affective, family = "binomial") - -refgrid <- psycho::refdata(affective, "Adjusting") -predicted <- get_predicted(fit, newdata = refgrid) - -ggplot(predicted, aes(x = Adjusting, y = Sex_Median)) + - geom_line() + - geom_ribbon(aes( - ymin = Sex_CI_5, - ymax = Sex_CI_95 - ), - alpha = 0.1 - ) -} -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/golden.Rd b/man/golden.Rd index 8669672..b5be67f 100644 --- a/man/golden.Rd +++ b/man/golden.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{golden} \alias{golden} \title{Golden Ratio.} diff --git a/man/hdi.Rd b/man/hdi.Rd deleted file mode 100644 index 8a92f9e..0000000 --- a/man/hdi.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{HDI} -\alias{HDI} -\title{Highest Density Intervals (HDI).} -\usage{ -HDI(x, prob = 0.95) -} -\arguments{ -\item{x}{A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling).} - -\item{prob}{Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated.} -} -\description{ -Compute the Highest Density Intervals (HDI) of a distribution. -} -\examples{ -library(psycho) - -distribution <- rnorm(1000, 0, 1) -HDI_values <- HDI(distribution) -print(HDI_values) -plot(HDI_values) -summary(HDI_values) - -x <- matrix(rexp(200), 100) -HDI_values <- HDI(x) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_R2.Rd b/man/interpret_R2.Rd deleted file mode 100644 index 81c8294..0000000 --- a/man/interpret_R2.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_R2} -\alias{interpret_R2} -\title{R2 interpreation.} -\usage{ -interpret_R2(x, rules = "cohen1988") -} -\arguments{ -\item{x}{Value.} - -\item{rules}{Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list.} -} -\description{ -Interpret R2 with a set of rules. -} -\examples{ -library(psycho) -interpret_R2(x = 0.42) -interpret_R2(x = c(0.42, 0.2, 0.9, 0)) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_R2_posterior.Rd b/man/interpret_R2_posterior.Rd index 3015367..3b1bc12 100644 --- a/man/interpret_R2_posterior.Rd +++ b/man/interpret_R2_posterior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/interpret_posterior.R \name{interpret_R2_posterior} \alias{interpret_R2_posterior} \title{R2 interpreation for a posterior distribution.} diff --git a/man/interpret_RMSEA.Rd b/man/interpret_RMSEA.Rd deleted file mode 100644 index c9c7b62..0000000 --- a/man/interpret_RMSEA.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_RMSEA} -\alias{interpret_RMSEA} -\title{RMSEA interpreation.} -\usage{ -interpret_RMSEA(x, rules = "awang2012") -} -\arguments{ -\item{x}{RMSEA.} - -\item{rules}{Can be "awang2012", or a custom list.} -} -\description{ -Interpret RMSEA with a set of rules. -} -\examples{ -library(psycho) -interpret_RMSEA(0.04) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_bf.Rd b/man/interpret_bf.Rd deleted file mode 100644 index 9778d03..0000000 --- a/man/interpret_bf.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_bf} -\alias{interpret_bf} -\title{Bayes Factor Interpretation} -\usage{ -interpret_bf(x, direction = TRUE, bf = TRUE, rules = "jeffreys1961") -} -\arguments{ -\item{x}{Bayes Factor.} - -\item{direction}{Include direction (against / in favour).} - -\item{bf}{Include Bayes Factor.} - -\item{rules}{Can be "jeffreys1961" (default), "raftery1995", or a custom list.} -} -\description{ -Return the interpretation of a Bayes Factor. -} -\examples{ -library(psycho) -interpret_bf(x = 10) -} -\references{ -\itemize{ - \item{Jeffreys, H. (1961), Theory of Probability, 3rd ed., Oxford University Press, Oxford.} - \item{Jarosz, A. F., & Wiley, J. (2014). What are the odds? A practical guide to computing and reporting Bayes factors. The Journal of Problem Solving, 7(1), 2.} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_lavaan.blavaan.Rd b/man/interpret_blavaan.Rd similarity index 57% rename from man/interpret_lavaan.blavaan.Rd rename to man/interpret_blavaan.Rd index 31ecacb..e43b9af 100644 --- a/man/interpret_lavaan.blavaan.Rd +++ b/man/interpret_blavaan.Rd @@ -1,18 +1,17 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R -\name{interpret_lavaan.blavaan} -\alias{interpret_lavaan.blavaan} +\name{interpret_blavaan} +\alias{interpret_blavaan} \title{Interpret fit measures of blavaan objects} \usage{ -\method{interpret_lavaan}{blavaan}(fit, indices = c("BIC", "DIC", "WAIC", - "LOOIC"), ...) +interpret_blavaan(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) } \arguments{ -\item{fit}{lavaan or blavaan object.} +\item{fit}{A blavaan model.} \item{indices}{Vector of strings indicating which indices to report. Only works for bayesian objects for now.} -\item{...}{Arguments passed to or from other methods.} +\item{...}{Other arguments.} } \description{ Interpret fit measures of blavaan objects diff --git a/man/interpret_d.Rd b/man/interpret_d.Rd deleted file mode 100644 index 27d178d..0000000 --- a/man/interpret_d.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_d} -\alias{interpret_d} -\title{Standardized difference (Cohen's d) interpreation.} -\usage{ -interpret_d(x, direction = FALSE, rules = "cohen1988") -} -\arguments{ -\item{x}{Standardized difference.} - -\item{direction}{Return direction.} - -\item{rules}{Can be "cohen1988" (default), "sawilowsky2009", or a custom list.} -} -\description{ -Interpret d with a set of rules. -} -\examples{ -library(psycho) -interpret_d(-0.42) -interpret_d(-0.62) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_d_posterior.Rd b/man/interpret_d_posterior.Rd deleted file mode 100644 index e227e6f..0000000 --- a/man/interpret_d_posterior.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_d_posterior} -\alias{interpret_d_posterior} -\title{Standardized difference (Cohen's d) interpreation for a posterior distribution.} -\usage{ -interpret_d_posterior(posterior, rules = "cohen1988") -} -\arguments{ -\item{posterior}{Posterior distribution of standardized differences.} - -\item{rules}{Can be "cohen1988" (default), "sawilowsky2009", or a custom list.} -} -\description{ -Interpret d with a set of rules. -} -\examples{ -library(psycho) -posterior <- rnorm(1000, 0.6, 0.05) -interpret_d_posterior(posterior) -interpret_d_posterior(rnorm(1000, 0.1, 1)) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_lavaan.Rd b/man/interpret_lavaan.Rd deleted file mode 100644 index 9a02487..0000000 --- a/man/interpret_lavaan.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_lavaan} -\alias{interpret_lavaan} -\title{Interpret fit measures of lavaan or blavaan objects} -\usage{ -interpret_lavaan(fit, ...) -} -\arguments{ -\item{fit}{lavaan or blavaan object.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Interpret fit measures of lavaan or blavaan objects -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_lavaan.lavaan.Rd b/man/interpret_lavaan.lavaan.Rd deleted file mode 100644 index d036690..0000000 --- a/man/interpret_lavaan.lavaan.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_lavaan.lavaan} -\alias{interpret_lavaan.lavaan} -\title{Interpret fit measures of lavaan objects} -\usage{ -\method{interpret_lavaan}{lavaan}(fit, ...) -} -\arguments{ -\item{fit}{lavaan or blavaan object.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Interpret fit measures of lavaan objects -} diff --git a/man/interpret_odds.Rd b/man/interpret_odds.Rd deleted file mode 100644 index c057123..0000000 --- a/man/interpret_odds.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_odds} -\alias{interpret_odds} -\title{Odds ratio interpreation for a posterior distribution.} -\usage{ -interpret_odds(x, log = FALSE, direction = FALSE, rules = "chen2010") -} -\arguments{ -\item{x}{Odds ratio.} - -\item{log}{Are these log odds ratio?} - -\item{direction}{Return direction.} - -\item{rules}{Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list.} -} -\description{ -Interpret odds with a set of rules. -} -\examples{ -library(psycho) -interpret_odds(x = 2) -} -\references{ -\itemize{ - \item{Chen, H., Cohen, P., & Chen, S. (2010). How big is a big odds ratio? Interpreting the magnitudes of odds ratios in epidemiological studies. Communications in Statistics—Simulation and Computation, 39(4), 860-864.} - } -} -\seealso{ -http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_odds_posterior.Rd b/man/interpret_odds_posterior.Rd deleted file mode 100644 index c4f4693..0000000 --- a/man/interpret_odds_posterior.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_odds_posterior} -\alias{interpret_odds_posterior} -\title{Odds ratio interpreation for a posterior distribution.} -\usage{ -interpret_odds_posterior(posterior, log = FALSE, rules = "chen2010") -} -\arguments{ -\item{posterior}{Posterior distribution of odds ratio.} - -\item{log}{Are these log odds ratio?} - -\item{rules}{Can be "chen2010" (default), "cohen1988" (through \link[=odds_to_d]{log odds to Cohen's d transformation}) or a custom list.} -} -\description{ -Interpret odds with a set of rules. -} -\examples{ -library(psycho) -posterior <- rnorm(1000, 0.6, 0.05) -interpret_odds_posterior(posterior) -interpret_odds_posterior(rnorm(1000, 0.1, 1)) -interpret_odds_posterior(rnorm(1000, 3, 1.5)) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_omega_sq.Rd b/man/interpret_omega_sq.Rd deleted file mode 100644 index 7f4bfc8..0000000 --- a/man/interpret_omega_sq.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_omega_sq} -\alias{interpret_omega_sq} -\title{Omega Squared Interpretation} -\usage{ -interpret_omega_sq(x, rules = "field2013") -} -\arguments{ -\item{x}{Omega Squared.} - -\item{rules}{Can be "field2013" (default), or a custom list.} -} -\description{ -Return the interpretation of Omegas Squared. -} -\examples{ -library(psycho) -interpret_omega_sq(x = 0.05) -} -\references{ -\itemize{ - \item{Field, A (2013) Discovering statistics using IBM SPSS Statistics. Fourth Edition. Sage:London.} - } -} -\seealso{ -http://imaging.mrc-cbu.cam.ac.uk/statswiki/FAQ/effectSize -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_r.Rd b/man/interpret_r.Rd deleted file mode 100644 index 8fea9ab..0000000 --- a/man/interpret_r.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_r} -\alias{interpret_r} -\title{Correlation coefficient r interpreation.} -\usage{ -interpret_r(x, direction = TRUE, strength = TRUE, - rules = "cohen1988") -} -\arguments{ -\item{x}{Correlation coefficient.} - -\item{direction}{Return direction.} - -\item{strength}{Return strength.} - -\item{rules}{Can be "cohen1988" (default), "evans1996", or a custom list.} -} -\description{ -Interpret r with a set of rules. -} -\examples{ -library(psycho) -interpret_r(-0.42) -} -\seealso{ -Page 88 of APA's 6th Edition -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_r_posterior.Rd b/man/interpret_r_posterior.Rd deleted file mode 100644 index 8d4615d..0000000 --- a/man/interpret_r_posterior.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_r_posterior} -\alias{interpret_r_posterior} -\title{Correlation coefficient r interpreation for a posterior distribution.} -\usage{ -interpret_r_posterior(posterior, rules = "cohen1988") -} -\arguments{ -\item{posterior}{Posterior distribution of correlation coefficient.} - -\item{rules}{Can be "cohen1988" (default) or "evans1996", or a custom list.} -} -\description{ -Interpret r with a set of rules. -} -\examples{ -library(psycho) -posterior <- rnorm(1000, 0.5, 0.5) -interpret_r_posterior(posterior) -} -\seealso{ -Page 88 of APA's 6th Edition -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/is.mixed.Rd b/man/is.mixed.Rd deleted file mode 100644 index d2fd963..0000000 --- a/man/is.mixed.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{is.mixed} -\alias{is.mixed} -\title{Check if model includes random effects.} -\usage{ -is.mixed(fit, ...) -} -\arguments{ -\item{fit}{Model.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Check if model is mixed. See the -documentation for your model's class: -\itemize{ - \item{\link[=is.mixed.stanreg]{is.mixed.stanreg}} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/is.mixed.stanreg.Rd b/man/is.mixed.stanreg.Rd deleted file mode 100644 index 794345a..0000000 --- a/man/is.mixed.stanreg.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{is.mixed.stanreg} -\alias{is.mixed.stanreg} -\title{Check if model includes random effects.} -\usage{ -\method{is.mixed}{stanreg}(fit, ...) -} -\arguments{ -\item{fit}{Model.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Check if model is mixed. -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/is.standardized.Rd b/man/is.standardized.Rd index 85823f1..90316d1 100644 --- a/man/is.standardized.Rd +++ b/man/is.standardized.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{is.standardized} \alias{is.standardized} \title{Check if a dataframe is standardized.} @@ -19,11 +19,12 @@ Check if a dataframe is standardized. } \examples{ library(psycho) +library(effectsize) df <- psycho::affective is.standardized(df) -dfZ <- psycho::standardize(df) +dfZ <- effectsize::standardize(df) is.standardized(dfZ) } \author{ diff --git a/man/mellenbergh.test.Rd b/man/mellenbergh.test.Rd index bdd0372..20c83c7 100644 --- a/man/mellenbergh.test.Rd +++ b/man/mellenbergh.test.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/mellenbergh.test.R \name{mellenbergh.test} \alias{mellenbergh.test} \title{Mellenbergh & van den Brink (1998) test for pre-post comparison.} diff --git a/man/model_to_priors.Rd b/man/model_to_priors.Rd index eaba6af..b2cd060 100644 --- a/man/model_to_priors.Rd +++ b/man/model_to_priors.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{model_to_priors} \alias{model_to_priors} \title{Model to Prior.} diff --git a/man/mpe.Rd b/man/mpe.Rd deleted file mode 100644 index e531c17..0000000 --- a/man/mpe.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{mpe} -\alias{mpe} -\title{Compute Maximum Probability of Effect (MPE).} -\usage{ -mpe(posterior) -} -\arguments{ -\item{posterior}{Posterior Distribution.} -} -\value{ -list containing the MPE and its values. -} -\description{ -Compute the Maximum Probability of Effect (MPE), i.e., the proportion of posterior distribution that is of the same sign as the median. In other words, it corresponds to the maximum probability that the effect is different from 0 in the median’s direction. -} -\examples{ -library(psycho) -library(rstanarm) - -fit <- rstanarm::stan_glm(rating ~ advance, data = attitude) -posterior <- psycho::analyze(fit)$values$effects$advance$posterior -mpe <- psycho::mpe(posterior) -print(mpe$MPE) -print(mpe$values) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/n_factors.Rd b/man/n_factors.Rd deleted file mode 100644 index 87128d9..0000000 --- a/man/n_factors.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{n_factors} -\alias{n_factors} -\title{Find Optimal Factor Number.} -\usage{ -n_factors(df, rotate = "varimax", fm = "minres", n = NULL) -} -\arguments{ -\item{df}{A dataframe or correlation matrix} - -\item{rotate}{What rotation to use c("none", "varimax", "oblimin","promax")} - -\item{fm}{Factoring method: "pa" for Principal Axis Factor Analysis, -"minres" (default) for minimum residual (OLS) factoring, "mle" for -Maximum Likelihood FA and "pc" for Principal Components} - -\item{n}{If correlation matrix is passed, the sample size.} -} -\value{ -output -} -\description{ -Find optimal components number using maximum method aggreement. -} -\examples{ -df <- dplyr::select_if(attitude, is.numeric) -results <- psycho::n_factors(df) - -summary(results) -plot(results) - -# See details on methods -psycho::values(results)$methods -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/odds_to_d.Rd b/man/odds_to_d.Rd deleted file mode 100644 index 04006d9..0000000 --- a/man/odds_to_d.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{odds_to_d} -\alias{odds_to_d} -\title{(Log) odds ratio to Cohen's d} -\usage{ -odds_to_d(x, log = TRUE) -} -\arguments{ -\item{x}{Odds ratio.} - -\item{log}{Are these log odds ratio?} -} -\description{ -(Log) odds ratio to Cohen's d. -} -\examples{ -library(psycho) -odds_to_d(x = 2) -} -\references{ -\itemize{ - \item{Sánchez-Meca, J., Marín-Martínez, F., & Chacón-Moscoso, S. (2003). Effect-size indices for dichotomized outcomes in meta-analysis. Psychological methods, 8(4), 448.} - } -} -\seealso{ -https://www.meta-analysis.com/downloads/Meta-analysis%20Converting%20among%20effect%20sizes.pdf -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/odds_to_probs.Rd b/man/odds_to_probs.Rd deleted file mode 100644 index d6f2c3e..0000000 --- a/man/odds_to_probs.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{odds_to_probs} -\alias{odds_to_probs} -\title{Convert (log)odds to probabilies.} -\usage{ -odds_to_probs(odds, subset = NULL, except = NULL, log = TRUE) -} -\arguments{ -\item{odds}{Odds values in vector or dataframe.} - -\item{subset}{Character or list of characters of column names to be -transformed.} - -\item{except}{Character or list of characters of column names to be excluded -from transformation.} - -\item{log}{Are these Log odds (such as in logistic models)?} -} -\description{ -Convert (log)odds to probabilies. -} -\examples{ -library(psycho) -odds_to_probs(-1.45) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/omega_sq.Rd b/man/omega_sq.Rd deleted file mode 100644 index 03d7571..0000000 --- a/man/omega_sq.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{omega_sq} -\alias{omega_sq} -\title{Partial Omega Squared.} -\usage{ -omega_sq(x, partial = TRUE) -} -\arguments{ -\item{x}{aov object.} - -\item{partial}{Return partial omega squared.} -} -\value{ -output -} -\description{ -Partial Omega Squared. -} -\examples{ -library(psycho) - -df <- psycho::affective - -x <- aov(df$Tolerating ~ df$Salary) -x <- aov(df$Tolerating ~ df$Salary * df$Sex) - -omega_sq(x) -} -\seealso{ -http://stats.stackexchange.com/a/126520 -} -\author{ -Arnoud Plantinga -} diff --git a/man/overlap.Rd b/man/overlap.Rd deleted file mode 100644 index bb7ed69..0000000 --- a/man/overlap.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{overlap} -\alias{overlap} -\title{Overlap of Two Empirical Distributions.} -\usage{ -overlap(x, y, method = "trapezoid") -} -\arguments{ -\item{x}{A vector of values from a probability distribution (e.g., posterior probabilities from MCMC sampling).} - -\item{y}{Scalar between 0 and 1, indicating the mass within the credible interval that is to be estimated.} - -\item{method}{Method of AUC computation. Can be "trapezoid" (default), "step" or "spline".} -} -\description{ -A method to calculate the overlap coefficient of two kernel density estimates (a measure of similarity between two samples). -} -\examples{ -library(psycho) - -x <- rnorm(100, 1, 0.5) -y <- rnorm(100, 0, 1) -overlap(x, y) -} -\author{ -S. Venne -} diff --git a/man/percentile.Rd b/man/percentile.Rd index 135e1c8..2860063 100644 --- a/man/percentile.Rd +++ b/man/percentile.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{percentile} \alias{percentile} \title{Transform z score to percentile.} diff --git a/man/percentile_to_z.Rd b/man/percentile_to_z.Rd index 6e2a87b..f6e8c4a 100644 --- a/man/percentile_to_z.Rd +++ b/man/percentile_to_z.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{percentile_to_z} \alias{percentile_to_z} \title{Transform a percentile to a z score.} diff --git a/man/plot.psychobject.Rd b/man/plot.psychobject.Rd index 2bb72a8..cd2fd43 100644 --- a/man/plot.psychobject.Rd +++ b/man/plot.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/psychobject.R \name{plot.psychobject} \alias{plot.psychobject} \title{Plot the results.} diff --git a/man/plot_loadings.Rd b/man/plot_loadings.Rd deleted file mode 100644 index 5a07c00..0000000 --- a/man/plot_loadings.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{plot_loadings} -\alias{plot_loadings} -\title{Plot loadings.} -\usage{ -plot_loadings(loadings) -} -\arguments{ -\item{loadings}{Loadings by variable.} -} -\description{ -Plot loadings. -} -\examples{ -\dontrun{ -library(psycho) - -x <- psych::fa(psych::Thurstone.33, 2) -plot_loadings(format_loadings(x)$loadings) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/power_analysis.Rd b/man/power_analysis.Rd index 80594dd..1e98772 100644 --- a/man/power_analysis.Rd +++ b/man/power_analysis.Rd @@ -1,12 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/miscellaneous.R \name{power_analysis} \alias{power_analysis} \title{Power analysis for fitted models.} \usage{ power_analysis(fit, n_max, n_min = NULL, step = 1, n_batch = 1, - groups = NULL, verbose = TRUE, CI = 90, effsize = FALSE, - effsize_rules = "cohen1988", bayes_factor = FALSE, overlap = FALSE) + groups = NULL, verbose = TRUE, CI = 90) } \arguments{ \item{fit}{A lm or stanreg model.} @@ -23,15 +22,7 @@ power_analysis(fit, n_max, n_min = NULL, step = 1, n_batch = 1, \item{verbose}{Print progress.} -\item{CI}{Argument for \link[=analyze]{analyze}.} - -\item{effsize}{Argument for \link[=analyze]{analyze}.} - -\item{effsize_rules}{Argument for \link[=analyze]{analyze}.} - -\item{bayes_factor}{Argument for \link[=analyze]{analyze}.} - -\item{overlap}{rgument for \link[=analyze]{analyze}.} +\item{CI}{Confidence level.} } \value{ A dataframe containing the summary of all models for all iterations. diff --git a/man/print.psychobject.Rd b/man/print.psychobject.Rd index 8de8772..5ee634d 100644 --- a/man/print.psychobject.Rd +++ b/man/print.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/psychobject.R \name{print.psychobject} \alias{print.psychobject} \title{Print the results.} diff --git a/man/probs_to_odds.Rd b/man/probs_to_odds.Rd deleted file mode 100644 index 5e03bb8..0000000 --- a/man/probs_to_odds.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{probs_to_odds} -\alias{probs_to_odds} -\title{Convert probabilities to (log)odds.} -\usage{ -probs_to_odds(probs, log = FALSE) -} -\arguments{ -\item{probs}{Probabilities values in vector or dataframe.} - -\item{log}{Compute log odds (such as in logistic models)?} -} -\description{ -Convert probabilities to (log)odds. -} -\examples{ -library(psycho) -probs_to_odds(0.75) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/refdata.Rd b/man/refdata.Rd deleted file mode 100644 index f613c3b..0000000 --- a/man/refdata.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{refdata} -\alias{refdata} -\title{Create a reference grid.} -\usage{ -refdata(df, target = "all", length.out = 10, factors = "reference", - numerics = "mean", na.rm = TRUE) -} -\arguments{ -\item{df}{The dataframe.} - -\item{target}{String or list of strings to indicate target columns. Can be "all".} - -\item{length.out}{Length of numeric target variables.} - -\item{factors}{Type of summary for factors. Can be "combination" or "reference".} - -\item{numerics}{Type of summary for numerics Can be "combination", any function ("mean", "median", ...) or a value.} - -\item{na.rm}{Remove NaNs.} -} -\description{ -Create a reference grid. -} -\examples{ -library(psycho) - -df <- psycho::affective -newdata <- refdata(df, target = "Sex") -newdata <- refdata(df, target = "Sex", factors = "combinations") -newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), length.out = 3) -newdata <- refdata(df, target = c("Sex", "Salary", "Tolerating"), numerics = 0) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/remove_outliers.Rd b/man/remove_outliers.Rd deleted file mode 100644 index e5091e3..0000000 --- a/man/remove_outliers.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{remove_outliers} -\alias{remove_outliers} -\title{Remove outliers.} -\usage{ -remove_outliers(df, target, threshold = qnorm(0.95), - direction = "both") -} -\arguments{ -\item{df}{Dataframe.} - -\item{target}{String or list of strings of variables} - -\item{threshold}{The z-score value (deviation of SD) by which to consider outliers.} - -\item{direction}{Can be "both", "upper" or "lower".} -} -\description{ -Removes outliers (with the z-score method only for now). -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/reorder_matrix.Rd b/man/reorder_matrix.Rd deleted file mode 100644 index f61e482..0000000 --- a/man/reorder_matrix.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{reorder_matrix} -\alias{reorder_matrix} -\title{Reorder square matrix.} -\usage{ -reorder_matrix(mat, dmat = NULL) -} -\arguments{ -\item{mat}{A square matrix.} - -\item{dmat}{A square matrix with values to use as distance.} -} -\description{ -Reorder square matrix. -} -\examples{ -library(psycho) - -r <- correlation(iris) -r <- r$values$r -r <- reorder_matrix(r) -} diff --git a/man/rnorm_perfect.Rd b/man/rnorm_perfect.Rd deleted file mode 100644 index ed92733..0000000 --- a/man/rnorm_perfect.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{rnorm_perfect} -\alias{rnorm_perfect} -\title{Perfect Normal Distribution.} -\usage{ -rnorm_perfect(n, mean = 0, sd = 1, method = "qnorm", iter = 10000) -} -\arguments{ -\item{n}{number of observations. If length(n) > 1, the length is taken to be the number required.} - -\item{mean}{vector of means.} - -\item{sd}{vector of standard deviations.} - -\item{method}{"qnorm" or "average".} - -\item{iter}{number of iterations (precision).} -} -\description{ -Generates a sample of size n with a near-perfect normal distribution. -} -\examples{ -library(psycho) -x <- rnorm_perfect(10) -plot(density(x)) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/rope.Rd b/man/rope.Rd deleted file mode 100644 index 4f57bb4..0000000 --- a/man/rope.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{rope} -\alias{rope} -\title{Region of Practical Equivalence (ROPE)} -\usage{ -rope(posterior, bounds = c(-0.1, 0.1), CI = 95, overlap = FALSE) -} -\arguments{ -\item{posterior}{Posterior Distribution.} - -\item{bounds}{Rope lower and higher bounds.} - -\item{CI}{The credible interval to use.} - -\item{overlap}{Compute rope overlap (EXPERIMENTAL).} -} -\value{ -list containing rope indices -} -\description{ -Compute the proportion of a posterior distribution that lies within a region of practical equivalence. -} -\examples{ -library(psycho) - -posterior <- rnorm(1000, 0, 0.01) -results <- rope(posterior) -results$decision -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/simulate_data_regression.Rd b/man/simulate_data_regression.Rd index d0ce07d..4192358 100644 --- a/man/simulate_data_regression.Rd +++ b/man/simulate_data_regression.Rd @@ -25,7 +25,6 @@ library(psycho) data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) fit <- lm(y ~ ., data = data) coef(fit) -analyze(fit) } \author{ TPArrow diff --git a/man/standardize.Rd b/man/standardize.Rd deleted file mode 100644 index 20e31f2..0000000 --- a/man/standardize.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{standardize} -\alias{standardize} -\title{Standardize.} -\usage{ -standardize(x, ...) -} -\arguments{ -\item{x}{Object.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Standardize objects. See the documentation for your object's class: -\itemize{ -\item{\link[=standardize.numeric]{standardize.numeric}} -\item{\link[=standardize.data.frame]{standardize.data.frame}} -\item{\link[=standardize.stanreg]{standardize.stanreg}} -\item{\link[=standardize.lm]{standardize.lm}} -\item{\link[=standardize.glm]{standardize.glm}} - } -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/standardize.data.frame.Rd b/man/standardize.data.frame.Rd deleted file mode 100644 index 951b263..0000000 --- a/man/standardize.data.frame.Rd +++ /dev/null @@ -1,55 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{standardize.data.frame} -\alias{standardize.data.frame} -\title{Standardize (scale and reduce) Dataframe.} -\usage{ -\method{standardize}{data.frame}(x, subset = NULL, except = NULL, - normalize = FALSE, ...) -} -\arguments{ -\item{x}{Dataframe.} - -\item{subset}{Character or list of characters of column names to be -standardized.} - -\item{except}{Character or list of characters of column names to be excluded -from standardization.} - -\item{normalize}{Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1.} - -\item{...}{Arguments passed to or from other methods.} -} -\value{ -Dataframe. -} -\description{ -Selects numeric variables and standardize (Z-score, "normalize") them. -} -\examples{ -\dontrun{ -df <- data.frame( - Participant = as.factor(rep(1:25, each = 4)), - Condition = base::rep_len(c("A", "B", "C", "D"), 100), - V1 = rnorm(100, 30, .2), - V2 = runif(100, 3, 5), - V3 = rnorm(100, 100, 10) -) - -dfZ <- standardize(df) -dfZ <- standardize(df, except = "V3") -dfZ <- standardize(df, except = c("V1", "V2")) -dfZ <- standardize(df, subset = "V3") -dfZ <- standardize(df, subset = c("V1", "V2")) -dfZ <- standardize(df, normalize = TRUE) - -# Respects grouping -dfZ <- df \%>\% - dplyr::group_by(Participant) \%>\% - standardize(df) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/standardize.glm.Rd b/man/standardize.glm.Rd deleted file mode 100644 index b7b1399..0000000 --- a/man/standardize.glm.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{standardize.glm} -\alias{standardize.glm} -\title{Standardize Coefficients.} -\usage{ -\method{standardize}{glm}(x, method = "refit", ...) -} -\arguments{ -\item{x}{A linear model.} - -\item{method}{The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "agresti".} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute standardized coefficients. -} -\examples{ -\dontrun{ -library(psycho) -fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") -fit <- lme4::glmer(Sex ~ Adjusting + (1 | Sex), data = psycho::affective, family = "binomial") - -standardize(fit) -} - -} -\seealso{ -https://think-lab.github.io/d/205/ -} -\author{ -Kamil Barton -} diff --git a/man/standardize.lm.Rd b/man/standardize.lm.Rd deleted file mode 100644 index 153fd0f..0000000 --- a/man/standardize.lm.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{standardize.lm} -\alias{standardize.lm} -\title{Standardize Coefficients.} -\usage{ -\method{standardize}{lm}(x, method = "refit", partial_sd = FALSE, - preserve_factors = TRUE, ...) -} -\arguments{ -\item{x}{A linear model.} - -\item{method}{The standardization method. Can be "refit" (will entirely refit the model based on standardized data. Can take some time) or "posthoc".} - -\item{partial_sd}{Logical, if set to TRUE, model coefficients are multiplied by partial SD, otherwise they are multiplied by the ratio of the standard deviations of the independent variable and dependent variable.} - -\item{preserve_factors}{Standardize factors-related coefs only by the dependent variable (i.e., do not standardize the dummies generated by factors).} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute standardized coefficients. -} -\examples{ -\dontrun{ -library(psycho) - -df <- mtcars \%>\% - mutate(cyl = as.factor(cyl)) - -fit <- lm(wt ~ mpg * cyl, data = df) -fit <- lmerTest::lmer(wt ~ mpg * cyl + (1 | gear), data = df) - -summary(fit) -standardize(fit) -} - -} -\author{ -Kamil Barton -} diff --git a/man/standardize.numeric.Rd b/man/standardize.numeric.Rd deleted file mode 100644 index 32b933d..0000000 --- a/man/standardize.numeric.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{standardize.numeric} -\alias{standardize.numeric} -\title{Standardize (scale and reduce) numeric variables.} -\usage{ -\method{standardize}{numeric}(x, normalize = FALSE, ...) -} -\arguments{ -\item{x}{Numeric vector.} - -\item{normalize}{Will perform a normalization instead of a standardization. This scales all numeric variables in the range 0 - 1.} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Standardize (Z-score, "normalize") a vector. -} -\examples{ -standardize(x = c(1, 4, 6, 2)) -standardize(x = c(1, 4, 6, 2), normalize = TRUE) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/standardize.stanreg.Rd b/man/standardize.stanreg.Rd deleted file mode 100644 index ac9837d..0000000 --- a/man/standardize.stanreg.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{standardize.stanreg} -\alias{standardize.stanreg} -\title{Standardize Posteriors.} -\usage{ -\method{standardize}{stanreg}(x, method = "refit", ...) -} -\arguments{ -\item{x}{A stanreg model.} - -\item{method}{"refit" (default) will entirely refit the model based on standardized data. Can take a long time. Other post-hoc methods are "posterior" (based on estimated SD) or "sample" (based on the sample SD).} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Compute standardized posteriors from which to get standardized coefficients. -} -\examples{ -\dontrun{ -library(psycho) -library(rstanarm) - -fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = iris) -fit <- rstanarm::stan_glm(Sepal.Length ~ Sepal.Width * Species, data = standardize(iris)) -posteriors <- standardize(fit) -posteriors <- standardize(fit, method = "posterior") -} - -} -\seealso{ -https://github.com/stan-dev/rstanarm/issues/298 -} -\author{ -\href{https://github.com/jgabry}{Jonah Gabry}, \href{https://github.com/bgoodri}{bgoodri} -} diff --git a/man/summary.psychobject.Rd b/man/summary.psychobject.Rd index e479648..126eb5f 100644 --- a/man/summary.psychobject.Rd +++ b/man/summary.psychobject.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/psychobject.R \name{summary.psychobject} \alias{summary.psychobject} \title{Print the results.} diff --git a/man/values.Rd b/man/values.Rd index c42a926..8447c04 100644 --- a/man/values.Rd +++ b/man/values.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R +% Please edit documentation in R/psychobject.R \name{values} \alias{values} \title{Extract values as list.} diff --git a/tests/testthat/test-assess.R b/tests/testthat/test-assess.R new file mode 100644 index 0000000..7736057 --- /dev/null +++ b/tests/testthat/test-assess.R @@ -0,0 +1,150 @@ +context("neuropsychological tests") + + + + +test_that("assess", { + x <- assess( + patient = 10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$p, 0.018, tol = 0.02) + + x <- assess( + patient = 10, + mean = 8, + sd = 2, + n = 10 + ) + + testthat::expect_equal(x$values$p, 0.18, tol = 0.02) + + x <- assess( + patient = c(10, 12), + mean = 8, + sd = 2, + verbose = FALSE + ) + + testthat::expect_equal(x[[1]]$values$p, 0.16, tol = 0.05) +}) + + + + + +test_that("crawford.test", { + + # bayesian ---------------------------------------------------------------- + + + x <- crawford.test( + patient = 10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$p, 0.019, tol = 0.02) + + x <- crawford.test( + patient = -10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$p, 0.019, tol = 0.02) + + + + # frequentist ------------------------------------------------------------- + + + x <- crawford.test.freq( + patient = 10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, 3.05, tol = 0.2) + + x <- crawford.test.freq( + patient = -10, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, -3.3, tol = 0.2) + + x <- crawford.test.freq( + patient = 7, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, 2.10, tol = 0.2) + + x <- crawford.test.freq( + patient = 0, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$t, -0.12, tol = 0.2) +}) + + + + + + + +test_that("crawford.test", { + x <- crawford_dissociation.test( + case_X = 142, + case_Y = 7, + controls_X = c(100, 125, 89, 105, 109, 99), + controls_Y = c(7, 8, 9, 6, 7, 10) + ) + + testthat::expect_equal(x$t, 2.1, tol = 0.02) +}) + + + + + + + + + + +test_that("mellenbergh.test", { + x <- mellenbergh.test( + t0 = 4, + t1 = 12, + controls = c(0, -2, 5, 2, 1, 3, -4, -2) + ) + + testthat::expect_equal(x$values$z, 1.90, tol = 0.2) + + + x <- mellenbergh.test( + t0 = 4, + t1 = 12, + controls = 2.54 + ) + + testthat::expect_equal(x$values$z, 2.22, tol = 0.2) + + x <- mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) + testthat::expect_equal(x$values$z, 1.90, tol = 0.1) + x <- mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) + testthat::expect_equal(x$values$z, -1.63, tol = 0.1) +}) + + + + + + + + + + + + diff --git a/tests/testthat/test-deprecated.R b/tests/testthat/test-deprecated.R index 7aa5568..ef9190e 100644 --- a/tests/testthat/test-deprecated.R +++ b/tests/testthat/test-deprecated.R @@ -1,513 +1,5 @@ context("deprecated") -test_that("If it works.", { - library(psycho) - library(lmerTest) - library(lme4) - - df <- psycho::affective - x <- aov(Tolerating ~ Salary, data = df) - testthat::expect_equal(nrow(summary(psycho::analyze(x))), 2) - - x <- anova(lm(Tolerating ~ Salary, data = df)) - testthat::expect_equal(nrow(summary(psycho::analyze(x))), 2) - - x <- aov(Tolerating ~ Birth_Season + Error(Sex), data = df) - testthat::expect_message(psycho::analyze(x)) - - x <- anova(lmerTest::lmer(Tolerating ~ Birth_Season + (1 | Sex), data = df)) - testthat::expect_equal(nrow(summary(psycho::analyze(x))), 1) - - x <- anova(lme4::lmer(Tolerating ~ Birth_Season + (1 | Sex), data = df)) - testthat::expect_error(psycho::analyze(x)) -}) - - -test_that("analyze.glmer", { - library(lme4) - - # GLM - fit <- lme4::glmer(vs ~ mpg + (1 | cyl), data = mtcars, family = "binomial") - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$mpg$Coef, 2), 0.17, tolerance = 0.02) - - # test summary - summa <- summary(model, round = 2) - testthat::expect_equal(nrow(summa), 2) - - # GLM - fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = psycho::affective, family = "binomial") - testthat::expect_warning(analyze(fit)) -}) - - -test_that("analyze.glm", { - library(psycho) - - # GLM - fit <- glm(vs ~ mpg, data = mtcars, family = "binomial") - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$mpg$Coef, 2), 0.43, tolerance = 0.02) - - # test summary - summa <- summary(model, round = 2) - testthat::expect_equal(nrow(summa), 2) -}) - - - - -test_that("analyze.htest", { - library(psycho) - - df <- psycho::affective - - x <- t.test(df$Adjusting, df$Concealing) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) - - x <- cor.test(df$Adjusting, df$Concealing) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) - - x <- t.test(df$Adjusting ~ df$Sex) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) - - x <- t.test(df$Adjusting, mu = 0) - rez <- psycho::analyze(x) - testthat::expect_equal(ncol(summary(rez)), 6) -}) - - - - - - - - -test_that("analyze.lavaan", { - library(psycho) - library(lavaan) - - HS.model <- " visual =~ x1 + x2 + x3\n textual =~ x4 + x5 + x6\n speed =~ x7 + x8 + x9 " - - fit <- lavaan::cfa(HS.model, data = lavaan::HolzingerSwineford1939) - rez <- analyze(fit) - testthat::expect_equal(nrow(summary(rez)), 24) -}) - - - - -test_that("analyze.lm", { - library(psycho) - - # GLM - fit <- lm(Sepal.Width ~ Sepal.Length, data = iris) - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$Sepal.Length$Coef, 2), -0.06, tolerance = 0.01) - - # test summary - summa <- summary(model, round = 2) - testthat::expect_equal(nrow(summa), 2) - - - # Poly - fit <- lm(Sepal.Width ~ poly(Sepal.Length, 2), data = iris) - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal(round(values$effects$`poly(Sepal.Length, 2)2`$Coef, 2), 0.82, tolerance = 0.01) -}) - - - - - -test_that("analyze.lmerModLmerTest", { - # Fit - library(lmerTest) - - fit <- lmerTest::lmer(Sepal.Length ~ Sepal.Width + (1 | Species), data = iris) - - model <- analyze(fit) - values <- values(model) - testthat::expect_equal( - round(values$effects$Sepal.Width$Coef, 2), 0.8, - tolerance = 0.05 - ) -}) - - - - -test_that("analyze.stanreg", { - # Fit - library(rstanarm) - library(psycho) - - set.seed(666) - - quiet <- function(x) { - sink(tempfile()) - on.exit(sink()) - invisible(force(x)) - } - - - - fit <- quiet(rstanarm::stan_glm( - vs ~ mpg * as.factor(cyl), - data = mtcars, - family = binomial(link = "logit"), - prior = NULL, - chains = 1, iter = 1000, seed = 666 - )) - - model <- psycho::analyze(fit) - values <- psycho::values(model) - testthat::expect_equal(round(values$effects$mpg$median, 2), 0.08, tolerance = 0.10) - - model <- psycho::analyze(fit, effsize = TRUE) - values <- psycho::values(model) - testthat::expect_equal(round(values$effects$mpg$median, 2), 0.08, tolerance = 0.10) - # This needs to be fixed: - # testthat::expect_equal(round(values$effects$mpg$std_median, 2), 0.39, tolerance = 0.10) - - - # Random - fit <- quiet(rstanarm::stan_glmer( - Sepal.Length ~ Sepal.Width + (1 | Species), - data = iris, - chains = 1, iter = 1000, seed = 666 - )) - - model <- psycho::analyze(fit, effsize = FALSE) - values <- psycho::values(model) - testthat::expect_equal( - round(values$effects$Sepal.Width$median, 2), 0.79, - tolerance = 0.05 - ) - - - - # standardized - data <- psycho::standardize(iris) - fit <- quiet(rstanarm::stan_glm(Sepal.Length ~ Sepal.Width + Petal.Width, - data = data, - prior = rstanarm::normal(0, 1, autoscale = FALSE), - chains = 1, iter = 1000, seed = 666 - )) - results <- psycho::analyze(fit) - testthat::expect_equal( - round(results$values$effects$Sepal.Width$median, 2), 0.21, - tolerance = 0.025 - ) - results <- psycho::analyze(fit, effsize = TRUE) - testthat::expect_equal( - round(results$values$effects$Sepal.Width$median, 2), 0.21, - tolerance = 0.025 - ) - - - - # Other algorithms - fit <- quiet(rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width, - data = iris, - seed = 666, - algorithm = "meanfield" - )) - - results <- psycho::analyze(fit) - values <- psycho::values(results) - testthat::expect_equal( - round(values$effects$Sepal.Width$median, 2), -0.46, - tolerance = 0.1 - ) - - # This also needs to be fixed - - # fit <- rstanarm::stan_glm( - # Sepal.Length ~ Sepal.Width, - # data = iris, - # seed = 666, - # algorithm = "fullrank" - # ) - # - # results <- psycho::analyze(fit) - # values <- psycho::values(results) - - # testthat::expect_equal( - # round(values$effects$Sepal.Width$median, 2), -0.12, - # tolerance = 0.1 - # ) - - fit <- quiet(rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width, - data = iris, - seed = 666, - algorithm = "optimizing" - )) - testthat::expect_error(psycho::analyze(fit)) -}) - - - -test_that("assess", { - x <- assess( - patient = 10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$p, 0.018, tol = 0.02) - - x <- assess( - patient = 10, - mean = 8, - sd = 2, - n = 10 - ) - - testthat::expect_equal(x$values$p, 0.18, tol = 0.02) - - x <- assess( - patient = c(10, 12), - mean = 8, - sd = 2, - verbose = FALSE - ) - - testthat::expect_equal(x[[1]]$values$p, 0.16, tol = 0.05) -}) - - - - -test_that("bayes_cor", { - results <- psycho::bayes_cor.test( - psycho::affective$Concealing, - psycho::affective$Tolerating - ) - - testthat::expect_equal(results$values$median, 0.073, tol = 0.05) - testthat::expect_equal(results$values$effect_size$values$`very small`, 0.82, tol = 0.05) - - results <- psycho::bayes_cor(iris) - testthat::expect_equal(nrow(results$values$r), 4) - - - results <- psycho::bayes_cor( - dplyr::select(iris, dplyr::starts_with("Sepal")), - dplyr::select(iris, dplyr::starts_with("Petal")) - ) - testthat::expect_equal(nrow(results$values$r), 2) -}) - - - - - - -test_that("correlation", { - df <- attitude[c("rating", "complaints", "privileges", "learning")] - - - # Pearson - output <- psycho::correlation(df) - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.82, tol = 0.1) - - # Spearman - output <- psycho::correlation(df, method = "spearman") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.83, tol = 0.1) - - # Partial - output <- psycho::correlation(df, type = "partial", adjust = "holm") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.72, tol = 0.1) - - # Semi - output <- psycho::correlation(df, type = "semi", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.53, tol = 0.1) - - # glasso - # testthat::expect_warning(psycho::correlation(df, type = "glasso", adjust = "none")) - - # cor_auto - output <- psycho::correlation(df, type = "cor_auto", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.82, tol = 0.1) - - # Dual - df2 <- attitude[c("raises", "critical")] - output <- psycho::correlation(df, df2, type = "full", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.67, tol = 0.1) - - - - type <- "semi" - adjust <- "none" - method <- "pearson" - output <- psycho::correlation(df, df2, type = "semi", adjust = "none") - value <- output$values$r[2, 1] - testthat::expect_equal(value, 0.46, tol = 0.1) - - plot <- plot(output) - testthat::expect_equal(length(plot), 10, tol = 0.1) - - # Other - testthat::expect_warning(psycho::correlation(df, type = "dupa", adjust = "holm")) - - # Plot - plot <- plot(correlation(df)) - testthat::expect_equal(length(plot), 10, tol = 0.1) - - testthat::expect_warning(correlation(data.frame(replicate(11, rnorm(100))), adjust = "none")) -}) - - - - - -test_that("crawford.test", { - - # bayesian ---------------------------------------------------------------- - - - x <- crawford.test( - patient = 10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$p, 0.019, tol = 0.02) - - x <- crawford.test( - patient = -10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$p, 0.019, tol = 0.02) - - - - # frequentist ------------------------------------------------------------- - - - x <- crawford.test.freq( - patient = 10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, 3.05, tol = 0.2) - - x <- crawford.test.freq( - patient = -10, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, -3.3, tol = 0.2) - - x <- crawford.test.freq( - patient = 7, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, 2.10, tol = 0.2) - - x <- crawford.test.freq( - patient = 0, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$t, -0.12, tol = 0.2) -}) - - - - - - - -test_that("crawford.test", { - x <- crawford_dissociation.test( - case_X = 142, - case_Y = 7, - controls_X = c(100, 125, 89, 105, 109, 99), - controls_Y = c(7, 8, 9, 6, 7, 10) - ) - - testthat::expect_equal(x$t, 2.1, tol = 0.02) -}) - - - - - -test_that("create_intervals", { - x <- psycho::rnorm_perfect(1000) - testthat::expect_equal(length(levels(psycho::create_intervals(x, 3))), 3) - testthat::expect_equal(length(levels(psycho::create_intervals(x, length = 100))), 2) - testthat::expect_equal(length(levels(psycho::create_intervals(x, 3, equal_range = FALSE))), 3) - testthat::expect_true(is.numeric(psycho::create_intervals(x, 3, labels = "median"))) - testthat::expect_true(is.numeric(psycho::create_intervals(x, 3, labels = FALSE))) -}) - - - - - -test_that("dprime", { - testthat::expect_equal(dprime(9, 2, 1, 7)$dprime, 1.65, tolerance = 0.1) - testthat::expect_equal(dprime(1, 9, 1, 0)$dprime, -1.49, tolerance = 0.1) - - df <- data.frame( - Participant = c("A", "B", "C"), - n_hit = c(1, 2, 5), - n_fa = c(6, 8, 1) - ) - - indices <- dprime(n_hit = df$n_hit, n_fa = df$n_fa, n_targets = 10, n_distractors = 10, adjusted = F) - testthat::expect_equal(indices$dprime[1], -1.53, tolerance = 0.1) - - testthat::expect_equal(dprime(5, 0, n_targets = 10, n_distractors = 8, adjusted = FALSE)$aprime, 0.875, tolerance = 0.1) -}) - - - - - -test_that("find_best_model.stanreg", { - testthat::expect_equal(1, 1) - - # The following fails for some reasons - - # data <- standardize(attitude) - # fit <- rstanarm::stan_glm(rating ~ advance + privileges, - # chains = 1, iter = 500, - # data=data, - # seed=666) - # - # best <- find_best_model(fit, K=2) - # best_formula <- best$formula - # testthat::expect_equal(best_formula, "rating ~ privileges") - # - # best <- find_best_model(fit, K=0) - # best_formula <- best$formula - # testthat::expect_equal(best_formula, "rating ~ privileges") -}) - - @@ -528,17 +20,6 @@ test_that("find_matching_string", { -test_that("find_random_effects", { - f <- as.formula("Y ~ A + B + C + D + (1|E)") - rf <- psycho::find_random_effects(f) - testthat::expect_equal(rf, "(1|E)") -}) - - - - - - test_that("find_season", { dates <- c("2017-02-15", "2017-05-15", "2017-08-15", "2017-11-15") @@ -550,496 +31,16 @@ test_that("find_season", { -test_that("formatting", { - - testthat::expect_equal(format_p(0.00000), "< .001***") - testthat::expect_equal(format_p(0.00000, stars = FALSE), "< .001") - - testthat::expect_equal(format_formula(paste("A", "~ B")), "A ~ B") -}) - - - - - - - -test_that("get_contrasts", { - # rstanarm - require(rstanarm) - - df <- psycho::affective - fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data = df) - - contrasts <- psycho::get_contrasts(fit, "Salary") - testthat::expect_equal(mean(contrasts$Median), -0.134, tolerance = 0.05) - - # lmerTest - require(lmerTest) - - fit <- lmerTest::lmer(Adjusting ~ Birth_Season + (1 | Salary), data = psycho::affective) - - contrasts <- get_contrasts(fit) - testthat::expect_equal(mean(contrasts$Difference), -0.218, tolerance = 0.05) - - # glmer - require(lme4) - - fit <- lme4::glmer(Sex ~ Birth_Season + (1 | Salary), data = psycho::affective, family = "binomial") - - contrasts <- get_contrasts(fit, adjust = "bonf") - testthat::expect_equal(mean(contrasts$Difference), -0.0734, tolerance = 0.05) - - # glm - fit <- glm(Sex ~ Birth_Season, data = psycho::affective, family = "binomial") - - contrasts <- get_contrasts(fit) - testthat::expect_equal(mean(contrasts$Difference), -0.0458, tolerance = 0.05) -}) - - - - - -test_that("get_info", { - fit <- lme4::glmer(vs ~ wt + (1 | gear), data = mtcars, family = "binomial") - info <- get_info(fit) - testthat::expect_equal(info$outcome, "vs") - fit <- lme4::lmer(hp ~ wt + (1 | gear), data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") - fit <- glm(vs ~ wt, data = mtcars, family = "binomial") - info <- get_info(fit) - testthat::expect_equal(info$outcome, "vs") - fit <- lm(hp ~ wt, data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") - fit <- rstanarm::stan_glm(hp ~ wt, data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") - - outcome <- "hp" - fit <- lm(paste(outcome, " ~ wt"), data = mtcars) - info <- get_info(fit) - testthat::expect_equal(info$outcome, "hp") -}) - - - - - - - - -test_that("get_means", { - # rstanarm - require(rstanarm) - - df <- psycho::affective - fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data = df) - - means <- psycho::get_means(fit, "Salary") - testthat::expect_equal(mean(means$Median), 4.876, tolerance = 0.05) - - - # lmerTest - require(lmerTest) - - fit <- lmerTest::lmer(Adjusting ~ Birth_Season + (1 | Salary), data = psycho::affective) - - means <- get_means(fit, formula = "Birth_Season") - testthat::expect_equal(mean(means$Mean), 3.860, tolerance = 0.05) - - - # glmer - require(lme4) - - fit <- lme4::glmer(Sex ~ Birth_Season + (1 | Salary), data = psycho::affective, family = "binomial") - - means <- get_means(fit, formula = "Birth_Season") - testthat::expect_equal(mean(means$Mean), -1.221759, tolerance = 0.05) - - # glm - fit <- glm(Sex ~ Birth_Season, data = psycho::affective, family = "binomial") - - means <- get_means(fit, formula = "Birth_Season") - testthat::expect_equal(mean(means$Mean), -1.413, tolerance = 0.05) -}) - - - - - - - - - - - - - - -test_that("get_predicted", { - - - - # Rstanarm ---------------------------------------------------------------- - library(psycho) - require(rstanarm) - - - fit <- rstanarm::stan_glm( - vs ~ mpg, - data = mtcars, - family = binomial(link = "logit"), - seed = 666 - ) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$vs, data$vs_Median)$estimate) - testthat::expect_equal(r, 0.68, tolerance = 0.2) - - - - - fit <- rstanarm::stan_glm( - cyl ~ mpg, - data = mtcars, - seed = 666 - ) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$cyl, data$cyl_Median)$estimate) - testthat::expect_equal(r, 0.85, tolerance = 0.02) - - - - fit <- rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width + Species, - data = iris, - seed = 666 - ) - data <- psycho::get_predicted(fit, posterior_predict = TRUE) - r <- as.numeric(cor.test(data$Sepal.Length, data$Sepal.Length_Median)$estimate) - testthat::expect_equal(r, 0.84, tolerance = 0.02) - - - # Actual test ------------------------------------------------------------- - - df <- psycho::affective - fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, data = df) - ref_grid <- emmeans::ref_grid(fit, at = list( - Tolerating = seq(min(df$Tolerating), - max(df$Tolerating), - length.out = 10 - ) - )) - - predicted <- psycho::get_predicted(fit, newdata = ref_grid) - testthat::expect_equal(mean(predicted$Life_Satisfaction_Median), 4.77, tolerance = 0.05) - - predicted <- psycho::get_predicted(fit, newdata = ref_grid, keep_iterations = TRUE) - testthat::expect_equal(length(predicted), 4004) - - - - - - - - # GLM and LM -------------------------------------------------------------- - - fit <- glm(vs ~ mpg, data = mtcars, family = binomial(link = "logit")) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$vs, data$vs_Predicted)$estimate) - testthat::expect_equal(r, 0.68, tolerance = 0.2) - - - fit <- lm(cyl ~ mpg, data = mtcars) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(mtcars$cyl, data$cyl_Predicted)$estimate) - testthat::expect_equal(r, 0.85, tolerance = 0.02) - - # glmerMod ---------------------------------------------------------------- - library(lme4) - - fit <- lme4::glmer(vs ~ mpg + (1 | cyl), data = mtcars, family = binomial(link = "logit")) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$vs, data$vs_Predicted)$estimate) - testthat::expect_equal(r, 0.79, tolerance = 0.02) - - fit <- lme4::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$Tolerating, data$Tolerating_Predicted)$estimate) - testthat::expect_equal(r, 0.3, tolerance = 0.02) - - library(lmerTest) - fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Salary), data = affective) - data <- psycho::get_predicted(fit) - r <- as.numeric(cor.test(data$Tolerating, data$Tolerating_Predicted)$estimate) - testthat::expect_equal(r, 0.3, tolerance = 0.02) -}) - - - - - - - - - - - -test_that("get_R2", { - # Fit - library(psycho) - - fit <- lm(Tolerating ~ Adjusting, data = psycho::affective) - testthat::expect_equal(psycho::get_R2(fit)$R2, 0.08, tol = 0.01) - - fit <- glm(Sex ~ Adjusting, data = psycho::affective, family = "binomial") - testthat::expect_equal(psycho::get_R2(fit), 0.025, tol = 0.01) - - fit <- lmerTest::lmer(Tolerating ~ Adjusting + (1 | Sex), data = psycho::affective) - testthat::expect_equal(psycho::get_R2(fit)$R2m, 0.08, tol = 0.01) - testthat::expect_equal(psycho::get_R2(fit, method = "tjur")$R2m, 0.081, tol = 0.01) - - fit <- lme4::glmer(Sex ~ Adjusting + (1 | Salary), data = na.omit(psycho::affective), family = "binomial") - testthat::expect_equal(psycho::get_R2(fit)$R2m, 0.037, tol = 0.01) -}) - - - - - - - -test_that("hdi", { - x <- attitude$rating - results <- psycho::HDI(x, 0.95) - - testthat::expect_equal(results$values$HDImin, 40) - testthat::expect_equal(length(plot(results)), 9) - testthat::expect_equal(psycho::HDI(x, 95)$values$HDImin, 40) -}) - - - - - - - - -test_that("interpret_bf", { - testthat::expect_equal(psycho::interpret_bf(3), "moderate evidence (BF = 3.00) in favour of") - testthat::expect_equal(psycho::interpret_bf(1 / 3), "moderate evidence (BF = 3.00) against") - testthat::expect_equal(psycho::interpret_bf(1 / 3, rules = "raftery1995"), "positive evidence (BF = 3.00) against") -}) - - - - - -test_that("interpret_d", { - testthat::expect_equal(psycho::interpret_d(0), "very small") - testthat::expect_equal(psycho::interpret_d(0, rules = "sawilowsky2009"), "tiny") - - testthat::expect_equal(psycho::interpret_d_posterior(c(0.1, 0.1, 0.1, 0.1))$values$large, 0) -}) - - - - - - -test_that("interpret_odds", { - testthat::expect_equal(psycho::interpret_odds(0), "very small") - testthat::expect_equal(psycho::interpret_odds(0, log = TRUE), "very small") - testthat::expect_equal(psycho::interpret_odds(5, log = TRUE), "large") - testthat::expect_equal(psycho::interpret_odds(5, log = TRUE, rules = "cohen1988"), "large") - - testthat::expect_equal(psycho::interpret_odds_posterior(c(5, 5, 5, 5))$values$large, 0) -}) - - - - - - - - -test_that("interpret_r", { - testthat::expect_equal(psycho::interpret_r(0), "very small, and negative") - testthat::expect_equal(psycho::interpret_r(0, rules = "evans1996"), "very weak, and negative") -}) - - - - - - - -test_that("interpret_R2", { - testthat::expect_equal(psycho::interpret_R2(0.2), "medium") - testthat::expect_equal(psycho::interpret_R2(0.2, rules = "chin1998"), "small") - testthat::expect_equal(psycho::interpret_R2(0.2, rules = "hair2013"), "very small") - testthat::expect_true(is.na(psycho::interpret_R2(-5))) - - testthat::expect_equal(psycho::interpret_R2_posterior(c(0.2, 0.2, 0.2))$values$medium, 1) - testthat::expect_equal(psycho::interpret_R2_posterior(c(0.1, 0.2, 0.3, 0.4))$values$large, 0.5) -}) - - - - - - - - -test_that("interpret_RMSEA", { - testthat::expect_equal(psycho::interpret_RMSEA(0.04), "good") - testthat::expect_equal(psycho::interpret_RMSEA(0.05), "acceptable") - testthat::expect_equal(psycho::interpret_RMSEA(0.08), "poor") -}) - - - - - - - - - -test_that("is.mixed.stanreg", { - library(rstanarm) - fit <- rstanarm::stan_glm(Sepal.Length ~ Petal.Length, data = iris, iter = 100) - testthat::expect_equal(is.mixed(fit), FALSE) - fit <- rstanarm::stan_lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris, iter = 100) - testthat::expect_equal(is.mixed(fit), TRUE) -}) - - - - - - - - - -test_that("is.psychobject", { - df <- attitude - results <- psycho::correlation(df) - testthat::expect_true(psycho::is.psychobject(results)) -}) - - - - - - - - -test_that("is.standardized", { - df <- psycho::affective - testthat::expect_equal(is.standardized(df), F) - df <- psycho::standardize(df) - testthat::expect_equal(is.standardized(df), T) -}) - - - - - - -test_that("mellenbergh.test", { - x <- mellenbergh.test( - t0 = 4, - t1 = 12, - controls = c(0, -2, 5, 2, 1, 3, -4, -2) - ) - - testthat::expect_equal(x$values$z, 1.90, tol = 0.2) - - - x <- mellenbergh.test( - t0 = 4, - t1 = 12, - controls = 2.54 - ) - - testthat::expect_equal(x$values$z, 2.22, tol = 0.2) - - x <- mellenbergh.test(t0 = 4, t1 = 12, controls = c(0, -2, 5, 2, 1, 3, -4, -2)) - testthat::expect_equal(x$values$z, 1.90, tol = 0.1) - x <- mellenbergh.test(t0 = 8, t1 = 2, controls = 2.6) - testthat::expect_equal(x$values$z, -1.63, tol = 0.1) -}) - - - - - - - -test_that("model_to_priors", { - fit <- rstanarm::stan_glm(Sepal.Length ~ Petal.Width, data = iris) - priors <- psycho::model_to_priors(fit) - testthat::expect_equal(length(priors), 3) -}) - - - - - - -test_that("n_factors", { - results <- attitude %>% - select_if(is.numeric) %>% - psycho::n_factors() - - testthat::expect_equal(nrow(summary(results)), 7) - testthat::expect_equal(nrow(psycho::values(results)$methods), 9) - testthat::expect_equal(length(plot(results)), 9) -}) - - - - - -test_that("odds_to_probs", { - testthat::expect_equal(odds_to_probs(-1.6), 0.17, tolerance = 0.01) - testthat::expect_equal(odds_to_probs(-1.6, log = F), 2.66, tolerance = 0.01) - - testthat::expect_equal( - ncol(odds_to_probs( - psycho::affective, - subset = c("Life_Satisfaction"), - except = c("Sex") - )), - 8 - ) -}) - - - - - - - - -test_that("overlap", { - x <- rnorm(1000, 1, 0.5) - y <- rnorm(1000, 0, 1) - testthat::expect_equal(overlap(x, y), 0.43, tolerance = 0.1) -}) @@ -1084,29 +85,6 @@ test_that("print.psychobject", { -test_that("probs_to_odds", { - testthat::expect_equal(probs_to_odds(0.75), 3, tolerance = 0.01) - testthat::expect_equal(probs_to_odds(0.75, log = TRUE), 1.098, tolerance = 0.01) -}) - - - - - - -test_that("refdata", { - testthat::expect_equal(nrow(psycho::refdata(psycho::affective, target = "Sex")), 2) - testthat::expect_equal(nrow(psycho::refdata(iris, length.out = 2)), 48) - testthat::expect_equal(nrow(psycho::refdata(iris, target = "Sepal.Length", length.out = 2, factors = "combinations")), 6) - testthat::expect_equal(nrow(psycho::refdata(iris, target = "Species", length.out = 2, factors = "combinations")), 3) - testthat::expect_equal(nrow(psycho::refdata(iris, target = "Species", length.out = 2, numerics = 0)), 3) -}) - - - - - - @@ -1125,82 +103,6 @@ test_that("remove_empty_cols", { -test_that("rnorm_perfect", { - x <- psycho::rnorm_perfect(10, 0, 1) - testthat::expect_equal(mean(x), 0, tolerance = 0.02) - - x <- psycho::rnorm_perfect(10, 0, 1, method = "average") - testthat::expect_equal(mean(x), 0, tolerance = 0.05) -}) - - - - - - -test_that("standardize", { - library(psycho) - - set.seed(666) - df <- data.frame( - Participant = as.factor(rep(1:25, each = 4)), - Condition = base::rep_len(c("A", "B", "C", "D"), 100), - V1 = rnorm(100, 30, .2), - V2 = runif(100, 3, 5), - V3 = rnorm(100, 100, 10) - ) - - # Deactivate all this for CRAN - - # dfZ <- standardize(df) - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfZ <- standardize(df, except = "V3") - # testthat::expect_equal(mean(dfZ$V2), 0, tol = 0.01) - # - # dfZ <- standardize(df, except = c("V1", "V2")) - # testthat::expect_equal(mean(dfZ$V3), 0, tol = 0.01) - # - # dfZ <- standardize(df$V1) - # testthat::expect_equal(mean(dfZ), 0, tol = 0.01) - # - # dfZ <- standardize(df, subset = c("V1", "V2")) - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfZ <- standardize(df, subset = "V1", except = "V3") - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfZ <- standardize(dplyr::group_by(df, Participant)) - # testthat::expect_equal(mean(dfZ$V1), 0, tol = 0.01) - # - # dfN <- standardize(df, except = "V3", normalize = TRUE) - # testthat::expect_equal(mean(dfN$V2), 0.533, tol = 0.5) - - - # Models - fit <- rstanarm::stan_glm( - Sepal.Length ~ Sepal.Width, - data = iris, - seed = 666, - algorithm = "meanfield" - ) - - std <- standardize(fit, method = "posterior") - testthat::expect_equal(mean(std), -0.24, tol = 0.02) - - std <- standardize(fit, method = "sample") - testthat::expect_equal(mean(std), 1.34, tol = 0.02) - - fit <- lm( - Sepal.Length ~ Sepal.Width, - data = iris - ) - - std <- standardize(fit, method = "posthoc") - testthat::expect_equal(mean(std$Coef_std), -0.059, tol = 0.01) -}) - - @@ -1215,19 +117,3 @@ test_that("values.psychobject", { - - - - -test_that("analyze.fa", { - library(psycho) - library(psych) - - x <- psych::fa(psych::Thurstone.33, 2) - - results <- analyze(x) - testthat::expect_equal(nrow(summary(results)), 9) - - cfa_model <- get_cfa_model(results$values$loadings, treshold = 0.3) - testthat::expect_equal(length(cfa_model), 1) -}) diff --git a/tests/testthat/test-dprime.R b/tests/testthat/test-dprime.R new file mode 100644 index 0000000..a06d78d --- /dev/null +++ b/tests/testthat/test-dprime.R @@ -0,0 +1,18 @@ +context("dprime") + + +test_that("dprime", { + testthat::expect_equal(dprime(9, 2, 1, 7)$dprime, 1.65, tolerance = 0.1) + testthat::expect_equal(dprime(1, 9, 1, 0)$dprime, -1.49, tolerance = 0.1) + + df <- data.frame( + Participant = c("A", "B", "C"), + n_hit = c(1, 2, 5), + n_fa = c(6, 8, 1) + ) + + indices <- dprime(n_hit = df$n_hit, n_fa = df$n_fa, n_targets = 10, n_distractors = 10, adjusted = F) + testthat::expect_equal(indices$dprime[1], -1.53, tolerance = 0.1) + + testthat::expect_equal(dprime(5, 0, n_targets = 10, n_distractors = 8, adjusted = FALSE)$aprime, 0.875, tolerance = 0.1) +}) From 7d89256cb662bfbd59a46267167fbe92866b69a8 Mon Sep 17 00:00:00 2001 From: Dominique Makowski Date: Wed, 22 Jan 2020 11:16:27 +0800 Subject: [PATCH 3/4] remove everything and fix --- DESCRIPTION | 38 +-- NAMESPACE | 11 - R/crawford.test.R | 2 +- R/deprecated.R | 442 ++------------------------- R/format_digit.R | 18 -- R/interpret_posterior.R | 119 -------- R/miscellaneous.R | 165 ++++------ R/startup_message.R | 2 +- man/assess.Rd | 22 +- man/crawford.test.Rd | 21 +- man/crawford_dissociation.test.Rd | 9 +- man/dprime.Rd | 11 +- man/find_combinations.formula.Rd | 3 +- man/find_matching_string.Rd | 3 +- man/find_season.Rd | 9 +- man/format_digit.Rd | 27 -- man/format_formula.Rd | 27 -- man/interpret_R2_posterior.Rd | 24 -- man/interpret_blavaan.Rd | 18 -- man/model_to_priors.Rd | 44 --- man/power_analysis.Rd | 12 +- man/simulate_data_regression.Rd | 31 -- vignettes/bayesian.R | 333 --------------------- vignettes/bayesian.Rmd | 19 -- vignettes/bayesian.html | 269 ----------------- vignettes/overview.R | 21 -- vignettes/overview.Rmd | 3 - vignettes/overview.html | 479 ------------------------------ 28 files changed, 168 insertions(+), 2014 deletions(-) delete mode 100644 R/format_digit.R delete mode 100644 R/interpret_posterior.R delete mode 100644 man/format_digit.Rd delete mode 100644 man/format_formula.Rd delete mode 100644 man/interpret_R2_posterior.Rd delete mode 100644 man/interpret_blavaan.Rd delete mode 100644 man/model_to_priors.Rd delete mode 100644 man/simulate_data_regression.Rd delete mode 100644 vignettes/bayesian.R delete mode 100644 vignettes/bayesian.html delete mode 100644 vignettes/overview.R delete mode 100644 vignettes/overview.html diff --git a/DESCRIPTION b/DESCRIPTION index c1ba438..1a9303f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: psycho Type: Package Title: Efficient and Publishing-Oriented Workflow for Psychological Science -Version: 0.5.0 +Version: 0.5.1 Authors@R: c( person("Dominique", "Makowski", @@ -28,41 +28,23 @@ Description: The main goal of the psycho package is to provide tools for psychol License: MIT + file LICENSE Encoding: UTF-8 LazyData: true -RoxygenNote: 6.1.1 +RoxygenNote: 7.0.2 Depends: R (>= 3.5.0) Imports: methods, + stats, + scales, + utils, + dplyr, + tidyr, + stringr, + ggplot2, insight, bayestestR, parameters, performance, - effectsize, - dplyr, - ggplot2, - tidyr, - stringr, - purrr, - psych, - MASS, - qgraph, - nFactors, - ppcor, - ggcorrplot, - rstanarm, - rstantools, - MuMIn, - lme4, - lmerTest, - emmeans (>= 1.2.2), - broom, - tibble, - DescTools, - BayesFactor (>= 0.9.1), - scales, - loo (>= 2.0.0), - lavaan, - blavaan (>= 0.3.4) + effectsize Suggests: knitr, rmarkdown, diff --git a/NAMESPACE b/NAMESPACE index 2b11059..cf72bf6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,32 +12,23 @@ export(dprime) export(find_combinations) export(find_matching_string) export(find_season) -export(format_digit) -export(format_formula) export(golden) -export(interpret_R2_posterior) -export(interpret_blavaan) export(is.psychobject) export(is.standardized) export(mellenbergh.test) -export(model_to_priors) export(percentile) export(percentile_to_z) export(power_analysis) export(remove_empty_cols) -export(simulate_data_regression) export(values) import(dplyr) import(ggplot2) -import(purrr) -importFrom(rstanarm,normal) importFrom(scales,rescale) importFrom(stats,approx) importFrom(stats,cor) importFrom(stats,density) importFrom(stats,ecdf) importFrom(stats,model.frame) -importFrom(stats,na.omit) importFrom(stats,pnorm) importFrom(stats,pt) importFrom(stats,qnorm) @@ -48,5 +39,3 @@ importFrom(stats,terms) importFrom(stats,update) importFrom(stats,var) importFrom(utils,combn) -importFrom(utils,head) -importFrom(utils,tail) diff --git a/R/crawford.test.R b/R/crawford.test.R index c904d26..5583b4b 100644 --- a/R/crawford.test.R +++ b/R/crawford.test.R @@ -122,7 +122,7 @@ crawford.test <- function(patient, direction, insight::format_value((1 - p) * 100), "% (", - parameters::format_ci(ci$CI_low, ci$CI_high, ci = CI / 100), + insight::format_ci(ci$CI_low, ci$CI_high, ci = CI / 100), ") of the control population." ) diff --git a/R/deprecated.R b/R/deprecated.R index 1c2b8c2..587138b 100644 --- a/R/deprecated.R +++ b/R/deprecated.R @@ -1,7 +1,3 @@ - - - - #' Remove empty columns. #' #' Removes all columns containing ony NaNs. @@ -39,90 +35,6 @@ is.psychobject <- function(x) inherits(x, "psychobject") - - - - - - - - - - -#' Simulates data for single or multiple regression. -#' -#' Simulates data for single or multiple regression. -#' -#' @param coefs Desired theorethical coefs. Can be a single value or a list. -#' @param sample Desired sample size. -#' @param error The error (standard deviation of gaussian noise). -#' -#' @examples -#' library(psycho) -#' -#' data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) -#' fit <- lm(y ~ ., data = data) -#' coef(fit) -#' @details See https://stats.stackexchange.com/questions/59062/multiple-linear-regression-simulation -#' -#' @author TPArrow -#' -#' @export -simulate_data_regression <- function(coefs = 0.5, sample = 100, error = 0) { - - # Prevent error - coefs[coefs == 0] <- 0.01 - - y <- rnorm(sample, 0, 1) - - n_var <- length(coefs) - X <- scale(matrix(rnorm(sample * (n_var), 0, 1), ncol = n_var)) - X <- cbind(y, X) - - # find the current correlation matrix - cor_0 <- var(X) - - # cholesky decomposition to get independence - chol_0 <- solve(chol(cor_0)) - - X <- X %*% chol_0 - - # create new correlation structure (zeros can be replaced with other r vals) - coefs_structure <- diag(x = 1, nrow = n_var + 1, ncol = n_var + 1) - coefs_structure[-1, 1] <- coefs - coefs_structure[1, -1] <- coefs - - X <- X %*% chol(coefs_structure) * sd(y) + mean(y) - X <- X[, -1] - - # Add noise - y <- y + rnorm(sample, 0, error) - - data <- data.frame(X) - names(data) <- paste0("V", 1:n_var) - data$y <- as.vector(y) - - return(data) -} - - - - - - - - - - - - - - - - - - - # analyze.blavaan <- function(x, CI = 90, standardize = FALSE, ...) { # fit <- x # @@ -315,6 +227,30 @@ simulate_data_regression <- function(coefs = 0.5, sample = 100, error = 0) { +# interpret_blavaan <- function(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) { +# values <- list() +# +# indices <- lavaan::fitmeasures(fit) +# +# +# for (index in names(indices)) { +# values[index] <- indices[index] +# } +# +# # Summary +# summary <- as.data.frame(indices) %>% +# tibble::rownames_to_column("Index") %>% +# rename_("Value" = "indices") %>% +# mutate_("Index" = "str_to_upper(Index)") +# +# # Text +# relevant_indices <- summary[summary$Index %in% c("BIC", "DIC", "WAIC", "LOOIC"), ] +# text <- paste0(relevant_indices$Index, " = ", insight::format_value(relevant_indices$Value), collapse = ", ") +# +# output <- list(text = text, summary = summary, values = values, plot = "Not available yet") +# class(output) <- c("psychobject", "list") +# return(output) +# } @@ -439,333 +375,3 @@ find_combinations.formula <- function(object, interaction = TRUE, fixed = NULL, } - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#' Clean and format formula. -#' -#' Clean and format formula. -#' -#' @param formula formula -#' @param ... Arguments passed to or from other methods. -#' -#' -#' @examples -#' library(psycho) -#' library(lme4) -#' -#' fit <- lm(hp ~ wt, data = mtcars) -#' -#' format_formula(fit$call$formula) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @export -format_formula <- function(formula) { - formula <- tryCatch({ - stringr::str_squish(paste(format(eval(formula)), collapse = "")) - }, error = function(e) { - formula <- stringr::str_squish(paste(format(formula), collapse = "")) - }) - - return(formula) -} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -# get_graph.lavaan <- function(fit, links = c("Regression", "Correlation", "Loading"), standardize = FALSE, threshold_Coef = NULL, threshold_p = NULL, threshold_MPE = NULL, digits = 2, CI = "default", labels_CI = TRUE, ...) { -# # https://www.r-bloggers.com/ggplot2-sem-models-with-tidygraph-and-ggraph/ -# -# -# if (labels_CI == TRUE) { -# if (CI != "default") { -# results <- analyze(fit, CI = CI, standardize = standardize) -# } else { -# results <- analyze(fit, standardize = standardize) -# } -# } else { -# results <- analyze(fit, standardize = standardize) -# } -# -# summary <- summary(results) -# CI <- results$values$CI -# -# # Check what type of model -# if (class(fit) %in% c("blavaan")) { -# summary$Coef <- summary$Median -# if (is.null(threshold_MPE)) { -# threshold_MPE <- -1 -# } -# summary <- summary %>% -# filter_("MPE >= threshold_MPE") -# } else if (class(fit) %in% c("lavaan")) { -# if (is.null(threshold_p)) { -# threshold_p <- 1.1 -# } -# summary <- summary %>% -# filter_("p <= threshold_p") -# } else { -# stop(paste("Error in UseMethod('plot_lavaan') : no applicable method for 'plot_lavaan' applied to an object of class", class(fit))) -# } -# -# # Deal with thresholds -# if (is.null(threshold_Coef)) { -# threshold_Coef <- min(abs(summary$Coef)) - 1 -# } -# -# # Edge properties -# edges <- summary %>% -# mutate_("abs_coef" = "abs(Coef)") %>% -# filter_( -# "Type %in% c(links)", -# "From != To", -# "abs_coef >= threshold_Coef" -# ) %>% -# select(-one_of("abs_coef")) %>% -# rename_( -# "to" = "To", -# "from" = "From" -# ) -# -# # Labels -# if (labels_CI == TRUE) { -# edges <- edges %>% -# mutate_("Label" = 'paste0(insight::format_value(Coef, digits), -# ", ", CI, "% CI [", insight::format_value(CI_lower, digits), -# ", ", insight::format_value(CI_higher, digits), "]")') -# } else { -# edges <- edges %>% -# mutate_("Label" = "insight::format_value(Coef, digits)") -# } -# edges <- edges %>% -# mutate_( -# "Label_Regression" = "ifelse(Type=='Regression', Label, '')", -# "Label_Correlation" = "ifelse(Type=='Correlation', Label, '')", -# "Label_Loading" = "ifelse(Type=='Loading', Label, '')" -# ) -# edges <- edges[colSums(!is.na(edges)) > 0] -# -# # Identify latent variables for nodes -# latent_nodes <- edges %>% -# filter_('Type == "Loading"') %>% -# distinct_("to") %>% -# transmute_("Name" = "to", "Latent" = TRUE) -# -# nodes_list <- unique(c(edges$from, edges$to)) -# -# # Node properties -# nodes <- summary %>% -# filter_( -# "From == To", -# "From %in% nodes_list" -# ) %>% -# mutate_("Name" = "From") %>% -# left_join(latent_nodes, by = "Name") %>% -# mutate_("Latent" = "if_else(is.na(Latent), FALSE, Latent)") %>% -# select(one_of(c("Name", "Latent"))) -# -# return(list(nodes = nodes, edges = edges)) -# } - - - - - - -# get_graph.fa <- function(fit, threshold_Coef = NULL, digits = 2, ...) { -# edges <- summary(analyze(fit)) %>% -# tidyr::gather("To", "Coef", -one_of("N", "Item", "Label")) %>% -# rename_("From" = "Item") %>% -# mutate_("Label" = "insight::format_value(Coef, digits)") %>% -# select(one_of("From", "To", "Coef", "Label"), everything()) %>% -# dplyr::filter() -# -# # Deal with thresholds -# if (is.null(threshold_Coef)) { -# threshold_Coef <- min(abs(edges$Coef)) - 1 -# } -# -# edges <- edges %>% -# filter_("Coef > threshold_Coef") -# -# nodes <- data.frame("Name" = c(edges$From, edges$To)) %>% -# distinct_("Name") -# -# return(list(nodes = nodes, edges = edges)) -# } - - - - -# get_graph.psychobject_correlation <- function(fit, ...) { -# vars <- row.names(fit$values$r) -# -# r <- fit$values$r %>% -# as.data.frame() %>% -# tibble::rownames_to_column("from") %>% -# tidyr::gather("to", "r", vars) -# -# if ("p" %in% names(fit$values)) { -# r <- r %>% -# full_join( -# fit$values$p %>% -# as.data.frame() %>% -# tibble::rownames_to_column("from") %>% -# tidyr::gather("to", "p", vars), -# by = c("from", "to") -# ) -# } -# -# r <- filter_(r, "!from == to") -# return(r) -# } - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#' Interpret fit measures of blavaan objects -#' -#' Interpret fit measures of blavaan objects -#' -#' @param indices Vector of strings indicating which indices to report. Only works for bayesian objects for now. -#' @param fit A blavaan model. -#' @param ... Other arguments. -#' @export -interpret_blavaan <- function(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) { - values <- list() - - indices <- lavaan::fitmeasures(fit) - - - for (index in names(indices)) { - values[index] <- indices[index] - } - - # Summary - summary <- as.data.frame(indices) %>% - tibble::rownames_to_column("Index") %>% - rename_("Value" = "indices") %>% - mutate_("Index" = "str_to_upper(Index)") - - # Text - relevant_indices <- summary[summary$Index %in% c("BIC", "DIC", "WAIC", "LOOIC"), ] - text <- paste0(relevant_indices$Index, " = ", insight::format_value(relevant_indices$Value), collapse = ", ") - - output <- list(text = text, summary = summary, values = values, plot = "Not available yet") - class(output) <- c("psychobject", "list") - return(output) -} - - - - - - - - - - - - - - diff --git a/R/format_digit.R b/R/format_digit.R deleted file mode 100644 index 2ecb090..0000000 --- a/R/format_digit.R +++ /dev/null @@ -1,18 +0,0 @@ -#' Formatting -#' -#' @param x number. -#' @param digits number of significant digits. -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @examples -#' -#' format_digit(1.20) -#' format_digit(1.2) -#' format_digit(1.2012313) -#' format_digit(0.0045) -#' -#' @export -format_digit <- function(x, digits=2){ - return(trimws(format(round(x, digits), nsmall = digits))) -} diff --git a/R/interpret_posterior.R b/R/interpret_posterior.R deleted file mode 100644 index 6f4d308..0000000 --- a/R/interpret_posterior.R +++ /dev/null @@ -1,119 +0,0 @@ - - -#' R2 interpreation for a posterior distribution. -#' -#' Interpret R2 with a set of rules. -#' -#' @param posterior Distribution of R2. -#' @param rules Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list. -#' -#' @examples -#' library(psycho) -#' posterior <- rnorm(1000, 0.4, 0.1) -#' interpret_R2_posterior(posterior) -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' @importFrom stats na.omit -#' @importFrom utils head tail -#' @export -interpret_R2_posterior <- function(posterior, rules = "cohen1988") { - interpretation <- sapply(posterior, .interpret_R2, rules = rules) - rules <- unlist(interpretation[, 1]$rules) - interpretation <- as.data.frame(unlist(interpretation[1, ])) - interpretation <- na.omit(interpretation) - names(interpretation) <- "Interpretation" - - summary <- interpretation %>% - group_by_("Interpretation") %>% - summarise_("Probability" = "n() / length(posterior)") - - values <- list() - for (value in names(sort(rules, decreasing = TRUE))) { - if (value %in% summary$Interpretation) { - values[value] <- summary[summary$Interpretation == value, ]$Probability - } else { - values[value] <- 0 - } - } - - # Text - if (length(summary$Interpretation) > 1) { - text_strength <- paste0(paste0(head(summary$Interpretation, -1), collapse = ", "), " or ", tail(summary$Interpretation, 1)) - text_effects <- paste0( - paste0(paste0(insight::format_value(head(summary$Probability * 100, -1)), "%"), collapse = ", "), - " and ", - paste0(insight::format_value(tail(summary$Probability, 1) * 100), "%") - ) - - text <- paste0( - "The R2 can be considered as ", - text_strength, - " with respective probabilities of ", - text_effects, - "." - ) - } else { - text_sizes <- summary$Interpretation - text_effects <- paste0(insight::format_value(summary$Probability * 100), "%") - - text <- paste0( - "The R2 can be considered as ", - text_sizes, - " with a probability of ", - text_effects, - "." - ) - } - - - plot <- "Not available." - - output <- list(text = text, plot = plot, summary = summary, values = values) - class(output) <- c("psychobject", "list") - - return(output) -} - - -#' @keywords internal -.interpret_R2 <- function(x, rules = "cohen1988", return_rules = TRUE) { - if (!is.list(rules)) { - if (rules == "cohen1988") { - rules <- list( - "very small" = 0, - "small" = 0.02, - "medium" = 0.13, - "large" = 0.26 - ) - } else if (rules == "chin1998") { - rules <- list( - "very small" = 0, - "small" = 0.19, - "medium" = 0.33, - "large" = 0.67 - ) - } else if (rules == "hair2013") { - rules <- list( - "very small" = 0, - "small" = 0.25, - "medium" = 0.50, - "large" = 0.75 - ) - } else { - stop("rules must be either a list or 'cohen1988', 'chin1998' or 'hair2013'.") - } - } - - x <- (x - unlist(rules)) - interpretation <- names(which.min(x[x >= 0])) - if (is.null(interpretation)) { - interpretation <- NA - } - - if (return_rules) { - return(list(interpretation = interpretation, rules = rules)) - } else { - return(interpretation) - } -} - - diff --git a/R/miscellaneous.R b/R/miscellaneous.R index 6ef70da..bab484c 100644 --- a/R/miscellaneous.R +++ b/R/miscellaneous.R @@ -19,13 +19,12 @@ #' #' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} #' -#' @import purrr #' @export is.standardized <- function(df, tol = 0.1) { dfZ <- effectsize::standardize(df) - dfZnum <- purrr::keep(dfZ, is.numeric) + dfZnum <- dfZ[sapply(dfZ, is.numeric)] - dfnum <- purrr::keep(df, is.numeric) + dfnum <- dfZ[sapply(df, is.numeric)] error <- as.matrix(dfnum) - as.matrix(dfZnum) error <- as.data.frame(error) @@ -50,105 +49,69 @@ is.standardized <- function(df, tol = 0.1) { -#' Model to Prior. -#' -#' Convert a Bayesian model's results to priors. -#' -#' @param fit A stanreg model. -#' @param autoscale Set autoscale. -#' @examples -#' \dontrun{ -#' library(rstanarm) -#' library(psycho) -#' -#' fit <- stan_glm(Sepal.Length ~ Petal.Width, data = iris) -#' priors <- model_to_priors(fit) -#' update(fit, prior = priors$prior) -#' -#' fit <- stan_glmer(Subjective_Valence ~ Emotion_Condition + (1 | Participant_ID), -#' data = psycho::emotion -#' ) -#' priors <- model_to_priors(fit) -#' -#' fit1 <- stan_glm(Subjective_Valence ~ Emotion_Condition, -#' data = filter(psycho::emotion, Participant_ID == "1S") -#' ) -#' -#' fit2 <- stan_glm(Subjective_Valence ~ Emotion_Condition, -#' data = filter(psycho::emotion, Participant_ID == "1S"), -#' prior = priors$prior, prior_intercept = priors$prior_intercept -#' ) -#' } -#' -#' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} -#' -#' @import dplyr -#' @importFrom stats update -#' @importFrom rstanarm normal -#' @export -model_to_priors <- function(fit, autoscale = FALSE) { - posteriors <- as.data.frame(fit) - - # Varnames - varnames <- names(posteriors) - varnames <- varnames[grepl("b\\[", varnames) == FALSE] - - fixed_effects <- names(fit$coefficients) - fixed_effects <- fixed_effects[grepl("b\\[", fixed_effects) == FALSE] - fixed_effects <- fixed_effects[fixed_effects != "(Intercept)"] - - # Get priors - prior_intercept <- list() - priors <- list() - prior_aux <- list() - for (prior in varnames) { - if (prior == "(Intercept)") { - prior_intercept$mean <- mean(posteriors[[prior]]) - prior_intercept$sd <- sd(posteriors[[prior]]) - } else if (prior %in% fixed_effects) { - priors[[prior]] <- list() - priors[[prior]]$mean <- mean(posteriors[[prior]]) - priors[[prior]]$sd <- sd(posteriors[[prior]]) - } else { - prior_aux[[prior]] <- list() - prior_aux[[prior]]$mean <- mean(posteriors[[prior]]) - prior_aux[[prior]]$sd <- sd(posteriors[[prior]]) - } - } +# model_to_priors <- function(fit, autoscale = FALSE) { +# posteriors <- as.data.frame(fit) +# +# # Varnames +# varnames <- names(posteriors) +# varnames <- varnames[grepl("b\\[", varnames) == FALSE] +# +# fixed_effects <- names(fit$coefficients) +# fixed_effects <- fixed_effects[grepl("b\\[", fixed_effects) == FALSE] +# fixed_effects <- fixed_effects[fixed_effects != "(Intercept)"] +# +# # Get priors +# prior_intercept <- list() +# priors <- list() +# prior_aux <- list() +# for (prior in varnames) { +# if (prior == "(Intercept)") { +# prior_intercept$mean <- mean(posteriors[[prior]]) +# prior_intercept$sd <- sd(posteriors[[prior]]) +# } else if (prior %in% fixed_effects) { +# priors[[prior]] <- list() +# priors[[prior]]$mean <- mean(posteriors[[prior]]) +# priors[[prior]]$sd <- sd(posteriors[[prior]]) +# } else { +# prior_aux[[prior]] <- list() +# prior_aux[[prior]]$mean <- mean(posteriors[[prior]]) +# prior_aux[[prior]]$sd <- sd(posteriors[[prior]]) +# } +# } +# +# +# prior_intercept <- rstanarm::normal( +# prior_intercept$mean, +# prior_intercept$sd, +# autoscale = autoscale +# ) +# prior <- .format_priors(priors, autoscale = autoscale) +# prior_aux <- .format_priors(prior_aux, autoscale = autoscale) +# +# return(list(prior_intercept = prior_intercept, prior = prior, priox_aux = prior_aux)) +# } - prior_intercept <- rstanarm::normal( - prior_intercept$mean, - prior_intercept$sd, - autoscale = autoscale - ) - prior <- .format_priors(priors, autoscale = autoscale) - prior_aux <- .format_priors(prior_aux, autoscale = autoscale) - return(list(prior_intercept = prior_intercept, prior = prior, priox_aux = prior_aux)) -} - - -#' @keywords internal -.format_priors <- function(priors, autoscale = FALSE) { - prior_mean <- data.frame(priors) %>% - select(contains("mean")) %>% - tidyr::gather() %>% - select_("value") %>% - pull() - - prior_sd <- data.frame(priors) %>% - select(contains("sd")) %>% - tidyr::gather() %>% - select_("value") %>% - pull() - - prior <- rstanarm::normal( - prior_mean, - prior_sd, - autoscale = autoscale - ) -} +# .format_priors <- function(priors, autoscale = FALSE) { +# prior_mean <- data.frame(priors) %>% +# select(contains("mean")) %>% +# tidyr::gather() %>% +# select_("value") %>% +# pull() +# +# prior_sd <- data.frame(priors) %>% +# select(contains("sd")) %>% +# tidyr::gather() %>% +# select_("value") %>% +# pull() +# +# prior <- rstanarm::normal( +# prior_mean, +# prior_sd, +# autoscale = autoscale +# ) +# } @@ -239,7 +202,7 @@ percentile_to_z <- function(percentile) { #' #' @author \href{https://dominiquemakowski.github.io/}{Dominique Makowski} #' -#' @importFrom stats model.frame +#' @importFrom stats model.frame update #' @import dplyr #' @export power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, groups = NULL, verbose = TRUE, CI = 90) { @@ -282,7 +245,7 @@ power_analysis <- function(fit, n_max, n_min = NULL, step = 1, n_batch = 1, grou } # Progress if (verbose == TRUE) { - cat(paste0(format_digit(round((n - n_min) / (n_max - n_min) * 100)), "%\n")) + cat(paste0(insight::format_value(round((n - n_min) / (n_max - n_min) * 100)), "%\n")) } } return(results) diff --git a/R/startup_message.R b/R/startup_message.R index 613a53c..3990ca9 100644 --- a/R/startup_message.R +++ b/R/startup_message.R @@ -1,3 +1,3 @@ .onAttach <- function(libname, pkgname) { - packageStartupMessage("message: Many functions of the psycho package have been (improved and) moved to other packages of the new 'easystats' collection (https://github.com/easystats). If you don't find where a function is gone, please open an issue at: https://github.com/easystats/easystats/issues") + packageStartupMessage("Note: Many functions of the 'psycho' package have been (improved and) moved to other packages of the new 'easystats' collection (https://github.com/easystats). If you don't find where a function is gone, please open an issue at: https://github.com/easystats/easystats/issues") } diff --git a/man/assess.Rd b/man/assess.Rd index 68c0ceb..f8733aa 100644 --- a/man/assess.Rd +++ b/man/assess.Rd @@ -4,11 +4,23 @@ \alias{assess} \title{Compare a patient's score to a control group} \usage{ -assess(patient, mean = 0, sd = 1, n = NULL, controls = NULL, - CI = 95, treshold = 0.05, iter = 10000, - color_controls = "#2196F3", color_CI = "#E91E63", - color_score = "black", color_size = 2, alpha_controls = 1, - alpha_CI = 0.8, verbose = TRUE) +assess( + patient, + mean = 0, + sd = 1, + n = NULL, + controls = NULL, + CI = 95, + treshold = 0.05, + iter = 10000, + color_controls = "#2196F3", + color_CI = "#E91E63", + color_score = "black", + color_size = 2, + alpha_controls = 1, + alpha_CI = 0.8, + verbose = TRUE +) } \arguments{ \item{patient}{Single value (patient's score).} diff --git a/man/crawford.test.Rd b/man/crawford.test.Rd index 717bd8d..362af97 100644 --- a/man/crawford.test.Rd +++ b/man/crawford.test.Rd @@ -4,11 +4,22 @@ \alias{crawford.test} \title{Crawford-Garthwaite (2007) Bayesian test for single-case analysis.} \usage{ -crawford.test(patient, controls = NULL, mean = NULL, sd = NULL, - n = NULL, CI = 95, treshold = 0.1, iter = 10000, - color_controls = "#2196F3", color_CI = "#E91E63", - color_score = "black", color_size = 2, alpha_controls = 1, - alpha_CI = 0.8) +crawford.test( + patient, + controls = NULL, + mean = NULL, + sd = NULL, + n = NULL, + CI = 95, + treshold = 0.1, + iter = 10000, + color_controls = "#2196F3", + color_CI = "#E91E63", + color_score = "black", + color_size = 2, + alpha_controls = 1, + alpha_CI = 0.8 +) } \arguments{ \item{patient}{Single value (patient's score).} diff --git a/man/crawford_dissociation.test.Rd b/man/crawford_dissociation.test.Rd index 35c3199..610306d 100644 --- a/man/crawford_dissociation.test.Rd +++ b/man/crawford_dissociation.test.Rd @@ -4,8 +4,13 @@ \alias{crawford_dissociation.test} \title{Crawford-Howell (1998) modified t-test for testing difference between a patient’s performance on two tasks.} \usage{ -crawford_dissociation.test(case_X, case_Y, controls_X, controls_Y, - verbose = TRUE) +crawford_dissociation.test( + case_X, + case_Y, + controls_X, + controls_Y, + verbose = TRUE +) } \arguments{ \item{case_X}{Single value (patient's score on test X).} diff --git a/man/dprime.Rd b/man/dprime.Rd index 0dfcb30..9e39343 100644 --- a/man/dprime.Rd +++ b/man/dprime.Rd @@ -4,8 +4,15 @@ \alias{dprime} \title{Dprime (d') and Other Signal Detection Theory indices.} \usage{ -dprime(n_hit, n_fa, n_miss = NULL, n_cr = NULL, n_targets = NULL, - n_distractors = NULL, adjusted = TRUE) +dprime( + n_hit, + n_fa, + n_miss = NULL, + n_cr = NULL, + n_targets = NULL, + n_distractors = NULL, + adjusted = TRUE +) } \arguments{ \item{n_hit}{Number of hits.} diff --git a/man/find_combinations.formula.Rd b/man/find_combinations.formula.Rd index 2490ed0..acb7ee1 100644 --- a/man/find_combinations.formula.Rd +++ b/man/find_combinations.formula.Rd @@ -4,8 +4,7 @@ \alias{find_combinations.formula} \title{Generate all combinations of predictors of a formula.} \usage{ -\method{find_combinations}{formula}(object, interaction = TRUE, - fixed = NULL, ...) +\method{find_combinations}{formula}(object, interaction = TRUE, fixed = NULL, ...) } \arguments{ \item{object}{Formula.} diff --git a/man/find_matching_string.Rd b/man/find_matching_string.Rd index 7355950..98938a5 100644 --- a/man/find_matching_string.Rd +++ b/man/find_matching_string.Rd @@ -4,8 +4,7 @@ \alias{find_matching_string} \title{Fuzzy string matching.} \usage{ -find_matching_string(x, y, value = TRUE, step = 0.1, - ignore.case = TRUE) +find_matching_string(x, y, value = TRUE, step = 0.1, ignore.case = TRUE) } \arguments{ \item{x}{Strings.} diff --git a/man/find_season.Rd b/man/find_season.Rd index 024bc1b..e9096d4 100644 --- a/man/find_season.Rd +++ b/man/find_season.Rd @@ -4,8 +4,13 @@ \alias{find_season} \title{Find season of dates.} \usage{ -find_season(dates, winter = "12-21", spring = "3-20", - summer = "6-21", fall = "9-22") +find_season( + dates, + winter = "12-21", + spring = "3-20", + summer = "6-21", + fall = "9-22" +) } \arguments{ \item{dates}{Array of dates.} diff --git a/man/format_digit.Rd b/man/format_digit.Rd deleted file mode 100644 index 8f7a80d..0000000 --- a/man/format_digit.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/format_digit.R -\name{format_digit} -\alias{format_digit} -\title{Formatting} -\usage{ -format_digit(x, digits = 2) -} -\arguments{ -\item{x}{number.} - -\item{digits}{number of significant digits.} -} -\description{ -Formatting -} -\examples{ - -format_digit(1.20) -format_digit(1.2) -format_digit(1.2012313) -format_digit(0.0045) - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/format_formula.Rd b/man/format_formula.Rd deleted file mode 100644 index 05912af..0000000 --- a/man/format_formula.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{format_formula} -\alias{format_formula} -\title{Clean and format formula.} -\usage{ -format_formula(formula) -} -\arguments{ -\item{formula}{formula} - -\item{...}{Arguments passed to or from other methods.} -} -\description{ -Clean and format formula. -} -\examples{ -library(psycho) -library(lme4) - -fit <- lm(hp ~ wt, data = mtcars) - -format_formula(fit$call$formula) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_R2_posterior.Rd b/man/interpret_R2_posterior.Rd deleted file mode 100644 index 3b1bc12..0000000 --- a/man/interpret_R2_posterior.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/interpret_posterior.R -\name{interpret_R2_posterior} -\alias{interpret_R2_posterior} -\title{R2 interpreation for a posterior distribution.} -\usage{ -interpret_R2_posterior(posterior, rules = "cohen1988") -} -\arguments{ -\item{posterior}{Distribution of R2.} - -\item{rules}{Can be "cohen1988" (default), "chin1998" or "hair2013", or a custom list.} -} -\description{ -Interpret R2 with a set of rules. -} -\examples{ -library(psycho) -posterior <- rnorm(1000, 0.4, 0.1) -interpret_R2_posterior(posterior) -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/interpret_blavaan.Rd b/man/interpret_blavaan.Rd deleted file mode 100644 index e43b9af..0000000 --- a/man/interpret_blavaan.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{interpret_blavaan} -\alias{interpret_blavaan} -\title{Interpret fit measures of blavaan objects} -\usage{ -interpret_blavaan(fit, indices = c("BIC", "DIC", "WAIC", "LOOIC"), ...) -} -\arguments{ -\item{fit}{A blavaan model.} - -\item{indices}{Vector of strings indicating which indices to report. Only works for bayesian objects for now.} - -\item{...}{Other arguments.} -} -\description{ -Interpret fit measures of blavaan objects -} diff --git a/man/model_to_priors.Rd b/man/model_to_priors.Rd deleted file mode 100644 index b2cd060..0000000 --- a/man/model_to_priors.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/miscellaneous.R -\name{model_to_priors} -\alias{model_to_priors} -\title{Model to Prior.} -\usage{ -model_to_priors(fit, autoscale = FALSE) -} -\arguments{ -\item{fit}{A stanreg model.} - -\item{autoscale}{Set autoscale.} -} -\description{ -Convert a Bayesian model's results to priors. -} -\examples{ -\dontrun{ -library(rstanarm) -library(psycho) - -fit <- stan_glm(Sepal.Length ~ Petal.Width, data = iris) -priors <- model_to_priors(fit) -update(fit, prior = priors$prior) - -fit <- stan_glmer(Subjective_Valence ~ Emotion_Condition + (1 | Participant_ID), - data = psycho::emotion -) -priors <- model_to_priors(fit) - -fit1 <- stan_glm(Subjective_Valence ~ Emotion_Condition, - data = filter(psycho::emotion, Participant_ID == "1S") -) - -fit2 <- stan_glm(Subjective_Valence ~ Emotion_Condition, - data = filter(psycho::emotion, Participant_ID == "1S"), - prior = priors$prior, prior_intercept = priors$prior_intercept -) -} - -} -\author{ -\href{https://dominiquemakowski.github.io/}{Dominique Makowski} -} diff --git a/man/power_analysis.Rd b/man/power_analysis.Rd index 1e98772..d9be472 100644 --- a/man/power_analysis.Rd +++ b/man/power_analysis.Rd @@ -4,8 +4,16 @@ \alias{power_analysis} \title{Power analysis for fitted models.} \usage{ -power_analysis(fit, n_max, n_min = NULL, step = 1, n_batch = 1, - groups = NULL, verbose = TRUE, CI = 90) +power_analysis( + fit, + n_max, + n_min = NULL, + step = 1, + n_batch = 1, + groups = NULL, + verbose = TRUE, + CI = 90 +) } \arguments{ \item{fit}{A lm or stanreg model.} diff --git a/man/simulate_data_regression.Rd b/man/simulate_data_regression.Rd deleted file mode 100644 index 4192358..0000000 --- a/man/simulate_data_regression.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/deprecated.R -\name{simulate_data_regression} -\alias{simulate_data_regression} -\title{Simulates data for single or multiple regression.} -\usage{ -simulate_data_regression(coefs = 0.5, sample = 100, error = 0) -} -\arguments{ -\item{coefs}{Desired theorethical coefs. Can be a single value or a list.} - -\item{sample}{Desired sample size.} - -\item{error}{The error (standard deviation of gaussian noise).} -} -\description{ -Simulates data for single or multiple regression. -} -\details{ -See https://stats.stackexchange.com/questions/59062/multiple-linear-regression-simulation -} -\examples{ -library(psycho) - -data <- simulate_data_regression(coefs = c(0.1, 0.8), sample = 50, error = 0) -fit <- lm(y ~ ., data = data) -coef(fit) -} -\author{ -TPArrow -} diff --git a/vignettes/bayesian.R b/vignettes/bayesian.R deleted file mode 100644 index 84bb0c5..0000000 --- a/vignettes/bayesian.R +++ /dev/null @@ -1,333 +0,0 @@ -## ---- echo=F, message=FALSE, warning=FALSE------------------------------- -library(knitr) -library(rstanarm) -library(emmeans) -library(dplyr) -library(tidyr) -library(ggplot2) -library(psycho) -options(mc.cores=1) - -## ----message=FALSE, warning=FALSE, include=FALSE------------------------- -X <- psycho::standardize(psycho::affective$Concealing) -Y <- psycho::standardize(psycho::affective$Life_Satisfaction) -r <- cor.test(X, Y)$estimate -p <- cor.test(X, Y)$p.value -fit <- rstanarm::stan_glm(Y ~ X, seed=666, data=data.frame(Y,X)) -values <- values(analyze(fit)) -posterior <- values$effects$X$posterior -density <- density(posterior, n = length(posterior)) -hdi <- HDI(posterior, 0.90) -mpe <- mpe(posterior)$MPE - -## ----echo=FALSE, message=FALSE, warning=FALSE, fig.width=7, fig.height=4.5, fig.align='center', fig.cap="Posterior probability distribution of the correlation between X and Y"---- -ggplot(data.frame(x = density$x, y = density$y), aes(x=x, y=y)) + - xlab("\nPosterior Distribution of Correlation") + - ylab("Density") + - annotate("rect", xmin = hdi$values$HDImin, xmax=hdi$values$HDImax, ymin = 0, ymax=round(max(density$y)), fill="#2196F3", alpha = .5) + - geom_segment(aes(xend = x, yend = 0, colour = x), alpha=0.8) + - scale_color_gradientn(colours = c("#E91E63", "#E91E63", "#4CAF50", "#4CAF50"), - values=c(0, 0.4999, 0.5, 1), - guide=F, - limits = c(-1.5, 1.5)) + - # r - geom_vline(xintercept=r, color="#4CAF50") + - annotate("segment", x = r+0.05, xend = r, y = 10, yend = 10, size=0.1, arrow=arrow(type="closed", length = unit(0.10, "inches")), color="#4CAF50") + - annotate("text", x = r+0.055, y = 10, label = "Frequentist r Coefficient" , size=4 , fontface="bold", hjust = 0, color="#4CAF50") + - # median - geom_vline(xintercept=median(posterior)) + - annotate("segment", x = median(posterior)+0.05, xend = median(posterior), y = 8, yend = 8, colour = "black", size=0.1, arrow=arrow(type="closed", length = unit(0.10, "inches"))) + - annotate("text", x = median(posterior)+0.055, y = 8, label = "Posterior's Median" , size=4 , fontface="bold", hjust = 0) + - # # mean - # geom_vline(xintercept=mean(posterior), color="#2196F3") + - # annotate("segment", x = mean(posterior)+0.03, xend = r, y = 6, yend = 6, size=0.1, arrow=arrow(type="closed", length = unit(0.10, "inches")), color="#2196F3") + - # annotate("text", x = mean(posterior)+0.035, y = 6, label = "mean" , size=4 , fontface="bold", hjust = 0, color="#2196F3") - annotate("segment", x = hdi$values$HDImin, xend = hdi$values$HDImax, y = 3, yend = 3, size=0.3, arrow=arrow(type="closed", ends="both", length = unit(0.10, "inches")), color="#2196F3") + - annotate("text", x = -0.01, y = 3, label = "90% Credible Interval" , size=4 , fontface="bold", hjust = 0, color="#2196F3") - -## ---- echo=T, message=FALSE, warning=FALSE, results='hide'--------------- -library(rstanarm) -library(dplyr) -library(ggplot2) -library(psycho) - -df <- psycho::affective -summary(df) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -summary(df) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, data=df) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -knitr::kable(summary(results, round = 2)) - -## ----echo=TRUE, message=FALSE, warning=FALSE----------------------------- -print(results) - -## ----echo=T, message=FALSE, warning=FALSE-------------------------------- -refgrid <- df %>% - select(Tolerating) %>% - psycho::refdata(length.out=10) - -predicted <- psycho::get_predicted(fit, newdata=refgrid) - -## ----echo=T, message=FALSE, warning=FALSE, results='hide'---------------- -predicted - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -kable(predicted) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA---- -ggplot(predicted, aes(x=Tolerating, y=Life_Satisfaction_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Life_Satisfaction_CI_5, - ymax=Life_Satisfaction_CI_95), - alpha=0.1) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Salary, data=df) - -## ---- message=FALSE, warning=FALSE--------------------------------------- -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -print(results) - -## ----echo=T, message=FALSE, warning=FALSE, results='hide'---------------- -psycho::get_means(fit) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -kable(psycho::get_means(fit), digits=2) - -## ----echo=T, message=FALSE, warning=FALSE, results='hide'---------------- -psycho::get_contrasts(fit) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -kable(psycho::get_contrasts(fit), digits=2) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA---- -psycho::get_means(fit) %>% - ggplot(aes(x=Level, y=Median, group=1)) + - geom_line() + - geom_pointrange(aes(ymin=CI_lower, ymax=CI_higher)) + - ylab("Life Satisfaction") + - xlab("Salary") - -## ---- message=FALSE, results="hide"-------------------------------------- -# Let's fit our model -fit <- rstanarm::stan_glm(Sex ~ Adjusting, data=df, family = "binomial") - -## ---- message=FALSE, results="hide"-------------------------------------- -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -knitr::kable(summary(results, round = 2)) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -levels(df$Sex) - -## ----echo=T, message=FALSE, warning=FALSE-------------------------------- -refgrid <- df %>% - select(Adjusting) %>% - psycho::refdata(length.out=10) - -predicted <- psycho::get_predicted(fit, newdata=refgrid) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA---- -ggplot(predicted, aes(x=Adjusting, y=Sex_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Sex_CI_5, - ymax=Sex_CI_95), - alpha=0.1) + - ylab("Probability of being a male") - -## ---- message=FALSE, results="hide"-------------------------------------- -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Concealing * Sex, data=df) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -kable(summary(results, round = 2)) - -## ----echo=T, message=FALSE, warning=FALSE, results="hide"---------------- -refgrid <- df %>% - select(Concealing, Sex) %>% - psycho::refdata(length.out=10) - -predicted <- psycho::get_predicted(fit, newdata=refgrid) -predicted - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -kable(predicted) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA---- -ggplot(predicted, aes(x=Concealing, y=Life_Satisfaction_Median, fill=Sex)) + - geom_line(aes(colour=Sex)) + - geom_ribbon(aes(fill=Sex, - ymin=Life_Satisfaction_CI_5, - ymax=Life_Satisfaction_CI_95), - alpha=0.1) + - ylab("Life Satisfaction") - -## ----eval=FALSE, message=FALSE, warning=FALSE, eval=FALSE---------------- -# # Let's fit our model (it takes more time) -# fit <- rstanarm::stan_lmer(Concealing ~ Age + (1|Salary), data=df) - -## ----message=FALSE, warning=FALSE, include=FALSE, results="hide"--------- -# Let's fit our model (it takes more time) -fit <- rstanarm::stan_lmer(Concealing ~ Age + (1|Salary), data=df, iter=500, chains=2, seed=666) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -kable(summary(results, round = 2)) - -## ----echo=T, message=FALSE, warning=FALSE-------------------------------- -refgrid <- df %>% - select(Age) %>% - psycho::refdata(length.out=10) - -# We name the predicted dataframe by adding '_linear' to keep it for further comparison (see next part) -predicted_linear <- psycho::get_predicted(fit, newdata=refgrid) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA---- -ggplot(predicted_linear, aes(x=Age, y=Concealing_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - alpha=0.1) - -## ----message=FALSE, warning=FALSE, include=FALSE, results="hide"--------- -# Let's fit our model (it takes more time) -fit <- rstanarm::stan_lmer(Concealing ~ poly(Age, 2, raw=TRUE) + (1|Salary), data=df, iter=500, chains=2) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Format the results using analyze() -results <- psycho::analyze(fit) - -# We can extract a formatted summary table -summary(results, round = 2) - -## ----echo=FALSE, message=FALSE, warning=FALSE---------------------------- -knitr::kable(summary(results, round = 2)) - -## ----echo=T, message=FALSE, warning=FALSE-------------------------------- -refgrid <- df %>% - select(Age) %>% - psycho::refdata(length.out=20) - -predicted_poly <- psycho::get_predicted(fit, newdata=refgrid) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA---- -ggplot(predicted_poly, aes(x=Age, y=Concealing_Median)) + - geom_line() + - geom_ribbon(aes(ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - alpha=0.1) - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA, message=FALSE, warning=FALSE---- -p <- ggplot() + - # Linear model - geom_line(data=predicted_linear, - aes(x=Age, y=Concealing_Median), - colour="blue", - size=1) + - geom_ribbon(data=predicted_linear, - aes(x=Age, - ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - alpha=0.1, - fill="blue") + - # Polynormial Model - geom_line(data=predicted_poly, - aes(x=Age, y=Concealing_Median), - colour="red", - size=1) + - geom_ribbon(data=predicted_poly, - aes(x=Age, - ymin=Concealing_CI_5, - ymax=Concealing_CI_95), - fill="red", - alpha=0.1) + - # Actual data - geom_point(data=df, aes(x=Age, y=Concealing)) - -library(plotly) # To create interactive plots -ggplotly(p) # To transform a ggplot into an interactive plot - -## ---- message=FALSE, results="hide"-------------------------------------- -# Standardize (scale and center) the numeric variables -dfZ <- psycho::standardize(df) - -## ---- message=FALSE, results="hide"-------------------------------------- -# Let's fit our model -fit <- rstanarm::stan_glm(Life_Satisfaction ~ Tolerating, - data=dfZ, - prior=normal(location = 0, # Mean - scale = 1, # SD - autoscale=FALSE)) # Don't adjust scale automatically - -## ---- message=FALSE, results="hide"-------------------------------------- -results <- psycho::analyze(fit) - -# Extract the posterior -posterior <- results$values$effects$Tolerating$posterior - -# Create a posterior with the prior and posterior distribution and plot them. -data.frame(posterior = posterior, - prior = rnorm(length(posterior), 0, 1)) %>% - ggplot() + - geom_density(aes(x=posterior), fill="lightblue", alpha=0.5) + - geom_density(aes(x=prior), fill="blue", alpha=0.5) + - scale_y_sqrt() # Change the Y axis so the plot is less ugly - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='hide', fig.align='center', comment=NA, message=FALSE, warning=FALSE---- -# Fit the model -fit <- rstanarm::stan_glm(Sex ~ Adjusting, data=df, family = "binomial") - -## ---- fig.width=7, fig.height=4.5, eval = TRUE, results='markup', fig.align='center', comment=NA, message=FALSE, warning=FALSE---- -# Generate a new refgrid -refgrid <- df %>% - select(Adjusting) %>% - psycho::refdata(length.out=10) - -# Get predictions and keep iterations -predicted <- psycho::get_predicted(fit, newdata=refgrid, keep_iterations=TRUE) - -# Reshape this dataframe to have iterations as factor -predicted <- predicted %>% - tidyr::gather(Iteration, Iteration_Value, starts_with("iter")) - -# Plot iterations as well as the median prediction -ggplot(predicted, aes(x=Adjusting)) + - geom_line(aes(y=Iteration_Value, group=Iteration), size=0.3, alpha=0.01) + - geom_line(aes(y=Sex_Median), size=1) + - ylab("Male Probability\n") - diff --git a/vignettes/bayesian.Rmd b/vignettes/bayesian.Rmd index 7ee9325..73864a4 100644 --- a/vignettes/bayesian.Rmd +++ b/vignettes/bayesian.Rmd @@ -11,10 +11,6 @@ abstract: | Why use frequentist methods when you can use, in an even simpler way, the Bayesian framework? Throughout this tutorial, we will explore many of the analyses you might want to do with your data. vignette: > %\VignetteIndexEntry{BayesianPsychology} - %\VignetteDepends{dplyr} - %\VignetteDepends{tidyr} - %\VignetteDepends{ggplot2} - %\VignetteDepends{plotly} \usepackage[utf8]{inputenc} %\VignetteEngine{knitr::rmarkdown} editor_options: @@ -23,21 +19,6 @@ editor_options: ------- - - - - - - - - - - - - - - # The Bayesian Framework diff --git a/vignettes/bayesian.html b/vignettes/bayesian.html deleted file mode 100644 index fb31cbb..0000000 --- a/vignettes/bayesian.html +++ /dev/null @@ -1,269 +0,0 @@ - - - - - - - - - - - - - - - - -Bayesian Analysis in Psychology - - - - - - - - - - - - - - - - -

    Bayesian Analysis in Psychology

    -

    Dominique Makowski

    -

    2019-03-29

    -
    -

    Abstract

    -Why use frequentist methods when you can use, in an even simpler way, the Bayesian framework? Throughout this tutorial, we will explore many of the analyses you might want to do with your data. -
    - - - - -
    - - - - - - - - - - -
    -

    The Bayesian Framework

    -

    The vignette was updated and is available here.

    -
    - - - - - - - - diff --git a/vignettes/overview.R b/vignettes/overview.R deleted file mode 100644 index 941ea41..0000000 --- a/vignettes/overview.R +++ /dev/null @@ -1,21 +0,0 @@ -## ---- echo=F, message=FALSE, warning=FALSE------------------------------- -library(knitr) -library(dplyr) -library(ggplot2) -library(rstanarm) - -## ---- out.width=700, echo = FALSE, eval = TRUE, fig.align='center'------- -knitr::include_graphics("images/workflow.PNG") - -## ---- eval = FALSE------------------------------------------------------- -# # This for the stable version: -# install.packages("psycho") -# -# # Or this for the dev version: -# install.packages("devtools") -# library(devtools) -# devtools::install_github("neuropsychology/psycho.R") - -## ------------------------------------------------------------------------ -library(psycho) - diff --git a/vignettes/overview.Rmd b/vignettes/overview.Rmd index 4d2d6ee..caf5a2a 100644 --- a/vignettes/overview.Rmd +++ b/vignettes/overview.Rmd @@ -26,9 +26,6 @@ vignette: > ```{r, echo=F, message=FALSE, warning=FALSE} library(knitr) -library(dplyr) -library(ggplot2) -library(rstanarm) ``` diff --git a/vignettes/overview.html b/vignettes/overview.html deleted file mode 100644 index a867597..0000000 --- a/vignettes/overview.html +++ /dev/null @@ -1,479 +0,0 @@ - - - - - - - - - - - - - - - - -psycho for R - - - - - - - - - - - - - - - - - - - -

    psycho for R

    -

    Dominique Makowski

    -

    2019-03-29

    -
    -

    Abstract

    -Psycho is an R package that aims at providing tools for psychologists, neuropsychologists and neuroscientists, to transform statistical outputs into something readable that can be, almost directly, copied and pasted into a report. It also implements various functions useful in psychological science, such as correlation matrices, assessment plot creation or normalization. The package revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. Four functions can then be applied on a psychobject: summary(), print(), plot() and values(). Contrary to many other packages which goal is to produce statistical analyzes, psycho aims at filling the gap between statistical R outputs and statistical report writing, with a focus on APA formatting guidelines, to enhance the standardization of results reporting. Complex outputs, such as those of Bayesian and frequentist mixed models, are automatically transformed into readable text, tables, and plots that illustrate the effects. Thus, the results can easily be incorporated into shareable reports and publications, promoting data exploration, saving time and preventing errors for better, reproducible, science. -
    - - - - -
    -
    -

    Overview

    -

    The package mainly revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. 4 functions can be then applied on a psychobject: summary(), print(), plot() and values().

    -

    -
    -
    -

    Installation

    -
    -

    Install R and R Studio

    - -
    -
    -

    Install the psycho package

    -

    If you’ve never used psycho, enter one of the following in the console and press enter:

    - -

    In case of error: Sometimes the installation fails, and you might find in the red output the following lines:

    - -

    Try installing the missing packages (install.packages("thenameofapackage")) and then, install psycho again (sometimes this can be done several times).

    -

    Anyway, once you have psycho, just put this at the beginning of every script:

    - - -
    -
    -
    - - -
    -

    Credits

    -

    This package helped you? Don’t forget to cite the various packages you used :)

    -

    You can cite psycho as follows:

    -
      -
    • Makowski, (2018). The psycho Package: An Efficient and Publishing-Oriented Workflow for Psychological Science. Journal of Open Source Software, 3(22), 470. https://doi.org/10.21105/joss.00470
      • -
    -
    -
    -

    Contribution

    -

    Improve this vignette by modifying this file!

    -
    - - - - - - - - From d7a02f93dcb96922261a92c1d7e06f0720230b89 Mon Sep 17 00:00:00 2001 From: Dominique Makowski Date: Wed, 22 Jan 2020 11:23:56 +0800 Subject: [PATCH 4/4] go back to 0.5.0 --- DESCRIPTION | 2 +- vignettes/bayesian.html | 262 ++++++++++++++++++++++ vignettes/overview.R | 18 ++ vignettes/overview.html | 483 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 764 insertions(+), 1 deletion(-) create mode 100644 vignettes/bayesian.html create mode 100644 vignettes/overview.R create mode 100644 vignettes/overview.html diff --git a/DESCRIPTION b/DESCRIPTION index 1a9303f..a88f5a6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: psycho Type: Package Title: Efficient and Publishing-Oriented Workflow for Psychological Science -Version: 0.5.1 +Version: 0.5.0 Authors@R: c( person("Dominique", "Makowski", diff --git a/vignettes/bayesian.html b/vignettes/bayesian.html new file mode 100644 index 0000000..059930b --- /dev/null +++ b/vignettes/bayesian.html @@ -0,0 +1,262 @@ + + + + + + + + + + + + + + + + +Bayesian Analysis in Psychology + + + + + + + + + + + + + + + + + + + +

    Bayesian Analysis in Psychology

    +

    Dominique Makowski

    +

    2020-01-22

    +
    +

    Abstract

    +

    Why use frequentist methods when you can use, in an even simpler way, the Bayesian framework? Throughout this tutorial, we will explore many of the analyses you might want to do with your data.

    +
    + + + + +
    +

    The Bayesian Framework

    +

    The vignette was updated and is available here.

    +
    + + + + + + + + + + + diff --git a/vignettes/overview.R b/vignettes/overview.R new file mode 100644 index 0000000..0b20a89 --- /dev/null +++ b/vignettes/overview.R @@ -0,0 +1,18 @@ +## ---- echo=F, message=FALSE, warning=FALSE------------------------------------ +library(knitr) + +## ---- out.width=700, echo = FALSE, eval = TRUE, fig.align='center'------------ +knitr::include_graphics("images/workflow.PNG") + +## ---- eval = FALSE------------------------------------------------------------ +# # This for the stable version: +# install.packages("psycho") +# +# # Or this for the dev version: +# install.packages("devtools") +# library(devtools) +# devtools::install_github("neuropsychology/psycho.R") + +## ----------------------------------------------------------------------------- +library(psycho) + diff --git a/vignettes/overview.html b/vignettes/overview.html new file mode 100644 index 0000000..059e173 --- /dev/null +++ b/vignettes/overview.html @@ -0,0 +1,483 @@ + + + + + + + + + + + + + + + + +psycho for R + + + + + + + + + + + + + + + + + + + + + + +

    psycho for R

    +

    Dominique Makowski

    +

    2020-01-22

    +
    +

    Abstract

    +

    Psycho is an R package that aims at providing tools for psychologists, neuropsychologists and neuroscientists, to transform statistical outputs into something readable that can be, almost directly, copied and pasted into a report. It also implements various functions useful in psychological science, such as correlation matrices, assessment plot creation or normalization. The package revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. Four functions can then be applied on a psychobject: summary(), print(), plot() and values(). Contrary to many other packages which goal is to produce statistical analyzes, psycho aims at filling the gap between statistical R outputs and statistical report writing, with a focus on APA formatting guidelines, to enhance the standardization of results reporting. Complex outputs, such as those of Bayesian and frequentist mixed models, are automatically transformed into readable text, tables, and plots that illustrate the effects. Thus, the results can easily be incorporated into shareable reports and publications, promoting data exploration, saving time and preventing errors for better, reproducible, science.

    +
    + + + + +
    +
    +

    Overview

    +

    The package mainly revolves around the psychobject. Main functions from the package return this type, and the analyze() function transforms other R objects into psychobjects. 4 functions can be then applied on a psychobject: summary(), print(), plot() and values().

    +

    +
    +
    +

    Installation

    +
    +

    Install R and R Studio

    + +
    +
    +

    Install the psycho package

    +

    If you’ve never used psycho, enter one of the following in the console and press enter:

    + +

    In case of error: Sometimes the installation fails, and you might find in the red output the following lines:

    + +

    Try installing the missing packages (install.packages("thenameofapackage")) and then, install psycho again (sometimes this can be done several times).

    +

    Anyway, once you have psycho, just put this at the beginning of every script:

    + + +
    +
    +
    + + +
    +

    Credits

    +

    This package helped you? Don’t forget to cite the various packages you used :)

    +

    You can cite psycho as follows:

    +
      +
    • Makowski, (2018). The psycho Package: An Efficient and Publishing-Oriented Workflow for Psychological Science. Journal of Open Source Software, 3(22), 470. https://doi.org/10.21105/joss.00470
      • +
    +
    +
    +

    Contribution

    +

    Improve this vignette by modifying this file!

    +
    + + + + + + + + + + +