...
 
Commits (14)
......@@ -2,8 +2,8 @@ Package: sjPlot
Type: Package
Encoding: UTF-8
Title: Data Visualization for Statistics in Social Science
Version: 2.6.0
Date: 2018-08-23
Version: 2.6.2
Date: 2018-12-18
Authors@R: c(
person("Daniel", "Lüdecke", email = "d.luedecke@uke.de", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-8895-3206")),
person("Carsten", "Schwemmer", email = "carsten.schwemmer@uni-bamberg.de", role = "ctb")
......@@ -19,20 +19,20 @@ Description: Collection of plotting and table output functions for data
labelled data.
License: GPL-3
Depends: R (>= 3.2), graphics, grDevices, stats, utils
Imports: broom (>= 0.4.5), dplyr (>= 0.7.5), forcats, ggeffects (>=
0.5.0), glmmTMB, ggplot2 (>= 2.2.1), knitr, lme4 (>= 1.1-12),
magrittr, MASS, modelr, nlme, psych, purrr, rlang, scales,
sjlabelled (>= 1.0.13), sjmisc (>= 2.7.4), sjstats (>= 0.17.0),
tidyr (>= 0.7.0)
Suggests: AICcmodavg, brms, car, cluster, GPArotation, gridExtra,
ggrepel, ggridges, pscl, rstanarm, survey, TMB, Zelig, testthat
Imports: broom, dplyr (>= 0.7.5), forcats, ggeffects (>= 0.7.0),
glmmTMB, ggplot2 (>= 2.2.1), knitr, lme4 (>= 1.1-12), magrittr,
MASS, modelr, nlme, psych, purrr, rlang, scales, sjlabelled (>=
1.0.14), sjmisc (>= 2.7.6), sjstats (>= 0.17.2), tidyr (>=
0.7.0)
Suggests: brms, car, cluster, GPArotation, gridExtra, ggrepel,
ggridges, pscl, rstanarm, survey, TMB, Zelig, testthat
URL: https://strengejacke.github.io/sjPlot/
BugReports: https://github.com/strengejacke/sjPlot/issues
RoxygenNote: 6.1.0
RoxygenNote: 6.1.1
VignetteBuilder: knitr
NeedsCompilation: no
Packaged: 2018-08-23 16:17:25 UTC; Daniel
Packaged: 2018-12-18 16:39:15 UTC; Daniel
Author: Daniel Lüdecke [aut, cre] (<https://orcid.org/0000-0002-8895-3206>),
Carsten Schwemmer [ctb]
Repository: CRAN
Date/Publication: 2018-08-23 16:50:03 UTC
Date/Publication: 2018-12-18 17:10:03 UTC
This diff is collapsed.
......@@ -50,31 +50,17 @@ export(sjp.chi2)
export(sjp.corr)
export(sjp.fa)
export(sjp.frq)
export(sjp.glm)
export(sjp.glmer)
export(sjp.gpt)
export(sjp.grpfrq)
export(sjp.int)
export(sjp.kfold_cv)
export(sjp.likert)
export(sjp.lm)
export(sjp.lmer)
export(sjp.pca)
export(sjp.poly)
export(sjp.resid)
export(sjp.scatter)
export(sjp.stackfrq)
export(sjp.xtab)
export(sjplot)
export(sjplot_pal)
export(sjt.corr)
export(sjt.fa)
export(sjt.frq)
export(sjt.glm)
export(sjt.glmer)
export(sjt.itemanalysis)
export(sjt.lm)
export(sjt.lmer)
export(sjt.pca)
export(sjt.stackfrq)
export(sjt.xtab)
......@@ -95,7 +81,6 @@ importFrom(broom,tidy)
importFrom(dplyr,"%>%")
importFrom(dplyr,arrange)
importFrom(dplyr,between)
importFrom(dplyr,bind_cols)
importFrom(dplyr,bind_rows)
importFrom(dplyr,case_when)
importFrom(dplyr,filter)
......@@ -106,7 +91,6 @@ importFrom(dplyr,inner_join)
importFrom(dplyr,mutate)
importFrom(dplyr,n_distinct)
importFrom(dplyr,select)
importFrom(dplyr,select_)
importFrom(dplyr,slice)
importFrom(dplyr,summarise)
importFrom(dplyr,summarize)
......@@ -130,7 +114,6 @@ importFrom(graphics,plot)
importFrom(graphics,rect)
importFrom(knitr,asis_output)
importFrom(knitr,knit_print)
importFrom(lme4,VarCorr)
importFrom(lme4,getME)
importFrom(lme4,ranef)
importFrom(magrittr,"%>%")
......@@ -169,7 +152,9 @@ importFrom(sjlabelled,get_labels)
importFrom(sjlabelled,get_term_labels)
importFrom(sjlabelled,get_values)
importFrom(sjlabelled,set_labels)
importFrom(sjmisc,add_case)
importFrom(sjmisc,add_columns)
importFrom(sjmisc,add_variables)
importFrom(sjmisc,group_labels)
importFrom(sjmisc,group_var)
importFrom(sjmisc,is_empty)
......@@ -185,19 +170,15 @@ importFrom(sjmisc,std)
importFrom(sjmisc,str_contains)
importFrom(sjmisc,str_start)
importFrom(sjmisc,to_factor)
importFrom(sjmisc,to_label)
importFrom(sjmisc,to_value)
importFrom(sjmisc,trim)
importFrom(sjmisc,var_rename)
importFrom(sjmisc,var_type)
importFrom(sjmisc,word_wrap)
importFrom(sjmisc,zap_inf)
importFrom(sjstats,chisq_gof)
importFrom(sjstats,cod)
importFrom(sjstats,cramer)
importFrom(sjstats,cronb)
importFrom(sjstats,hdi)
importFrom(sjstats,hoslem_gof)
importFrom(sjstats,icc)
importFrom(sjstats,mean_n)
importFrom(sjstats,mic)
......@@ -211,7 +192,6 @@ importFrom(sjstats,reliab_test)
importFrom(sjstats,resp_val)
importFrom(sjstats,resp_var)
importFrom(sjstats,robust)
importFrom(sjstats,se)
importFrom(sjstats,std_beta)
importFrom(sjstats,table_values)
importFrom(sjstats,typical_value)
......@@ -247,9 +227,7 @@ importFrom(stats,kmeans)
importFrom(stats,kruskal.test)
importFrom(stats,lm)
importFrom(stats,loess)
importFrom(stats,logLik)
importFrom(stats,mad)
importFrom(stats,model.frame)
importFrom(stats,na.omit)
importFrom(stats,na.pass)
importFrom(stats,nobs)
......@@ -270,7 +248,6 @@ importFrom(stats,quantile)
importFrom(stats,rect.hclust)
importFrom(stats,residuals)
importFrom(stats,rstudent)
importFrom(stats,runif)
importFrom(stats,sd)
importFrom(stats,shapiro.test)
importFrom(stats,summary.lm)
......
# sjPlot 2.6.2
## General
* Revised some help-files and vignettes.
## Removed / Defunct
Following functions are now defunct:
* `sjt.lm()`, `sjt.glm()`, `sjt.lmer()` and `sjt.glmer()`. Please use `tab_model()` instead.
## Changes to functions
* `tab_model()` supports printing simplex parameters of monotonic effects of **brms** models.
* `tab_model()` gets a `prefix.labels`-argument to add a prefix to the labels of categorical terms.
* The `rotation`-argument in `sjt.pca()` and `sjp.pca()` now supports all rotations from `psych::principal()`.
## Bug fixes
* `plot_model()` no longer automatically changes the plot-type to `"slope"` for models with only one predictor that is categorical and has more than two levels.
* `type = "eff"` and `type = "pred"` in `plot_model()` did not work when `terms` was not specified.
* If robust standard errors are requested in `tab_model()`, the confidence intervals and p-values are now re-calculated and adjusted based on the robust standard errors.
* `colors = "bw"` was not recognized correctly for `plot_model(..., type = "int")`.
* Fix issue in `sjp.frq()` with correct axis labels for non-labelled character vectors.
# sjPlot 2.6.1
## General
* Removed defunct functions.
## Deprecated
* `sjt.lm()`, `sjt.glm()`, `sjt.lmer()` and `sjt.glmer()` are now deprecated. Please use `tab_model()` instead.
## Changes to functions
* Arguments `dot.size` and `line.size` in `plot_model()` now also apply to marginal effects and diagnostic plots.
* `plot_model()` now uses a free x-axis scale in facets for models with zero-inflated part.
* `plot_model()` now shows multiple plots for models with zero-inflated parts when `grids = FALSE`.
* `tab_model()` gets a `p.style` and `p.threshold` argument to indicate significance levels as asteriks, and to determine the threshold for which an estimate is considered as significant.
* `plot_model()` and `plot_models()` get a `p.threshold` argument to determine the threshold for which an estimate is considered as significant.
## Bug fixes
* Fixed bug from the last update that made value labels disappear for `plot_likert()`.
* `tab_model()` now also accepts multiple model-objects stored in a `list` as argument, as stated in the help-file.
* The `file`-argument now works again in `sjt.itemanalysis()`.
* Argument `show.ci` in `tab_model()` did not compute confidence intervals for different levels.
# sjPlot 2.6.0
## General
......
#' @title Deprecated functions
#' @name sjp.glmer
#'
#' @description A list of deprecated functions.
#'
#' @param ... Not used.
#' @return Nothing.
#'
#' @export
sjp.glmer <- function(...) {
.Defunct("plot_model", package = "sjPlot", msg = "`sjp.glmer()` is defunct. Please use `plot_model()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.glm <- function(...) {
.Defunct("plot_model", package = "sjPlot", msg = "`sjp.glm()` is defunct. Please use `plot_model()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.lmer <- function(...) {
.Defunct("plot_model", package = "sjPlot", msg = "`sjp.lmer()` is defunct. Please use `plot_model()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.lm <- function(...) {
.Defunct("plot_model", package = "sjPlot", msg = "`sjp.lm()` is defunct. Please use `plot_model()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.int <- function(...) {
.Defunct("plot_model", package = "sjPlot", msg = "`sjp.int()` is defunct. Please use `plot_model()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjt.frq <- function(...) {
.Defunct("frq", package = "sjmisc", msg = "`sjt.frq()` is defunct. Please use `sjmisc::frq()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.scatter <- function(...) {
.Defunct("plot_scatter", package = "sjPlot", msg = "`sjp.scatter()` is defunct. Please use `plot_scatter()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.resid <- function(...) {
.Defunct("plot_residuals", package = "sjPlot", msg = "`sjp.resid()` is defunct. Please use `plot_residuals()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.likert <- function(...) {
.Defunct("plot_likert", package = "sjPlot", msg = "`sjp.likert()` is defunct. Please use `plot_likert()` instead.")
}
#' @rdname sjp.glmer
#' @export
sjp.gpt <- function(...) {
.Defunct("plot_gpt", package = "sjPlot", msg = "`sjp.gpt()` is defunct. Please use `plot_gpt()` instead.")
}
......@@ -183,6 +183,11 @@ pgrpmean <- function(x, ...) {
attr(x, "p.value", exact = TRUE)
)
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
tab_df(
x = x,
title = title,
......@@ -192,12 +197,12 @@ pgrpmean <- function(x, ...) {
show.rownames = FALSE,
show.footnote = TRUE,
alternate.rows = FALSE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-top:1px solid; border-bottom: double;'
),
file = NULL,
file = file,
use.viewer = attr(x, "print", exact = TRUE) == "viewer",
...
)
......@@ -207,6 +212,10 @@ pgrpmean <- function(x, ...) {
#' @importFrom purrr map_chr
pgrpmeans <- function(x, ...) {
uv <- attr(x, "print", exact = TRUE) == "viewer"
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
titles <- purrr::map_chr(x, ~ sprintf(
"Mean for %s by %s<br><span class=\"subtitle\">grouped by %s</span>",
......@@ -233,12 +242,12 @@ pgrpmeans <- function(x, ...) {
show.rownames = FALSE,
show.footnote = TRUE,
alternate.rows = FALSE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-top:1px solid; border-bottom: double;'
),
file = NULL,
file = file,
use.viewer = uv,
...
)
......@@ -274,6 +283,11 @@ pequi_test <- function(x, ...) {
}
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
tab_df(
x = x,
title = "Test for Practical Equivalence of Model Parameters",
......@@ -283,13 +297,13 @@ pequi_test <- function(x, ...) {
show.rownames = FALSE,
show.footnote = TRUE,
alternate.rows = FALSE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-bottom: 1px solid;',
css.col3 = '+text-align:right;'
),
file = NULL,
file = file,
use.viewer = attr(x, "print", exact = TRUE) == "viewer",
...
)
......@@ -303,6 +317,11 @@ preliab <- function(x, ...) {
"Item Discrimination"
)
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
tab_df(
x = x,
title = "Reliability Test",
......@@ -312,12 +331,12 @@ preliab <- function(x, ...) {
show.rownames = FALSE,
show.footnote = FALSE,
alternate.rows = FALSE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-bottom: 1px solid;'
),
file = NULL,
file = file,
use.viewer = attr(x, "print", exact = TRUE) == "viewer",
...
)
......@@ -334,6 +353,10 @@ pdescr <- function(x, ...) {
if ("digits" %in% names(add.args)) digits <- eval(add.args[["digits"]])
uv <- attr(x, "print", exact = TRUE) == "viewer"
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
chead <- c(
"Variable",
......@@ -364,7 +387,7 @@ pdescr <- function(x, ...) {
show.rownames = FALSE,
show.footnote = FALSE,
alternate.rows = TRUE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-bottom: 1px solid;',
......@@ -372,7 +395,7 @@ pdescr <- function(x, ...) {
css.col2 = '+text-align:left;',
css.col3 = '+text-align:left;'
),
file = NULL,
file = file,
use.viewer = uv,
...
)
......@@ -394,6 +417,10 @@ pgdescr <- function(x, ...) {
if ("digits" %in% names(add.args)) digits <- eval(add.args[["digits"]])
uv <- attr(x, "print", exact = TRUE) == "viewer"
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
chead <- c(
"Variable",
......@@ -426,13 +453,13 @@ pgdescr <- function(x, ...) {
show.rownames = FALSE,
show.footnote = FALSE,
alternate.rows = TRUE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-bottom: 1px solid;',
css.col3 = '+text-align:left;'
),
file = NULL,
file = file,
use.viewer = uv,
...
)
......@@ -443,7 +470,13 @@ pgdescr <- function(x, ...) {
#' @importFrom dplyr n_distinct select
#' @importFrom sjmisc is_empty
pfrq <- function(x, ...) {
uv <- attr(x, "print", exact = TRUE) == "viewer"
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
titles <- purrr::map_chr(x, function(i) {
......@@ -497,7 +530,7 @@ pfrq <- function(x, ...) {
show.rownames = FALSE,
show.footnote = TRUE,
alternate.rows = FALSE,
encoding = "UTF-8",
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-bottom: 1px solid;',
......@@ -507,7 +540,7 @@ pfrq <- function(x, ...) {
css.col5 = 'text-align: right;',
css.col6 = 'text-align: right;'
),
file = NULL,
file = file,
use.viewer = uv,
...
)
......@@ -552,6 +585,11 @@ pmwu <- function(x, ...) {
)
}
enc <- attr(x, "encoding", exact = TRUE)
file <- attr(x, "file", exact = TRUE)
if (is.null(enc)) enc <- "UTF-8"
tab_df(
x = x$tab.df,
......@@ -562,7 +600,8 @@ pmwu <- function(x, ...) {
show.type = FALSE,
show.footnote = !is.null(fn),
alternate.rows = TRUE,
file = NULL,
file = file,
encoding = enc,
CSS = list(
css.firsttablecol = '+text-align:left;',
css.lasttablerow = 'border-bottom: 1px solid;'
......
......@@ -29,42 +29,6 @@ get_dot_data <- function(data, dots) {
dot_names <- function(dots) unname(unlist(lapply(dots, as.character)))
#' @importFrom sjmisc str_contains to_label to_value replace_na word_wrap
#' @importFrom sjstats resp_val resp_var
get_lm_data <- function(fit) {
if (inherits(fit, "plm")) {
# plm objects have different structure than (g)lm
fit_x <- data.frame(cbind(as.vector(fit$model[, 1]), stats::model.matrix(fit)))
# retrieve response vector
resp <- sjstats::resp_val(fit)
depvar.label <- sjstats::resp_var(fit)
} else if (inherits(fit, "pggls")) {
# plm objects have different structure than (g)lm
fit_x <- data.frame(fit$model)
depvar.label <- attr(attr(attr(fit$model, "terms"), "dataClasses"), "names")[1]
# retrieve response vector
resp <- as.vector(fit$model[, 1])
} else if (is_merMod(fit)) {
fit_x <- data.frame(stats::model.matrix(fit))
# retrieve response vector
resp <- stats::model.frame(fit)[[1]]
depvar.label <- sjstats::resp_var(fit)
} else if (inherits(fit, "gls")) {
fit_x <- data.frame(stats::model.matrix(fit))
resp <- nlme::getResponse(fit)
depvar.label <- attr(resp, "label")
} else {
fit_x <- data.frame(stats::model.matrix(fit))
# retrieve response vector
resp <- stats::model.frame(fit)[[1]]
depvar.label <- sjstats::resp_var(fit)
}
# get variable label label
depvar.label <- unname(sjlabelled::get_label(x = resp, def.value = depvar.label))
return(list(matrix = fit_x, resp.label = depvar.label, resp = resp))
}
# add annotations with table summary
# here we print out total N of cases, chi-square and significance of the table
print.table.summary <- function(baseplot,
......@@ -452,181 +416,6 @@ crosstabsum <- function(x, grp, weight.by) {
}
# checks at which position in fitted models factors with
# more than two levels are located.
#' @importFrom stats model.frame
retrieveModelGroupIndices <- function(models, rem_rows = NULL) {
# init group-row-indices
group.pred.rows <- c()
group.pred.labs <- c()
group.pred.span <- c()
found.factors <- c()
add.index <- 0
# ------------------------
# retrieve fitted models
# ------------------------
# go through fitted models
for (k in seq_len(length(models))) {
# get model
fit <- models[[k]]
# copy model frame
if (is_merMod(fit))
fmodel <- stats::model.frame(fit, fixed.only = T)
else
fmodel <- stats::model.frame(fit)
# retrieve all factors from model
for (grp.cnt in seq_len(ncol(fmodel))) {
# get variable
fit.var <- fmodel[, grp.cnt]
# is factor? and has more than two levels?
# (otherwise, only one category would appear in
# coefficients, so no grouping needed anyway)
if (is.factor(fit.var) && nlevels(fit.var) > 2) {
# get factor name
fac.name <- colnames(fmodel)[grp.cnt]
# check whether we already have this factor
if (!any(found.factors == fac.name)) {
# if not, save found factor variable name
found.factors <- c(found.factors, fac.name)
# save factor name
lab <- unname(sjlabelled::get_label(fit.var, def.value = fac.name))
# determins startindex
index <- grp.cnt + add.index - 1
index.add <- nlevels(fit.var) - 2
# save row index, so we know where to start group
group.pred.rows <- c(group.pred.rows, index)
group.pred.span <- c(group.pred.span, index:(index + index.add))
group.pred.labs <- c(group.pred.labs, lab)
# increase add.index by amount of factor levels (minus reference cat.)
add.index <- add.index + index.add
} else {
add.index <- add.index + nlevels(fit.var) - 2
}
}
}
}
# have any groups? if not, reset row-index-counter
if (length(group.pred.rows) < 1) {
group.pred.rows <- NULL
group.pred.labs <- NULL
group.pred.span <- NULL
}
# do we have any rows removed?
else if (!is.null(rem_rows)) {
# any non-computed row-indices left?
while (length(rem_rows) > 0) {
# take care, while loop!
any.found <- FALSE
# if yes, go through all grouping row indices
for (i in seq_len(length(group.pred.rows))) {
# if yes, check if removed row was before
# grouped row indes
if (length(rem_rows) > 0 && rem_rows[1] <= group.pred.rows[i]) {
# if yes, iterate all remaining group indices
for (j in i:length(group.pred.rows)) {
# and reduce index number (because of removed rows)
group.pred.rows[j] <- group.pred.rows[j] - 1
}
# where does span for grouping start?
start <- min(which(group.pred.span >= rem_rows[1]))
for (j in start:length(group.pred.span)) {
# and reduce index number (because of removed rows)
group.pred.span[j] <- group.pred.span[j] - 1
}
# reduce indices
rem_rows <- rem_rows - 1
# remove computed row-index
rem_rows <- rem_rows[-1]
# found something!
any.found <- TRUE
}
}
# removed any index? if not, break loop
if (!any.found) break
}
}
return(list(group.pred.rows,
group.pred.span,
group.pred.labs))
}
# automatically retrieve predictor labels
# of fitted (g)lm
#' @importFrom stats formula terms
retrieveModelLabels <- function(models, group.pred) {
fit.labels <- c()
for (k in seq_len(length(models))) {
# get model
fit <- models[[k]]
# any valid model?
if (inherits(fit, c("plm", "ppgls"))) return(NULL)
# get model coefficients' names
if (is_merMod(fit)) {
coef_names <- names(lme4::fixef(fit))
# get model frame
m_f <- stats::model.frame(fit, fixed.only = TRUE)
} else {
coef_names <- names(stats::coef(fit))
# get model frame
m_f <- stats::model.frame(fit)
}
# for NULL-models, we just have one column in model frame
if (ncol(m_f) > 1) {
# iterate coefficients (1 is intercept or response)
for (i in 2:ncol(m_f)) {
# check bounds
if (i <= length(coef_names)) {
# get predictor
pvar <- m_f[, i]
# check if we have a variable label
lab <- sjlabelled::get_label(pvar, def.value = colnames(m_f)[i])
# get model coefficients' names
coef_name <- coef_names[i]
# is predictor a factor?
# if yes, we have this variable multiple
# times, so manually set value labels
if (is.factor(pvar)) {
# get amount of levels
pvar.len <- nlevels(pvar)
# get value labels, if any
pvar.lab <- sjlabelled::get_labels(pvar)
# have any labels, and have we same amount of labels
# as factor levels?
if (!is.null(pvar.lab) && length(pvar.lab) == pvar.len) {
# create labels
if (group.pred && pvar.len > 2) {
# if predictor grouping is enabled, don't use variable labels again
labels.to.add <- pvar.lab[2:pvar.len]
} else {
# else, if we have not grouped predictors, we have no headin
# with variable label, hence, factor levels may not be intuitiv.
# thus, add variable label so values have a meaning
labels.to.add <- sprintf("%s (%s)", lab, pvar.lab[2:pvar.len])
}
fit.labels <- c(fit.labels, labels.to.add)
} else {
fit.labels <- c(fit.labels, coef_name)
}
} else {
if (!any(fit.labels == lab)) fit.labels <- c(fit.labels, lab)
}
}
}
}
}
unique(fit.labels)
}
# compute chi-square for glm
Chisquare.glm <- function(rr, digits = 3) {
return(with(rr, pchisq(null.deviance - deviance,
df.null - df.residual,
lower.tail = FALSE), digits = digits))
}
# Erzeugt eine rotierte Faktorladungen einer Hauptkomponentenanalyse
# (Paramter "data") mit einer bestimmten Anzahl an Faktoren (Parameter "factors")
# auf Grundlage der Varimax-Rotation
......
......@@ -261,6 +261,7 @@ tab_model_df <- function(x,
aic.list,
n.models,
title = NULL,
footnote = NULL,
col.header = NULL,
show.re.var = FALSE,
show.icc = FALSE,
......@@ -276,6 +277,15 @@ tab_model_df <- function(x,
# get style definition
style <- tab_df_style(CSS = CSS, ...)
# check for monotonic effects
sp <- string_starts_with("simo_mo", x$term)
if (!sjmisc::is_empty(sp)) {
x.sp <- dplyr::slice(x, !! sp)
x <- dplyr::slice(x, -!! sp)
x$term <- gsub(pattern = "^bsp_mo", replacement = "", x = x$term)
} else
x.sp <- NULL
# get HTML content
page.content <- tab_df_content(
......@@ -340,6 +350,40 @@ tab_model_df <- function(x,
page.content <- paste0(dv.content, page.content)
# simplex parameters here ----
if (!is.null(x.sp)) {
x.sp$term <- gsub(
pattern = "^simo_mo(.*)(\\.)(.*)(\\.)",
replacement = "\\1 \\[\\3\\]",
x = x.sp$term
)
sp.content <- tab_df_content(
mydf = x.sp,
title = NULL,
footnote = NULL,
col.header = NULL,
show.type = FALSE,
show.rownames = FALSE,
show.footnote = FALSE,
show.header = FALSE,
altr.row.col = FALSE,
sort.column = NULL,
include.table.tag = FALSE,
no.last.table.row = TRUE,
...
)
page.content <- paste0(page.content, " <tr>\n")
page.content <- paste0(page.content, sprintf(" <td colspan=\"%i\" class=\"simplexparts\">Simplex Parameters</td>\n", ncol(x)))
page.content <- paste0(page.content, " </tr>\n")
page.content <- paste0(page.content, sp.content)
}
# zero inflation part here ----
if (!is.null(zeroinf)) {
......@@ -507,6 +551,8 @@ tab_model_df <- function(x,
}
## TODO also show conditional ICC
if (!is_empty_list(icc.adj.list) && show.adj.icc) {
# icc.len <- max(purrr::map_dbl(icc.adj.list, length))
......@@ -676,6 +722,15 @@ tab_model_df <- function(x,
## TODO add bottom table border
# add optional "footnote" row ----
if (!is.null(footnote)) {
page.content <- paste0(page.content, " <tr>\n")
page.content <- paste0(page.content, sprintf(" <td colspan=\"%i\" class=\"footnote\">%s</td>\n", ncol(x), footnote))
page.content <- paste0(page.content, "</tr>\n")
}
# add table-caption ----
if (!is.null(title))
......
......@@ -260,6 +260,7 @@ tab_df_prepare_style <- function(CSS = NULL, content = NULL, task, ...) {
tag.fixedparts <- "fixedparts"
tag.randomparts <- "randomparts"
tag.zeroparts <- "zeroparts"
tag.simplexparts <- "simplexparts"
tag.firstsumrow <- "firstsumrow"
tag.labelcellborder <- "labelcellborder"
tag.depvarhead <- "depvarhead"
......@@ -295,6 +296,7 @@ tab_df_prepare_style <- function(CSS = NULL, content = NULL, task, ...) {
css.fixedparts <- "font-weight:bold; text-align:left;"
css.randomparts <- "font-weight:bold; text-align:left; padding-top:.8em;"
css.zeroparts <- "font-weight:bold; text-align:left; padding-top:.8em;"
css.simplexparts <- "font-weight:bold; text-align:left; padding-top:.8em;"
css.firstsumrow <- "border-top:1px solid;"
css.labelcellborder <- "border-bottom:1px solid;"
css.depvarhead <- "text-align:center; border-bottom:1px solid; font-style:italic; font-weight:normal;"
......@@ -339,6 +341,7 @@ tab_df_prepare_style <- function(CSS = NULL, content = NULL, task, ...) {
if (!is.null(CSS[['css.fixedparts']])) css.fixedparts <- ifelse(substring(CSS[['css.fixedparts']], 1, 1) == '+', paste0(css.fixedparts, substring(CSS[['css.fixedparts']], 2)), CSS[['css.fixedparts']])
if (!is.null(CSS[['css.randomparts']])) css.randomparts <- ifelse(substring(CSS[['css.randomparts']], 1, 1) == '+', paste0(css.randomparts, substring(CSS[['css.randomparts']], 2)), CSS[['css.randomparts']])
if (!is.null(CSS[['css.zeroparts']])) css.zeroparts <- ifelse(substring(CSS[['css.zeroparts']], 1, 1) == '+', paste0(css.zeroparts, substring(CSS[['css.zeroparts']], 2)), CSS[['css.zeroparts']])
if (!is.null(CSS[['css.simplexparts']])) css.simplexparts <- ifelse(substring(CSS[['css.simplexparts']], 1, 1) == '+', paste0(css.simplexparts, substring(CSS[['css.simplexparts']], 2)), CSS[['css.simplexparts']])
if (!is.null(CSS[['css.firstsumrow']])) css.firstsumrow <- ifelse(substring(CSS[['css.firstsumrow']], 1, 1) == '+', paste0(css.firstsumrow, substring(CSS[['css.firstsumrow']], 2)), CSS[['css.firstsumrow']])
if (!is.null(CSS[['css.labelcellborder']])) css.labelcellborder <- ifelse(substring(CSS[['css.labelcellborder']], 1, 1) == '+', paste0(css.table, substring(CSS[['css.labelcellborder']], 2)), CSS[['css.labelcellborder']])
if (!is.null(CSS[['css.depvarhead']])) css.depvarhead <- ifelse(substring(CSS[['css.depvarhead']], 1, 1) == '+', paste0(css.depvarhead, substring(CSS[['css.depvarhead']], 2)), CSS[['css.depvarhead']])
......@@ -356,7 +359,7 @@ tab_df_prepare_style <- function(CSS = NULL, content = NULL, task, ...) {
if (task == 1) {
content <- sprintf(
"<style>\nhtml, body { background-color: white; }\n%s { %s }\n%s { %s }\n%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n</style>",
"<style>\nhtml, body { background-color: white; }\n%s { %s }\n%s { %s }\n%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n.%s { %s }\n</style>",
tag.table, css.table,
tag.caption, css.caption,
tag.td, css.td,
......@@ -368,6 +371,7 @@ tab_df_prepare_style <- function(CSS = NULL, content = NULL, task, ...) {
tag.fixedparts, css.fixedparts,
tag.randomparts, css.randomparts,
tag.zeroparts, css.zeroparts,
tag.simplexparts, css.simplexparts,
tag.lasttablerow, css.lasttablerow,
tag.firsttablerow, css.firsttablerow,
tag.firstsumrow, css.firstsumrow,
......
plot_diag_linear <- function(model,
geom.colors,
dot.size,
line.size,
...) {
plot.list <- list()
geom.colors <- col_check2(geom.colors, 2)
......@@ -8,7 +9,7 @@ plot_diag_linear <- function(model,
p <- diag_vif(model)
if (!is.null(p)) plot.list[[length(plot.list) + 1]] <- p
p <- diag_qq(model, geom.colors)
p <- diag_qq(model, geom.colors, dot.size, line.size)
if (!is.null(p)) plot.list[[length(plot.list) + 1]] <- p
p <- diag_reqq(model, dot.size)
......@@ -17,21 +18,25 @@ plot_diag_linear <- function(model,
p <- diag_norm(model, geom.colors)
if (!is.null(p)) plot.list[[length(plot.list) + 1]] <- p
p <- diag_ncv(model)
p <- diag_ncv(model, dot.size, line.size)
if (!is.null(p)) plot.list[[length(plot.list) + 1]] <- p
plot.list
}
plot_diag_glm <- function(model, geom.colors, dot.size, ...) {
plot_diag_glm <- function(model, geom.colors, dot.size, line.size, ...) {
geom.colors <- col_check2(geom.colors, 2)
diag_reqq(model, dot.size)
}
#' @importFrom stats residuals fitted
diag_ncv <- function(model) {
diag_ncv <- function(model, dot.size, line.size) {
if (is.null(dot.size)) dot.size <- 1
if (is.null(line.size)) line.size <- 1
dat <- data.frame(
res = stats::residuals(model),
fitted = stats::fitted(model)
......@@ -39,8 +44,8 @@ diag_ncv <- function(model) {
ggplot(dat, aes_string(x = "fitted", y = "res")) +
geom_intercept_line2(0, NULL) +
geom_point() +
geom_smooth(method = "loess", se = FALSE) +
geom_point(size = dot.size) +
geom_smooth(method = "loess", se = FALSE, size = line.size) +
labs(
x = "Fitted values",
y = "Residuals",
......@@ -76,7 +81,11 @@ diag_norm <- function(model, geom.colors) {
#' @importFrom stats residuals rstudent fitted
diag_qq <- function(model, geom.colors, ...) {
diag_qq <- function(model, geom.colors, dot.size, line.size, ...) {
if (is.null(dot.size)) dot.size <- 1
if (is.null(line.size)) line.size <- 1
# qq-plot of studentized residuals
if (inherits(model, c("lme", "lmerMod", "glmmTMB"))) {
res_ <- sort(stats::residuals(model), na.last = NA)
......@@ -94,9 +103,9 @@ diag_qq <- function(model, geom.colors, ...) {
# plot it
ggplot(mydf, aes_string(x = "x", y = "y")) +
geom_point() +
geom_point(size = dot.size) +
scale_colour_manual(values = geom.colors) +
stat_smooth(method = "lm", se = FALSE) +
stat_smooth(method = "lm", se = FALSE, size = line.size) +
labs(
title = "Non-normality of residuals and outliers",
subtitle = "Dots should be plotted along the line",
......
#' @importFrom stats update
#' @importFrom dplyr bind_rows select mutate
#' @importFrom tidyr gather
plot_diag_stan <- function(model, geom.colors, axis.lim, facets, ...) {
plot_diag_stan <- function(model, geom.colors, axis.lim, facets, axis.labels, ...) {
# check some defaults
if (missing(facets)) facets <- TRUE
......@@ -105,10 +105,16 @@ plot_diag_stan <- function(model, geom.colors, axis.lim, facets, ...) {
ggridges::geom_density_ridges2(alpha = alpha, rel_min_height = .005, scale = scale) +
scale_fill_manual(values = col_check2(geom.colors, 2))
} else {
p <- ggplot(pp, aes_string(x = "Estimate", fill = "Sample")) +
geom_density(alpha = alpha) +
facet_wrap(~Term, scales = "free") +
scale_fill_manual(values = col_check2(geom.colors, 2))
if (!is.null(axis.labels) && !is.null(names(axis.labels))) {
p <- p + facet_wrap(~Term, scales = "free", labeller = labeller(.default = label_value, Term = axis.labels))
} else {
p <- p + facet_wrap(~Term, scales = "free")
}
}
......@@ -118,3 +124,4 @@ plot_diag_stan <- function(model, geom.colors, axis.lim, facets, ...) {
p + xlab("Distribution")
}
......@@ -25,7 +25,7 @@ utils::globalVariables("n")
#' @param axis.lim Numeric vector of length 2, defining the range of the plot axis.
#' Depending on plot type, may effect either x- or y-axis, or both.
#' For multiple plot outputs (e.g., from \code{type = "eff"} or
#' \code{type = "slope"} in \code{\link{sjp.glm}}), \code{axis.lim} may
#' \code{type = "slope"} in \code{\link{plot_model}}), \code{axis.lim} may
#' also be a list of vectors of length 2, defining axis limits for each
#' plot (only if non-faceted).
#' @param show.p Logical, adds significance levels to values, or value and
......
......@@ -560,7 +560,7 @@ plot_likert <- function(items,
)
) +
geom_text(
data = dplyr::filter(mydat.pos, .data$frq < 0),
data = dplyr::filter(mydat.neg, .data$frq < 0),
aes(
x = .data$x,
y = .data$ypos,
......
......@@ -34,11 +34,11 @@
#' \describe{
#' \item{\code{type = "slope"}}{Slope of coefficients for each single
#' predictor, against the response (linear relationship between each model
#' term and response).}
#' term and response). See 'Details'.}
#' \item{\code{type = "resid"}}{Slope of coefficients for each single
#' predictor, against the residuals (linear relationship between each model
#' term and residuals).}
#' \item{\code{type = "diag"}}{Check model assumptions.}
#' term and residuals). See 'Details'.}
#' \item{\code{type = "diag"}}{Check model assumptions. See 'Details'.}
#' }
#' \strong{Note:} For mixed models, the diagnostic plots like linear relationship
#' or check for Homoscedasticity, do \strong{not} take the uncertainty of
......@@ -80,10 +80,15 @@
#' Values for predictions will then be transformed, e.g.
#' \code{terms = "income [exp]"}. This is useful when model predictors were
#' transformed for fitting the model and should be back-transformed to the
#' original scale for predictions. Finally, using \code{pretty} for numeric
#' variables (e.g. \code{terms = "age [pretty]"}) calculates a pretty range
#' of values for the term, roughly of proportional length to the term's
#' value range. For more details, see \code{\link[ggeffects]{ggpredict}}.}
#' original scale for predictions. Finally, numeric vectors for which no
#' specific values are given, a "pretty range" is calculated, to avoid
#' memory allocation problems for vectors with many unique values. If a
#' numeric vector is specified as second or third term (i.e. if this vector
#' represents a grouping structure), representative values (see
#' \code{\link[ggeffects]{rprs_values}}) are chosen. If all values for a
#' numeric vector should be used to compute predictions, you may use
#' e.g. terms = "age [all]". For more details, see
#' \code{\link[ggeffects]{ggpredict}}.}
#' }
#' @param sort.est Determines in which way estimates are sorted in the plot:
#' \itemize{
......@@ -216,6 +221,9 @@
#' }
#' @param grid Logical, if \code{TRUE}, multiple plots are plotted as grid
#' layout.
#' @param p.threshold Numeric vector of length 3, indicating the treshold for
#' annotating p-values with asterisks. Only applies if
#' \code{p.style = "asterisk"}.
#' @param wrap.title Numeric, determines how many chars of the plot title are
#' displayed in one line and when a line break is inserted.
#' @param wrap.labels Numeric, determines how many chars of the value, variable
......@@ -312,19 +320,21 @@
#' \code{get_model_data()} simply calls \code{plot_model()} and returns
#' the data from the ggplot-object. Hence, it is rather inefficient and should
#' be used as alternative to \pkg{brooms} \code{tidy()}-function only in
#' specific situations. \cr \cr Some notes on the different plot-types:
#' specific situations. \cr \cr Some details on the different plot-types:
#' \describe{
#' \item{\code{type = "std2"}}{Plots standardized beta values,
#' \item{\code{type = "std2"}}{Plots standardized beta values,
#' however, standardization follows Gelman's (2008) suggestion, rescaling the
#' estimates by dividing them by two standard deviations instead of just one.
#' Resulting coefficients are then directly comparable for untransformed
#' binary predictors.
#' }
#' \item{\code{type = "pred"}}{Plots marginal effects. Simply wraps
#' \code{\link[ggeffects]{ggpredict}}.
#' \code{\link[ggeffects]{ggpredict}}. See also
#' \href{../doc/plot_marginal_effects.html}{this package-vignette}.
#' }
#' \item{\code{type = "eff"}}{Plots marginal effects. Simply wraps
#' \code{\link[ggeffects]{ggeffect}}.
#' \code{\link[ggeffects]{ggeffect}}. See also
#' \href{../doc/plot_marginal_effects.html}{this package-vignette}.
#' }
#' \item{\code{type = "int"}}{A shortcut for marginal effects plots, where
#' interaction terms are automatically detected and used as
......@@ -337,7 +347,25 @@
#' third) variable in an interaction is used as grouping factor(s)
#' (moderating variable). Use \code{type = "pred"} or \code{type = "eff"}
#' and specify a certain order in the \code{terms}-argument to indicate
#' which variable(s) should be used as moderator.}
#' which variable(s) should be used as moderator. See also
#' \href{../doc/plot_interactions.html}{this package-vignette}.
#' }
#' \item{\code{type = "slope"} and \code{type = "resid"}}{Simple diagnostic-plots,
#' where a linear model for each single predictor is plotted against the
#' response variable, or the model's residuals. Additionally, a loess-smoothed
#' line is added to the plot. The main purpose of these plots is to check whether
#' the relationship between outcome (or residuals) and a predictor is roughly
#' linear or not. Since the plots are based on a simple linear regression with
#' only one model predictor at the moment, the slopes (i.e. coefficients) may
#' differ from the coefficients of the complete model.
#' }
#' \item{\code{type = "diag"}}{For \strong{Stan-models}, plots the prior versus
#' posterior samples. For \strong{linear (mixed) models}, plots for
#' multicollinearity-check (Variance Inflation Factors), QQ-plots,
#' checks for normal distribution of residuals and homoscedasticity
#' (constant variance of residuals) are shown. For \strong{generalized
#' lineare mixed models}, returns the QQ-plot for random effects.
#' }
#' }
#'
#' @references
......@@ -376,7 +404,7 @@
#' plot_model(m, type = "re")
#'
#' # plot marginal effects
#' plot_model(m, type = "eff", terms = "Days")
#' plot_model(m, type = "pred", terms = "Days")
#'
#' # plot interactions
#' \dontrun{
......@@ -448,6 +476,7 @@ plot_model <- function(model,
dot.size = NULL,
line.size = NULL,
vline.color = NULL,
p.threshold = c(0.05, 0.01, 0.001),
grid,
case,
auto.label = TRUE,
......@@ -480,9 +509,6 @@ plot_model <- function(model,
# get info on model family
fam.info <- sjstats::model_family(model)
## TODO remove once sjstats was updated to >= 0.17.1
if (sjmisc::is_empty(fam.info$is_linear)) fam.info$is_linear <- FALSE
# check whether estimates should be transformed or not
if (missing(transform)) {
......@@ -501,7 +527,7 @@ plot_model <- function(model,
if (type %in% c("est", "std", "std2") && isTRUE(auto.label)) {
# get labels of dependent variables, and wrap them if too long
if (is.null(title)) title <- sjlabelled::get_dv_labels(model, case = case, multi.resp = fam.info$is_multivariate, ...)
if (is.null(title)) title <- sjlabelled::get_dv_labels(model, case = case, mv = fam.info$is_multivariate, ...)
title <- sjmisc::word_wrap(title, wrap = wrap.title)
# labels for axis with term names
......@@ -509,14 +535,14 @@ plot_model <- function(model,
axis.labels <- sjmisc::word_wrap(axis.labels, wrap = wrap.labels)
# title for axis with estimate values
if (is.null(axis.title)) axis.title <- sjmisc::word_wrap(estimate_axis_title(model, axis.title, type, transform), wrap = wrap.title)
if (is.null(axis.title)) axis.title <- sjmisc::word_wrap(estimate_axis_title(fit = model, axis.title = axis.title, type = type, transform = transform, include.zeroinf = TRUE), wrap = wrap.title)
axis.title <- sjmisc::word_wrap(axis.title, wrap = wrap.labels)
}
# check nr of terms. if only one, plot slope
if (type == "est" && length(sjstats::pred_vars(model)) == 1 && fam.info$is_linear) type <- "slope"
# check nr of estimates. if only one, plot slope
if (type == "est" && length(sjstats::pred_vars(model)) == 1 && fam.info$is_linear && one_par(model)) type <- "slope"
# set some default options for stan-models, which are not
......@@ -581,6 +607,7 @@ plot_model <- function(model,
bpe.color = bpe.color,
facets = grid,
show.zeroinf = show.zeroinf,
p.threshold = p.threshold,
...
)
......@@ -693,6 +720,7 @@ plot_model <- function(model,
geom.colors = colors,
axis.lim = axis.lim,
facets = grid,
axis.labels = axis.labels,
...
)
......@@ -702,6 +730,7 @@ plot_model <- function(model,
model = model,
geom.colors = colors,
dot.size = dot.size,
line.size = line.size,
...
)
......@@ -711,6 +740,7 @@ plot_model <- function(model,
model = model,
geom.colors = colors,
dot.size = dot.size,
line.size = line.size,
...
)
......@@ -767,3 +797,13 @@ get_model_data <- function(model,
else
p$data
}
one_par <- function(model) {
tryCatch(
{
length(stats::coef(model)) <= 2
},
error = function(x) { FALSE }
)
}
......@@ -2,6 +2,7 @@
#' @importFrom forcats fct_reorder fct_rev
#' @importFrom rlang .data
#' @importFrom sjmisc remove_var
#' @importFrom purrr pmap
plot_model_estimates <- function(model,
dat,
tf,
......@@ -29,6 +30,7 @@ plot_model_estimates <- function(model,
vline.color,
value.size,
facets,
p.threshold,
...) {
# remove intercept(s) from output
......@@ -97,7 +99,7 @@ plot_model_estimates <- function(model,
# add p-asterisks to data
dat$p.stars <- get_p_stars(dat$p.value)
dat$p.stars <- get_p_stars(dat$p.value, p.threshold)
dat$p.label <- sprintf("%.*f", digits, dat$estimate)
if (show.p) dat$p.label <- sprintf("%s %s", dat$p.label, dat$p.stars)
......@@ -228,27 +230,64 @@ plot_model_estimates <- function(model,
)
} else {
plot_point_estimates(
model = model,
dat = dat,
tf = tf,
title = title,
axis.labels = axis.labels,
axis.title = axis.title,
axis.lim = axis.lim,
grid.breaks = grid.breaks,
show.values = show.values,
value.offset = value.offset,
geom.size = geom.size,
line.size = line.size,
geom.colors = geom.colors,
bpe.style = bpe.style,
bpe.color = bpe.color,
vline.color = vline.color,
value.size = value.size,
facets = facets,
...
)
if (obj_has_name(dat, "wrap.facet") && dplyr::n_distinct(dat$wrap.facet, na.rm = TRUE) > 1 && !facets) {
dat <- purrr::map(split(dat, f = dat$wrap.facet), ~ sjmisc::remove_var(.x, "wrap.facet"))
if (length(axis.title) == 1) axis.title <- c(axis.title, "Odds Ratios")
purrr::pmap(list(dat, axis.title, names(dat)), function(.x, .y, .z) {
plot_point_estimates(
model = model,
dat = .x,
tf = tf,
title = paste0(title, " (", .z, ")"),
axis.labels = axis.labels,
axis.title = .y,
axis.lim = NULL,
grid.breaks = NULL,
show.values = show.values,
value.offset = value.offset,
geom.size = geom.size,
line.size = line.size,
geom.colors = geom.colors,
bpe.style = bpe.style,
bpe.color = bpe.color,
vline.color = vline.color,
value.size = value.size,
facets = facets,
...
)
})
} else {
plot_point_estimates(
model = model,
dat = dat,
tf = tf,
title = title,
axis.labels = axis.labels,
axis.title = axis.title,
axis.lim = axis.lim,
grid.breaks = grid.breaks,
show.values = show.values,
value.offset = value.offset,
geom.size = geom.size,
line.size = line.size,
geom.colors = geom.colors,
bpe.style = bpe.style,
bpe.color = bpe.color,
vline.color = vline.color,
value.size = value.size,
facets = facets,
...
)
}
}
}
......@@ -26,9 +26,6 @@
#' is \code{FALSE}.
#'
#' @inheritParams plot_model
#' @inheritParams sjp.lm
#' @inheritParams sjp.lmer
#' @inheritParams sjt.lm
#' @inheritParams sjp.grpfrq
#'
#' @return A ggplot-object.
......@@ -74,12 +71,11 @@
#' @import ggplot2
#' @importFrom purrr map map_df map2
#' @importFrom dplyr slice bind_rows filter
#' @importFrom broom tidy
#' @importFrom forcats fct_rev
#' @importFrom sjstats std_beta p_value model_family
#' @importFrom sjlabelled get_dv_labels get_term_labels
#' @importFrom rlang .data
#' @importFrom sjmisc word_wrap var_rename
#' @importFrom sjmisc word_wrap var_rename add_variables
#' @export
plot_models <- function(...,
transform,
......@@ -104,7 +100,7 @@ plot_models <- function(...,
show.intercept = FALSE,
show.p = TRUE,
p.shape = FALSE,
ci.lvl = .95,
p.threshold = c(0.05, 0.01, 0.001), ci.lvl = .95,
vline.color = NULL,
digits = 2,
grid = FALSE,
......@@ -122,10 +118,6 @@ plot_models <- function(...,
# get info on model family
fam.info <- sjstats::model_family(input_list[[1]])
## TODO remove once sjstats was updated to >= 0.17.1
if (sjmisc::is_empty(fam.info$is_linear)) fam.info$is_linear <- FALSE
# check whether estimates should be transformed or not
if (missing(transform)) {
......@@ -152,7 +144,7 @@ plot_models <- function(...,
fl <- input_list %>%
purrr::map(~ sjstats::std_beta(.x, type = std.est)) %>%
purrr::map(~ sjmisc::var_rename(.x, std.estimate = "estimate")) %>%
purrr::map2(input_list, ~ add_cols(
purrr::map2(input_list, ~ sjmisc::add_variables(
.x, p.value = sjstats::p_value(.y)[["p.value"]][-1]
))
......@@ -204,7 +196,7 @@ plot_models <- function(...,
# add grouping index
for (i in 1:length(fl)) fl[[i]] <- add_cols(fl[[i]], group = as.character(i), .after = Inf)
for (i in 1:length(fl)) fl[[i]] <- sjmisc::add_variables(fl[[i]], group = as.character(i), .after = Inf)
# merge models to one data frame
ff <- dplyr::bind_rows(fl)
......@@ -240,7 +232,7 @@ plot_models <- function(...,
# add p-asterisks to data
ff$p.stars <- get_p_stars(ff$p.value)
ff$p.stars <- get_p_stars(ff$p.value, p.threshold)
ff$p.label <- sprintf("%.*f", digits, ff$estimate)
if (show.p) ff$p.label <- sprintf("%s %s", ff$p.label, ff$p.stars)
......
......@@ -160,19 +160,33 @@ plot_point_estimates <- function(model,
# we need transformed scale for exponentiated estimates
has_zeroinf <- (obj_has_name(dat, "wrap.facet") && dplyr::n_distinct(dat$wrap.facet, na.rm = TRUE) > 1)
if (isTRUE(tf == "exp")) {
p <- p + scale_y_continuous(
trans = "log10",
limits = axis.scaling$axis.lim,
breaks = axis.scaling$ticks,
labels = prettyNum
)
if (has_zeroinf) {
p <- p + scale_y_continuous(trans = "log10")
} else {
p <- p + scale_y_continuous(
trans = "log10",
limits = axis.scaling$axis.lim,
breaks = axis.scaling$ticks,