[](https://doi.org/10.5281/zenodo.1284472)
Collection of convenient functions for common statistical computations, which are not directly provided by R's base or stats packages.
This package aims at providing, **first**, shortcuts for statistical measures, which otherwise could only be calculated with additional effort (like Cramer's V, Phi, or effict size statistics like Eta or Omega squared), or for which currently no functions available.
**Second**, another focus lies on weighted variants of common statistical measures and tests like weighted standard error, mean, t-test, correlation, and more.
The comprised tools include:
* Especially for mixed models: design effect, sample size calculation
* Weighted statistics and tests for: mean, median, standard error, standard deviation, correlation, Chi-squared test, t-test, Mann-Whitney-U-test
## Documentation
Please visit [https://strengejacke.github.io/sjstats/](https://strengejacke.github.io/sjstats/) for documentation and vignettes.
## Installation
### Latest development build
To install the latest development snapshot (see latest changes below), type following commands into the R console:
```r
library(devtools)
devtools::install_github("strengejacke/sjstats")
```
### Officiale, stable release
[](https://cran.r-project.org/package=sjstats)
[](https://cranlogs.r-pkg.org:443/)
[](https://cranlogs.r-pkg.org:443/)
To install the latest stable release from CRAN, type following command into the R console:
```r
install.packages("sjstats")
```
## Citation
In case you want / have to cite my package, please use `citation('sjstats')` for citation information.
[](https://doi.org/10.5281/zenodo.1284472)
sjstats/data/ 0000755 0001762 0000144 00000000000 13737643670 012676 5 ustar ligges users sjstats/data/efc.RData 0000644 0001762 0000144 00000042134 13446531537 014347 0 ustar ligges users ՝]qߏIJ9 1*TRhjIlHI)AIˡ. ÿ ( p/gι V_3ܻKw{{'ϧ?.|rsXq{?9/
pӍ~<=|o11}z
G 7~g9 Pv^1r<371? Wü+1y5 KA FO>
}z6̼ cz'Zc B?AS|n<_#}DX K?3 UӍaEG||]
|+w< A#:;wgc="˾9GUҏqƥ_zKBn# ZW?6<_Q/`ޛh ~艾_"eOyѮ71ۀE@# :_
A#K q?x9/{s{ u`a܈@z^MSq s K#O1 ޫh˟T1_H/z^釶zM?qߒCr)owcݠ/OET_}ճʺ 'f K鳀u81ƕW*QrI^':
<1 X2?'ᾥy )=~3?Yw=v'/bu\puR;_A
.\>E)oH?W/E:G[+u~-d?W(uR?!}|:W?-swGWP/;U|kS ?\RP柕2x.O|y;=q!wCyP5 @/> Aj?ެKX Kq8к>SYgJWЯ~+qd\K{
^tq<ȼsYi\tY${J ^J:
ΒCr3LsuoszoQrw~pu9K}Y;yב~9 ǣM\1\tujGuGd w rg}ףs ~Wq^;;[eq xwoo?xIn< ̠ T!02_ 3Y |9- -9fZ+%rݞ Owq7y C'?W= ^ i_ KS0crNڠ>6@gc]a4Z_o~j)H:o;nEW|?i'eo3hr:w(?%G? 7y[qH w c})k\wpco y ÷+px '<9'r!/Cs+pa=cq//g#=ɌuS;c_,ݯ'lNw3x ~hϡ{˹2k>ܡ+Hگu z~?V\ms!ݑ ;ခ?ߐeCq܄vh?A!2pP~Q| vn3o떓qBxgyr#Nxq)V_XH[~gab f%YOC)la^w/q^7 04/
%s", df$grp1.label, df$grp2.label),
N = sprintf("%s
%s", df$grp1.n, df$grp2.n),
'Mean Rank' = sprintf("%.2f
%.2f", df$rank.mean.grp1, df$rank.mean.grp2),
'Mann-Whitney-U' = as.character(df$u),
'Wilcoxon-W' = as.character(df$w),
Z = sprintf("%.3f", df$z),
'Effect Size' = sprintf("%.3f", df$r),
p = sprintf("%.3f", df$p)
)
# replace 0.001 with <0.001
tab.df$p[which(tab.df$p == "0.001")] <- "<0.001"
ret.df <- list(df = df, tab.df = tab.df, data = data.frame(dv, grp))
# save how to print output
attr(ret.df, "print") <- out
attr(ret.df, "encoding") <- encoding
attr(ret.df, "file") <- file
if (out %in% c("viewer", "browser"))
class(ret.df) <- c("mwu", "sjt_mwu")
else
class(ret.df) <- c("mwu", "sj_mwu")
ret.df
}
#' @rdname mwu
#' @export
mannwhitney <- mwu
sjstats/R/is_prime.R 0000644 0001762 0000144 00000001245 13446531537 014115 0 ustar ligges users #' @title Find prime numbers
#' @name is_prime
#'
#' @description This functions checks whether a number is, or numbers in a
#' vector are prime numbers.
#'
#' @param x An integer, or a vector of integers.
#'
#' @return \code{TRUE} for each prime number in \code{x}, \code{FALSE} otherwise.
#'
#' @examples
#' is_prime(89)
#' is_prime(15)
#' is_prime(c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
#'
#' @importFrom purrr map_lgl
#' @importFrom sjmisc is_float
#' @export
is_prime <- function(x) {
if (sjmisc::is_float(x))
stop("`x` needs to be an integer value.", call. = F)
purrr::map_lgl(x, ~ .x == 2L || all(.x %% 2L:max(2, floor(sqrt(.x))) != 0))
}
sjstats/R/gmd.R 0000644 0001762 0000144 00000003171 13752226326 013052 0 ustar ligges users #' @title Gini's Mean Difference
#' @name gmd
#' @description \code{gmd()} computes Gini's mean difference for a numeric vector
#' or for all numeric vectors in a data frame.
#'
#' @param x A vector or data frame.
#' @param ... Optional, unquoted names of variables that should be selected for
#' further processing. Required, if \code{x} is a data frame (and no vector)
#' and only selected variables from \code{x} should be processed. You may also
#' use functions like \code{:} or tidyselect's \code{select_helpers()}.
#'
#' @return For numeric vectors, Gini's mean difference. For non-numeric vectors
#' or vectors of length < 2, returns \code{NA}.
#'
#' @note Gini's mean difference is defined as the mean absolute difference between
#' any two distinct elements of a vector. Missing values from \code{x} are
#' silently removed.
#'
#' @references David HA. Gini's mean difference rediscovered. Biometrika 1968(55): 573-575
#'
#' @examples
#' data(efc)
#' gmd(efc$e17age)
#' gmd(efc, e17age, c160age, c12hour)
#'
#' @importFrom dplyr quos select
#' @importFrom purrr map_df
#' @importFrom sjmisc is_empty
#' @export
gmd <- function(x, ...) {
# evaluate dots
qs <- dplyr::quos(...)
if (!sjmisc::is_empty(qs)) x <- suppressMessages(dplyr::select(x, !!!qs))
if (is.data.frame(x))
purrr::map_df(x, gmd_helper)
else
gmd_helper(x)
}
#' @importFrom stats na.omit
gmd_helper <- function(x) {
if (!is.numeric(x)) return(NA)
x <- stats::na.omit(x)
n <- length(x)
if (n < 2) return(NA)
w <- 4 * ((1:n) - (n - 1) / 2) / n / (n - 1)
sum(w * sort(x - mean(x)))
}
sjstats/R/cramer.R 0000644 0001762 0000144 00000002357 13566035401 013554 0 ustar ligges users #' @rdname crosstable_statistics
#' @export
cramer <- function(tab, ...) {
UseMethod("cramer")
}
#' @export
cramer.table <- function(tab, ...) {
.cramer(tab)
}
#' @export
cramer.ftable <- function(tab, ...) {
.cramer(tab)
}
#' @rdname crosstable_statistics
#' @export
cramer.formula <- function(formula, data, ci.lvl = NULL, n = 1000, method = c("dist", "quantile"), ...) {
terms <- all.vars(formula)
tab <- table(data[[terms[1]]], data[[terms[2]]])
method <- match.arg(method)
if (is.null(ci.lvl) || is.na(ci.lvl)) {
.cramer(tab)
} else {
ci <- data[, terms] %>%
sjstats::bootstrap(n) %>%
dplyr::mutate(
tables = lapply(.data$strap, function(x) {
dat <- as.data.frame(x)
table(dat[[1]], dat[[2]])
}),
cramers = sapply(.data$tables, function(x) .cramer(x))
) %>%
dplyr::pull("cramers") %>%
boot_ci(ci.lvl = ci.lvl, method = method)
data_frame(
cramer = .cramer(tab),
conf.low = ci$conf.low,
conf.high = ci$conf.high
)
}
}
.cramer <- function(tab) {
# convert to flat table
if (!inherits(tab, "ftable")) tab <- stats::ftable(tab)
sqrt(phi(tab)^2 / min(dim(tab) - 1))
}
sjstats/R/wtd_se.R 0000644 0001762 0000144 00000001432 13565537440 013572 0 ustar ligges users #' @rdname weighted_sd
#' @export
weighted_se <- function(x, weights = NULL) {
UseMethod("weighted_se")
}
#' @export
weighted_se.data.frame <- function(x, weights = NULL) {
se_result <- purrr::map_dbl(x, ~ weighted_se_helper(.x, weights = weights))
names(se_result) <- colnames(x)
se_result
}
#' @export
weighted_se.matrix <- function(x, weights = NULL) {
se_result <- purrr::map_dbl(x, ~ weighted_se_helper(.x, weights = weights))
names(se_result) <- colnames(x)
se_result
}
#' @export
weighted_se.default <- function(x, weights = NULL) {
weighted_se_helper(x, weights)
}
weighted_se_helper <- function(x, weights) {
if (is.null(weights)) weights <- rep(1, length(x))
sqrt(weighted_variance(x, weights) / length(stats::na.omit(x)))
}
sjstats/R/wtd_chisqtest.R 0000644 0001762 0000144 00000005307 13775602764 015204 0 ustar ligges users #' @rdname weighted_sd
#' @export
weighted_chisqtest <- function(data, ...) {
UseMethod("weighted_chisqtest")
}
#' @importFrom dplyr select
#' @importFrom stats na.omit chisq.test as.formula
#' @rdname weighted_sd
#' @export
weighted_chisqtest.default <- function(data, x, y, weights, ...) {
x.name <- deparse(substitute(x))
y.name <- deparse(substitute(y))
w.name <- deparse(substitute(weights))
if (w.name == "NULL") {
w.name <- "weights"
data$weights <- 1
}
# create string with variable names
vars <- .compact_character(c(x.name, y.name, w.name))
# get data
dat <- suppressMessages(dplyr::select(data, !! vars))
dat <- stats::na.omit(dat)
colnames(dat)[ncol(dat)] <- ".weights"
# check if we have chisq-test for given probabilities
dot_args <- list(...)
if ("p" %in% names(dot_args)) {
.weighted_chisq_for_prob(dat, x.name, prob = dot_args[["p"]])
} else {
crosstable_statistics(data = dat, statistics = "auto", weights = ".weights", ...)
}
}
#' @importFrom stats xtabs
#' @rdname weighted_sd
#' @export
weighted_chisqtest.formula <- function(formula, data, ...) {
vars <- all.vars(formula)
dot_args <- list(...)
if (length(vars) < 3 && !"p" %in% names(dot_args)) {
vars <- c(vars, ".weights")
data$.weights <- 1
}
if ("p" %in% names(dot_args)) {
dat <- data[vars]
colnames(dat)[ncol(dat)] <- ".weights"
.weighted_chisq_for_prob(dat, names(dat)[1], prob = dot_args[["p"]])
} else {
tab <- as.table(round(stats::xtabs(data[[vars[3]]] ~ data[[vars[1]]] + data[[vars[2]]])))
class(tab) <- "table"
crosstable_statistics(data = tab, statistics = "auto", weights = NULL, ...)
}
}
.weighted_chisq_for_prob <- function(dat, x.name, prob) {
if (!requireNamespace("survey", quietly = TRUE)) {
stop("Package `survey` needed to for this function to work. Please install it.", call. = FALSE)
}
if (abs(sum(prob) - 1) > sqrt(.Machine$double.eps)) {
prob <- prob / sum(prob)
}
dat$sj_subject_id <- 1:nrow(dat)
dat$sj_weights <- dat$.weights
design <- survey::svydesign(id = ~sj_subject_id, weights = ~sj_weights, data = dat)
stable <- survey::svytable(stats::as.formula(paste0("~", x.name)), design)
out <- stats::chisq.test(stable, p = prob)
structure(class = "sj_xtab_stat2", list(
estimate = out$statistic,
p.value = out$p.value,
stat.name = "Chi-squared",
stat.html = "χ2",
df = out$parameter,
n_obs = nrow(dat),
method = "Weighted chi-squared test for given probabilities",
method.html = "Weighted χ2 test for given probabilities",
method.short = "Chi-squared"
))
}
sjstats/R/var_pop.R 0000644 0001762 0000144 00000003113 13446531537 013750 0 ustar ligges users #' @title Calculate population variance and standard deviation
#' @name var_pop
#' @description Calculate the population variance or standard deviation of a vector.
#'
#' @param x (Numeric) vector.
#'
#' @return The population variance or standard deviation of \code{x}.
#'
#' @details Unlike \code{\link[stats]{var}}, which returns the sample variance,
#' \code{var_pop()} returns the population variance. \code{sd_pop()}
#' returns the standard deviation based on the population variance.
#'
#' @examples
#' data(efc)
#'
#' # sampling variance
#' var(efc$c12hour, na.rm = TRUE)
#' # population variance
#' var_pop(efc$c12hour)
#'
#' # sampling sd
#' sd(efc$c12hour, na.rm = TRUE)
#' # population sd
#' sd_pop(efc$c12hour)
#'
#' @importFrom stats na.omit var
#' @importFrom sjmisc is_num_fac
#' @importFrom sjlabelled as_numeric
#' @export
var_pop <- function(x) {
# check for categorical
if (is.factor(x)) {
# only allow numeric factors
if (!sjmisc::is_num_fac(x)) {
warning("`x` must be numeric vector or a factor with numeric levels.", call. = F)
return(NA)
}
# convert factor to numeric
x <- sjlabelled::as_numeric(x)
}
# remove NA
x <- stats::na.omit(x)
n <- length(x)
# population variance
stats::var(x) * ((n - 1) / n)
}
#' @rdname var_pop
#' @importFrom stats na.omit var
#' @export
sd_pop <- function(x) {
# get population variance
pv <- var_pop(x)
# factors with non-numeric level return NULL
if (!is.null(pv) && !is.na(pv))
sqrt(pv)
else
NA
}
sjstats/R/re-exports.R 0000644 0001762 0000144 00000000746 13752226042 014413 0 ustar ligges users #' @importFrom magrittr %>%
#' @export
magrittr::`%>%`
#' @importFrom sjmisc typical_value
#' @export
sjmisc::typical_value
#' @importFrom performance mse
#' @export
performance::mse
#' @importFrom performance rmse
#' @export
performance::rmse
#' @importFrom bayestestR ci
#' @export
bayestestR::ci
#' @importFrom bayestestR equivalence_test
#' @export
bayestestR::equivalence_test
#' @importFrom insight link_inverse
#' @export
insight::link_inverse
sjstats/R/Deprecated.R 0000644 0001762 0000144 00000004437 13752226076 014353 0 ustar ligges users #' @title Deprecated functions
#' @name r2
#' @description A list of deprecated functions.
#'
#' @param x An object.
#' @param ... Currently not used.
#'
#' @return Nothing.
#'
#' @importFrom performance r2
#' @export
r2 <- function(x) {
.Deprecated("performance::r2()")
performance::r2(x)
}
#' @importFrom performance icc
#' @rdname r2
#' @export
icc <- function(x) {
.Deprecated("performance::icc()")
performance::icc(x)
}
#' @importFrom parameters p_value
#' @rdname r2
#' @export
p_value <- function(x, ...) {
.Deprecated("parameters::p_value()")
parameters::p_value(x)
}
#' @importFrom parameters standard_error
#' @rdname r2
#' @export
se <- function(x, ...) {
.Deprecated("parameters::standard_error()")
parameters::standard_error(x)
}
#' @importFrom effectsize cohens_f
#' @rdname r2
#' @export
cohens_f <- function(x, ...) {
.Deprecated("effectsize::cohens_f()")
effectsize::cohens_f(x)
}
#' @importFrom effectsize eta_squared
#' @rdname r2
#' @export
eta_sq <- function(x, ...) {
.Deprecated("effectsize::eta_squared()")
effectsize::eta_squared(x)
}
#' @importFrom effectsize epsilon_squared
#' @rdname r2
#' @export
epsilon_sq <- function(x, ...) {
.Deprecated("effectsize::epsilon_squared()")
effectsize::epsilon_squared(x)
}
#' @importFrom effectsize omega_squared
#' @rdname r2
#' @export
omega_sq <- function(x, ...) {
.Deprecated("effectsize::omega_sqared()")
effectsize::omega_squared(x)
}
#' @importFrom parameters rescale_weights
#' @rdname r2
#' @export
scale_weights <- function(x, ...) {
.Deprecated("parameters::rescale_weights()")
parameters::rescale_weights(x, ...)
}
#' @importFrom parameters model_parameters
#' @rdname r2
#' @export
tidy_stan <- function(x, ...) {
.Deprecated("parameters::model_parameters()")
parameters::model_parameters(x, ...)
}
#' @importFrom parameters standard_error_robust
#' @rdname r2
#' @export
robust <- function(x, ...) {
.Deprecated("parameters::standard_error_robust()")
parameters::standard_error_robust(x, ...)
}
#' @importFrom bayestestR mediation
#' @rdname r2
#' @export
mediation <- function(x, ...) {
.Deprecated("bayestestR::mediation()")
bayestestR::mediation(x, ...)
}
sjstats/R/select_helpers.R 0000644 0001762 0000144 00000001575 13446531537 015315 0 ustar ligges users string_starts_with <- function(pattern, x) {
pattern <- paste0("^\\Q", pattern, "\\E")
grep(pattern, x, perl = TRUE)
}
string_contains <- function(pattern, x) {
pattern <- paste0("\\Q", pattern, "\\E")
grep(pattern, x, perl = TRUE)
}
string_ends_with <- function(pattern, x) {
pattern <- paste0("\\Q", pattern, "\\E$")
grep(pattern, x, perl = TRUE)
}
#' @importFrom purrr map
string_one_of <- function(pattern, x) {
m <- unlist(purrr::map(pattern, ~ grep(., x, fixed = TRUE, useBytes = TRUE)))
x[m]
}
rownames_as_column <- function(x, var = "rowname") {
rn <- data.frame(rn = rownames(x), stringsAsFactors = FALSE)
x <- cbind(rn, x)
colnames(x)[1] <- var
rownames(x) <- NULL
x
}
obj_has_name <- function(x, name) {
name %in% names(x)
}
obj_has_rownames <- function(x) {
!identical(as.character(1:nrow(x)), rownames(x))
}
sjstats/R/svyglmzip.R 0000644 0001762 0000144 00000010546 13616600205 014342 0 ustar ligges users utils::globalVariables("scaled.weights")
#' @title Survey-weighted zero-inflated Poisson model
#' @name svyglm.zip
#' @description \code{svyglm.zip()} is an extension to the \CRANpkg{survey}-package
#' to fit survey-weighted zero-inflated Poisson models. It uses
#' \code{\link[survey]{svymle}} to fit sampling-weighted
#' maximum likelihood estimates, based on starting values provided
#' by \code{\link[pscl]{zeroinfl}}.
#'
#'
#' @param formula An object of class \code{formula}, i.e. a symbolic description
#' of the model to be fitted. See 'Details' in \code{\link[pscl]{zeroinfl}}.
#' @param design An object of class \code{\link[survey]{svydesign}}, providing
#' a specification of the survey design.
#' @param ... Other arguments passed down to \code{\link[pscl]{zeroinfl}}.
#'
#' @return An object of class \code{\link[survey]{svymle}} and \code{svyglm.zip},
#' with some additional information about the model.
#'
#' @details Code modified from https://notstatschat.rbind.io/2015/05/26/zero-inflated-poisson-from-complex-samples/.
#'
#' @examples
#' if (require("survey")) {
#' data(nhanes_sample)
#' set.seed(123)
#' nhanes_sample$malepartners <- rpois(nrow(nhanes_sample), 2)
#' nhanes_sample$malepartners[sample(1:2992, 400)] <- 0
#'
#' # create survey design
#' des <- svydesign(
#' id = ~SDMVPSU,
#' strat = ~SDMVSTRA,
#' weights = ~WTINT2YR,
#' nest = TRUE,
#' data = nhanes_sample
#' )
#'
#' # fit negative binomial regression
#' fit <- svyglm.zip(
#' malepartners ~ age + factor(RIDRETH1) | age + factor(RIDRETH1),
#' des
#' )
#'
#' # print coefficients and standard errors
#' fit
#' }
#' @importFrom insight find_formula
#' @importFrom stats weights update model.frame coef as.formula family
#' @export
svyglm.zip <- function(formula, design, ...) {
# check if pkg survey is available
if (!requireNamespace("survey", quietly = TRUE)) {
stop("Package `survey` needed to for this function to work. Please install it.", call. = FALSE)
}
if (!requireNamespace("pscl", quietly = TRUE)) {
stop("Package `pscl` needed to for this function to work. Please install it.", call. = FALSE)
}
# get design weights. we need to scale these weights for the glm.nb() function
dw <- stats::weights(design)
# update design with scaled weights
design <- stats::update(design, scaled.weights = dw / mean(dw, na.rm = TRUE))
# fit ZIP model, with scaled design weights
mod <- pscl::zeroinfl(formula, data = stats::model.frame(design), weights = scaled.weights, ...)
ff <- insight::find_formula(mod)
# fit survey model, using maximum likelihood estimation
svyfit <-
survey::svymle(
loglike = sjstats_loglik_zip,
grad = sjstats_score_zip,
design = design,
formulas = list(eta = ff$conditional, logitp = ff$zero_inflated),
start = stats::coef(mod),
na.action = "na.omit"
)
# add additoinal information
class(svyfit) <- c("svyglm.zip", class(svyfit))
attr(svyfit, "zip.terms") <- all.vars(formula)
attr(svyfit, "zip.formula") <- formula
svyfit$deviance <- mod$deviance
svyfit$df.residuals <- mod$df.residuals
svyfit$df <- length(stats::coef(mod)) + 1
svyfit$aic <- mod$aic
svyfit
}
#' @importFrom stats dpois
# log-likelihood function used in "svymle()"
sjstats_loglik_zip <- function(y, eta, logitp) {
mu <- exp(eta)
p <- exp(logitp) / (1 + exp(logitp))
log(p * (y == 0) + (1 - p) * stats::dpois(y, mu))
}
sjstats_dlogitp = function(y, eta, logitp) {
mu <- exp(eta)
p <- exp(logitp) / (1 + exp(logitp))
dexpit <- p / (1 + p) ^ 2
num <- dexpit * (y == 0) - dexpit * stats::dpois(y, mu)
denom <- p * (y == 0) + (1 - p) * stats::dpois(y, mu)
num / denom
}
# derivative
sjstats_deta_zip <- function(y, eta, logitp) {
mu <- exp(eta)
p <- exp(logitp) / (1 + exp(logitp))
dmutoy <- 0 * y
dmutoy[y > 0] = exp(-mu[y > 0]) * mu[y > 0] ^ (y[y > 0] - 1) / factorial(y[y > 0] - 1)
num = (1 - p) * (-stats::dpois(y, mu) + dmutoy)
denom = p * (y == 0) + (1 - p) * stats::dpois(y, mu)
num / denom
}
# score function, combines derivatives
sjstats_score_zip <- function(y, eta, logitp) {
cbind(sjstats_deta_zip(y, eta, logitp), sjstats_dlogitp(y, eta, logitp))
}
sjstats/R/wtd_ttest.R 0000644 0001762 0000144 00000010765 13565537440 014337 0 ustar ligges users #' @rdname weighted_sd
#' @importFrom stats pt qt weighted.mean setNames
#' @importFrom sjmisc is_empty
#' @export
weighted_ttest <- function(data, ...) {
UseMethod("weighted_ttest")
}
#' @rdname weighted_sd
#' @export
weighted_ttest.default <- function(data, x, y = NULL, weights, mu = 0, paired = FALSE, ci.lvl = 0.95, alternative = c("two.sided", "less", "greater"), ...) {
if (!missing(ci.lvl) & (length(ci.lvl) != 1 || !is.finite(ci.lvl) || ci.lvl < 0 || ci.lvl > 1))
stop("'ci.lvl' must be a single number between 0 and 1")
alternative <- match.arg(alternative)
x.name <- deparse(substitute(x))
y.name <- deparse(substitute(y))
w.name <- deparse(substitute(weights))
if (y.name == "NULL") y.name <- NULL
if (w.name == "NULL") {
w.name <- "weights"
data$weights <- 1
}
# create string with variable names
vars <- c(x.name, y.name, w.name)
# get data
dat <- suppressMessages(dplyr::select(data, !! vars))
dat <- na.omit(dat)
if (sjmisc::is_empty(dat) || nrow(dat) == 1) {
warning("Too less data to compute t-test.")
return(NULL)
}
xv <- dat[[x.name]]
wx <- wy <- dat[[w.name]]
if (!is.null(y.name))
yv <- dat[[y.name]]
else
yv <- NULL
nx <- ny <- nrow(dat)
weighted_ttest_helper(xv, yv, wx, wy, nx, ny, mu, paired, alternative, ci.lvl, x.name, y.name, NULL)
}
#' @rdname weighted_sd
#' @export
weighted_ttest.formula <- function(formula, data, mu = 0, paired = FALSE, ci.lvl = 0.95, alternative = c("two.sided", "less", "greater"), ...) {
if (!missing(ci.lvl) & (length(ci.lvl) != 1 || !is.finite(ci.lvl) || ci.lvl < 0 || ci.lvl > 1))
stop("'ci.lvl' must be a single number between 0 and 1")
alternative <- match.arg(alternative)
vars <- all.vars(formula)
g <- data[[vars[2]]]
if (is.factor(g))
grps <- levels(g)
else
grps <- na.omit(sort(unique(g)))
if (length(grps) > 2)
stop("Grouping factor has more than two levels.")
if (length(vars) < 3) {
vars <- c(vars, "weights")
data$weights <- 1
}
x <- data[[vars[1]]]
y <- data[[vars[2]]]
w <- data[[vars[3]]]
xv <- x[y == grps[1]]
yv <- x[y == grps[2]]
wx <- w[y == grps[1]]
wy <- w[y == grps[2]]
mxv <- is.na(xv)
xv <- xv[!mxv]
wx <- wx[!mxv]
myv <- is.na(yv)
yv <- yv[!myv]
wy <- wy[!myv]
nx <- length(xv)
ny <- length(yv)
labs <- sjlabelled::get_labels(
data[[vars[2]]],
attr.only = FALSE,
values = "p",
drop.na = TRUE,
drop.unused = TRUE
)
weighted_ttest_helper(xv, yv, wx, wy, nx, ny, mu, paired, alternative, ci.lvl, vars[1], vars[2], labs)
}
weighted_ttest_helper <- function(xv, yv, wx, wy, nx, ny, mu, paired, alternative, ci.lvl, x.name, y.name, group.name) {
if (paired) {
xv <- xv - yv
yv <- NULL
}
mu.x.w <- stats::weighted.mean(xv, wx)
var.x.w <- weighted_sd(xv, wx)^2
se.x <- sqrt(var.x.w / nx)
if (!is.null(yv)) {
mu.y.w <- stats::weighted.mean(yv, wy)
var.y.w <- weighted_sd(yv, wy)^2
se.y <- sqrt(var.y.w / ny)
se <- sqrt(se.x^2 + se.y^2)
df <- se^4 / (se.x^4 / (nx - 1) + se.y^4 / (ny - 1))
tstat <- (mu.x.w - mu.y.w - mu) / se
estimate <- c(mu.x.w, mu.y.w)
names(estimate) <- c("mean of x", "mean of y")
method <- "Two-Sample t-test"
} else {
se <- se.x
df <- nx - 1
tstat <- (mu.x.w - mu) / se
estimate <- stats::setNames(mu.x.w, if (paired) "mean of the differences" else "mean of x")
method <- if (paired) "Paired t-test" else "One Sample t-test"
}
if (alternative == "less") {
pval <- stats::pt(tstat, df)
cint <- c(-Inf, tstat + stats::qt(ci.lvl, df))
} else if (alternative == "greater") {
pval <- stats::pt(tstat, df, lower.tail = FALSE)
cint <- c(tstat - stats::qt(ci.lvl, df), Inf)
} else {
pval <- 2 * stats::pt(-abs(tstat), df)
alpha <- 1 - ci.lvl
cint <- stats::qt(1 - alpha / 2, df)
cint <- tstat + c(-cint, cint)
}
cint <- mu + cint * se
names(tstat) <- "t"
names(df) <- "df"
names(mu) <- if (paired || !is.null(yv)) "difference in means" else "mean"
tt <- structure(
class = "sj_ttest",
list(
estimate = estimate,
statistic = tstat,
df = df,
p.value = pval,
ci = cint,
alternative = alternative,
method = method
)
)
attr(tt, "x.name") <- x.name
attr(tt, "y.name") <- y.name
attr(tt, "group.name") <- group.name
tt
}
sjstats/R/cv_error.R 0000644 0001762 0000144 00000005655 13475522121 014127 0 ustar ligges users #' @title Test and training error from model cross-validation
#' @name cv_error
#'
#' @description \code{cv_error()} computes the root mean squared error from a model fitted
#' to kfold cross-validated test-training-data. \code{cv_compare()}
#' does the same, for multiple formulas at once (by calling \code{cv_error()}
#' for each formula).
#'
#' @param data A data frame.
#' @param formula The formula to fit the linear model for the test and training data.
#' @param formulas A list of formulas, to fit linear models for the test and training data.
#' @param k The number of folds for the kfold-crossvalidation.
#'
#' @return A data frame with the root mean squared errors for the training and test data.
#'
#' @details \code{cv_error()} first generates cross-validated test-training pairs, using
#' \code{\link[modelr]{crossv_kfold}} and then fits a linear model, which
#' is described in \code{formula}, to the training data. Then, predictions
#' for the test data are computed, based on the trained models.
#' The \emph{training error} is the mean value of the \code{\link{rmse}} for
#' all \emph{trained} models; the \emph{test error} is the rmse based on all
#' residuals from the test data.
#'
#' @examples
#' data(efc)
#' cv_error(efc, neg_c_7 ~ barthtot + c161sex)
#'
#' cv_compare(efc, formulas = list(
#' neg_c_7 ~ barthtot + c161sex,
#' neg_c_7 ~ barthtot + c161sex + e42dep,
#' neg_c_7 ~ barthtot + c12hour
#' ))
#'
#' @importFrom modelr crossv_kfold
#' @importFrom dplyr mutate summarise
#' @importFrom purrr map map2 map_dbl map_df
#' @importFrom broom augment
#' @importFrom tidyr unnest
#' @importFrom rlang .data
#' @importFrom insight find_response
#' @importFrom performance rmse
#' @export
cv_error <- function(data, formula, k = 5) {
# compute cross validation data
cv_data <- data %>%
modelr::crossv_kfold(k = k) %>%
dplyr::mutate(
trained.models = purrr::map(.data$train, ~ stats::lm(formula, data = .x)),
predicted = purrr::map2(.data$trained.models, .data$test, ~ broom::augment(.x, newdata = .y)),
residuals = purrr::map(.data$predicted, ~.x[[insight::find_response(formula)]] - .x$.fitted),
rmse.train = purrr::map_dbl(.data$trained.models, ~ performance::rmse(.x))
)
# Training error
train.error <- dplyr::summarise(cv_data, train.error = mean(.data$rmse.train, na.rm = TRUE))
# Test error
test.error <- cv_data %>%
tidyr::unnest(.data$predicted, .data$residuals) %>%
dplyr::summarise(test.error = sqrt(mean(.data$residuals^2, na.rm = TRUE)))
data_frame(
model = deparse(formula),
train.error = round(train.error[[1]], 4),
test.error = round(test.error[[1]], 4)
)
}
#' @rdname cv_error
#' @export
cv_compare <- function(data, formulas, k = 5) {
purrr::map_df(formulas, ~ cv_error(data, formula = .x, k = k))
}
sjstats/R/prop.R 0000644 0001762 0000144 00000022034 13752226261 013260 0 ustar ligges users #' @title Proportions of values in a vector
#' @name prop
#'
#' @description \code{prop()} calculates the proportion of a value or category
#' in a variable. \code{props()} does the same, but allows for
#' multiple logical conditions in one statement. It is similar
#' to \code{mean()} with logical predicates, however, both
#' \code{prop()} and \code{props()} work with grouped data frames.
#'
#' @param data A data frame. May also be a grouped data frame (see 'Examples').
#' @param ... One or more value pairs of comparisons (logical predicates). Put
#' variable names the left-hand-side and values to match on the
#' right hand side. Expressions may be quoted or unquoted. See
#' 'Examples'.
#' @param weights Vector of weights that will be applied to weight all observations.
#' Must be a vector of same length as the input vector. Default is
#' \code{NULL}, so no weights are used.
#' @param na.rm Logical, whether to remove NA values from the vector when the
#' proportion is calculated. \code{na.rm = FALSE} gives you the raw
#' percentage of a value in a vector, \code{na.rm = TRUE} the valid
#' percentage.
#' @param digits Amount of digits for returned values.
#'
#' @details \code{prop()} only allows one logical statement per comparison,
#' while \code{props()} allows multiple logical statements per comparison.
#' However, \code{prop()} supports weighting of variables before calculating
#' proportions, and comparisons may also be quoted. Hence, \code{prop()}
#' also processes comparisons, which are passed as character vector
#' (see 'Examples').
#'
#'
#' @return For one condition, a numeric value with the proportion of the values
#' inside a vector. For more than one condition, a data frame with one column
#' of conditions and one column with proportions. For grouped data frames,
#' returns a data frame with one column per group with grouping categories,
#' followed by one column with proportions per condition.
#'
#' @examples
#' data(efc)
#'
#' # proportion of value 1 in e42dep
#' prop(efc, e42dep == 1)
#'
#' # expression may also be completely quoted
#' prop(efc, "e42dep == 1")
#'
#' # use "props()" for multiple logical statements
#' props(efc, e17age > 70 & e17age < 80)
#'
#' # proportion of value 1 in e42dep, and all values greater
#' # than 2 in e42dep, including missing values. will return a data frame
#' prop(efc, e42dep == 1, e42dep > 2, na.rm = FALSE)
#'
#' # for factors or character vectors, use quoted or unquoted values
#' library(sjmisc)
#' # convert numeric to factor, using labels as factor levels
#' efc$e16sex <- to_label(efc$e16sex)
#' efc$n4pstu <- to_label(efc$n4pstu)
#'
#' # get proportion of female older persons
#' prop(efc, e16sex == female)
#'
#' # get proportion of male older persons
#' prop(efc, e16sex == "male")
#'
#' # "props()" needs quotes around non-numeric factor levels
#' props(efc,
#' e17age > 70 & e17age < 80,
#' n4pstu == 'Care Level 1' | n4pstu == 'Care Level 3'
#' )
#'
#' # also works with pipe-chains
#' library(dplyr)
#' efc %>% prop(e17age > 70)
#' efc %>% prop(e17age > 70, e16sex == 1)
#'
#' # and with group_by
#' efc %>%
#' group_by(e16sex) %>%
#' prop(e42dep > 2)
#'
#' efc %>%
#' select(e42dep, c161sex, c172code, e16sex) %>%
#' group_by(c161sex, c172code) %>%
#' prop(e42dep > 2, e16sex == 1)
#'
#' # same for "props()"
#' efc %>%
#' select(e42dep, c161sex, c172code, c12hour, n4pstu) %>%
#' group_by(c161sex, c172code) %>%
#' props(
#' e42dep > 2,
#' c12hour > 20 & c12hour < 40,
#' n4pstu == 'Care Level 1' | n4pstu == 'Care Level 3'
#' )
#'
#' @importFrom dplyr bind_cols bind_rows
#' @importFrom sjlabelled get_label get_labels as_numeric
#' @export
prop <- function(data, ..., weights = NULL, na.rm = TRUE, digits = 4) {
# check argument
if (!is.data.frame(data)) stop("`data` needs to be a data frame.", call. = F)
# get dots
dots <- match.call(expand.dots = FALSE)$`...`
proportions(data, dots, weight.by = weights, na.rm, digits, multi_logical = FALSE)
}
#' @rdname prop
#' @export
props <- function(data, ..., na.rm = TRUE, digits = 4) {
# check argument
if (!is.data.frame(data)) stop("`data` needs to be a data frame.", call. = F)
# get dots
dots <- match.call(expand.dots = FALSE)$`...`
proportions(data, dots, NULL, na.rm, digits, multi_logical = TRUE)
}
#' @importFrom purrr map_df
proportions <- function(data, dots, weight.by, na.rm, digits, multi_logical) {
# remember comparisons
comparisons <- lapply(dots, function(x) {
# to character, and remove spaces and quotes
x <- gsub(" ", "", deparse(x), fixed = T)
x <- gsub("\"", "", x, fixed = TRUE)
x
})
# do we have a grouped data frame?
if (inherits(data, "grouped_df")) {
# remember order of values
reihenfolge <- NULL
# get grouped data
grps <- get_grouped_data(data)
# now get proportions for each subset
fr <- purrr::map_df(
seq_len(nrow(grps)),
function(i) {
# get data from grouped data frame
.d <- grps$data[[i]]
# iterate dots (comparing conditions)
if (multi_logical)
result <- lapply(dots, get_multiple_proportion, .d, na.rm, digits)
else
result <- lapply(dots, get_proportion, .d, weight.by, na.rm, digits)
as.data.frame(t(unlist(result)))
}
)
# now we need the values from the groups of the grouped data frame
for (i in (ncol(grps) - 1):1) {
# get value label
var.name <- colnames(grps)[i]
val.labels <- suppressWarnings(
rep(sjlabelled::get_labels(data[[var.name]]), length.out = nrow(fr))
)
# if we have no value labels, use values instead
if (is.null(val.labels)) {
val.labels <-
rep(unique(sort(data[[var.name]])), length.out = nrow(fr))
}
# add row order, based on values of grouping variables
reihenfolge <- rep(sort(unique(sjlabelled::as_numeric(data[[var.name]]))), length.out = nrow(fr)) %>%
as.data.frame() %>%
dplyr::bind_cols(reihenfolge)
# bind values as column
fr <- dplyr::bind_cols(data.frame(val.labels, stringsAsFactors = FALSE), fr)
}
# get column names. we need variable labels as column names
var.names <- colnames(grps)[seq_len(ncol(grps) - 1)]
var.labels <- sjlabelled::get_label(data[, var.names], def.value = var.names)
# set variable labels and comparisons as colum names
colnames(fr) <- c(var.labels, comparisons)
# order rows by values of grouping variables
fr <- fr[do.call(order, reihenfolge), ]
return(fr)
} else {
# iterate dots (comparing conditions)
if (multi_logical)
result <- lapply(dots, get_multiple_proportion, data, na.rm, digits)
else
result <- lapply(dots, get_proportion, data, weight.by, na.rm, digits)
# if we have more than one proportion, return a data frame. this allows us
# to save more information, the condition and the proportion value
if (length(comparisons) > 1) {
return(data_frame(
condition = as.character(unlist(comparisons)),
prop = unlist(result)
))
}
return(unlist(result))
}
}
get_proportion <- function(x, data, weight.by, na.rm, digits) {
# to character, and remove spaces and quotes
x <- gsub(" ", "", deparse(x), fixed = T)
x <- gsub("\"", "", x, fixed = TRUE)
# split expression at ==, < or >
x.parts <- unlist(regmatches(x, gregexpr("[!=]=|[<>]|(?:(?![=!]=)[^<>])+", x, perl = TRUE)))
# shorter version, however, does not split variable names with dots
# x.parts <- unlist(regmatches(x, regexec("(\\w+)(\\W+)(\\w+)", x)))[-1]
# correct == assignment?
if (length(x.parts) < 3) {
message("?Syntax error in argument. You possibly used `=` instead of `==`.")
return(NULL)
}
# get variable from data and value from equation
f <- data[[x.parts[1]]]
v <- suppressWarnings(as.numeric(x.parts[3]))
# if we have factor, values maybe non-numeric
if (is.na(v)) v <- x.parts[3]
# weight vector?
if (!is.null(weight.by)) f <- weight(f, weights = weight.by)
# get proportions
if (x.parts[2] == "==")
dummy <- f == v
else if (x.parts[2] == "!=")
dummy <- f != v
else if (x.parts[2] == "<")
dummy <- f < v
else if (x.parts[2] == ">")
dummy <- f > v
else
dummy <- f == v
# remove missings?
if (na.rm) dummy <- na.omit(dummy)
# get proportion
round(sum(dummy, na.rm = T) / length(dummy), digits = digits)
}
get_multiple_proportion <- function(x, data, na.rm, digits) {
# evaluate argument
dummy <- with(data, eval(parse(text = deparse(x))))
# remove missings?
if (na.rm) dummy <- na.omit(dummy)
# get proportion
round(sum(dummy, na.rm = T) / length(dummy), digits = digits)
}
sjstats/R/anova_stats.R 0000644 0001762 0000144 00000015275 13776047636 014650 0 ustar ligges users #' @title Effect size statistics for anova
#' @name anova_stats
#' @description Returns the (partial) eta-squared, (partial) omega-squared,
#' epsilon-squared statistic or Cohen's F for all terms in an anovas.
#' \code{anova_stats()} returns a tidy summary, including all these statistics
#' and power for each term.
#'
#' @param model A fitted anova-model of class \code{aov} or \code{anova}. Other
#' models are coerced to \code{\link[stats]{anova}}.
#' @param digits Amount of digits for returned values.
#'
#' @return A data frame with all statistics is returned (excluding confidence intervals).
#'
#' @references Levine TR, Hullett CR (2002): Eta Squared, Partial Eta Squared, and Misreporting of Effect Size in Communication Research.
#' \cr \cr
#' Tippey K, Longnecker MT (2016): An Ad Hoc Method for Computing Pseudo-Effect Size for Mixed Model.
#'
#' @examples
#' # load sample data
#' data(efc)
#'
#' # fit linear model
#' fit <- aov(
#' c12hour ~ as.factor(e42dep) + as.factor(c172code) + c160age,
#' data = efc
#' )
#' \dontrun{
#' anova_stats(car::Anova(fit, type = 2))
#' }
#' @importFrom sjmisc add_columns round_num
#' @importFrom stats anova
#' @export
anova_stats <- function(model, digits = 3) {
if (!requireNamespace("pwr", quietly = TRUE)) {
stop("Package `pwr` needed for this function to work. Please install it.", call. = FALSE)
}
# .Deprecated("effectsize::effectsize()", package = "effectsize")
# get tidy summary table
aov.sum <- aov_stat_summary(model)
# compute all model statistics
etasq <- aov_stat_core(aov.sum, type = "eta")
partial.etasq <- aov_stat_core(aov.sum, type = "peta")
omegasq <- aov_stat_core(aov.sum, type = "omega")
partial.omegasq <- aov_stat_core(aov.sum, type = "pomega")
epsilonsq <- aov_stat_core(aov.sum, type = "epsilon")
# compute power for each estimate
cohens.f <- sqrt(partial.etasq / (1 - partial.etasq))
# bind as data frame
as <- dplyr::bind_rows(
data.frame(etasq, partial.etasq, omegasq, partial.omegasq, epsilonsq, cohens.f),
data.frame(etasq = NA, partial.etasq = NA, omegasq = NA, partial.omegasq = NA, epsilonsq = NA, cohens.f = NA)
) %>%
sjmisc::add_columns(aov.sum)
# get nr of terms
nt <- nrow(as) - 1
# finally, compute power
power <- tryCatch(
{
c(
pwr::pwr.f2.test(u = as$df[1:nt], v = as$df[nrow(as)], f2 = as$cohens.f[1:nt]^2)[["power"]],
NA
)
},
error = function(x) {
NA
}
)
out <- sjmisc::add_variables(as, power = power) %>%
sjmisc::round_num(digits = digits) %>%
as.data.frame()
class(out) <- c("sj_anova_stat", class(out))
out
}
#' @importFrom dplyr mutate
#' @importFrom rlang .data
aov_stat <- function(model, type) {
aov.sum <- aov_stat_summary(model)
aov.res <- aov_stat_core(aov.sum, type)
if (obj_has_name(aov.sum, "stratum"))
attr(aov.res, "stratum") <- aov.sum[["stratum"]]
aov.res
}
#' @importFrom stats anova residuals
#' @importFrom broom tidy
aov_stat_summary <- function(model) {
# check if we have a mixed model
mm <- is_merMod(model)
ori.model <- model
# check that model inherits from correct class
# else, try to coerce to anova table
if (!inherits(model, c("Gam", "aov", "anova", "anova.rms", "aovlist")))
model <- stats::anova(model)
# get summary table
aov.sum <- as.data.frame(broom::tidy(model))
# for mixed models, add information on residuals
if (mm) {
res <- stats::residuals(ori.model)
aov.sum <- dplyr::bind_rows(
aov.sum,
data_frame(
term = "Residuals",
df = length(res) - sum(aov.sum[["df"]]),
sumsq = sum(res^2, na.rm = TRUE),
meansq = mse(ori.model),
statistic = NA
)
)
}
# check if object has sums of square
if (!obj_has_name(aov.sum, "sumsq")) {
stop("Model object has no sums of squares. Cannot compute effect size statistic.", call. = FALSE)
}
# need special handling for rms-anova
if (inherits(model, "anova.rms"))
colnames(aov.sum) <- c("term", "df", "sumsq", "meansq", "statistic", "p.value")
# for car::Anova, the meansq-column might be missing, so add it manually
if (!obj_has_name(aov.sum, "meansq"))
aov.sum <- sjmisc::add_variables(aov.sum, meansq = aov.sum$sumsq / aov.sum$df, .after = "sumsq")
intercept <- .which_intercept(aov.sum$term)
if (length(intercept) > 0) {
aov.sum <- aov.sum[-intercept, ]
}
aov.sum
}
aov_stat_core <- function(aov.sum, type) {
intercept <- .which_intercept(aov.sum$term)
if (length(intercept) > 0) {
aov.sum <- aov.sum[-intercept, ]
}
# get mean squared of residuals
meansq.resid <- aov.sum[["meansq"]][nrow(aov.sum)]
# get total sum of squares
ss.total <- sum(aov.sum[["sumsq"]])
# get sum of squares of residuals
ss.resid <- aov.sum[["sumsq"]][nrow(aov.sum)]
# number of terms in model
n_terms <- nrow(aov.sum) - 1
# number of observations
N <- sum(aov.sum[["df"]]) + 1
if (type == "omega") {
# compute omega squared for each model term
aovstat <- purrr::map_dbl(1:n_terms, function(x) {
ss.term <- aov.sum[["sumsq"]][x]
df.term <- aov.sum[["df"]][x]
(ss.term - df.term * meansq.resid) / (ss.total + meansq.resid)
})
} else if (type == "pomega") {
# compute partial omega squared for each model term
aovstat <- purrr::map_dbl(1:n_terms, function(x) {
df.term <- aov.sum[["df"]][x]
meansq.term <- aov.sum[["meansq"]][x]
(df.term * (meansq.term - meansq.resid)) / (df.term * meansq.term + (N - df.term) * meansq.resid)
})
} else if (type == "epsilon") {
# compute epsilon squared for each model term
aovstat <- purrr::map_dbl(1:n_terms, function(x) {
ss.term <- aov.sum[["sumsq"]][x]
df.term <- aov.sum[["df"]][x]
(ss.term - df.term * meansq.resid) / ss.total
})
} else if (type == "eta") {
# compute eta squared for each model term
aovstat <-
purrr::map_dbl(1:n_terms, ~ aov.sum[["sumsq"]][.x] / sum(aov.sum[["sumsq"]]))
} else if (type %in% c("cohens.f", "peta")) {
# compute partial eta squared for each model term
aovstat <-
purrr::map_dbl(1:n_terms, ~ aov.sum[["sumsq"]][.x] / (aov.sum[["sumsq"]][.x] + ss.resid))
}
# compute Cohen's F
if (type == "cohens.f") aovstat <- sqrt(aovstat / (1 - aovstat))
# give values names of terms
names(aovstat) <- aov.sum[["term"]][1:n_terms]
aovstat
}
.which_intercept <- function(x) {
which(tolower(x) %in% c("(intercept)_zi", "intercept (zero-inflated)", "intercept", "zi_intercept", "(intercept)", "b_intercept", "b_zi_intercept"))
}
sjstats/R/phi.R 0000644 0001762 0000144 00000002323 13566035401 013054 0 ustar ligges users #' @rdname crosstable_statistics
#' @export
phi <- function(tab, ...) {
UseMethod("phi")
}
#' @export
phi.table <- function(tab, ...) {
.phi(tab)
}
#' @export
phi.ftable <- function(tab, ...) {
.phi(tab)
}
#' @export
phi.formula <- function(formula, data, ci.lvl = NULL, n = 1000, method = c("dist", "quantile"), ...) {
terms <- all.vars(formula)
tab <- table(data[[terms[1]]], data[[terms[2]]])
method <- match.arg(method)
if (is.null(ci.lvl) || is.na(ci.lvl)) {
.cramer(tab)
} else {
ci <- data[, terms] %>%
sjstats::bootstrap(n) %>%
dplyr::mutate(
tables = lapply(.data$strap, function(x) {
dat <- as.data.frame(x)
table(dat[[1]], dat[[2]])
}),
phis = sapply(.data$tables, function(x) .cramer(x))
) %>%
dplyr::pull("phis") %>%
boot_ci(ci.lvl = ci.lvl, method = method)
data_frame(
phi = .phi(tab),
conf.low = ci$conf.low,
conf.high = ci$conf.high
)
}
}
.phi <- function(tab) {
# convert to flat table
if (!inherits(tab, "ftable")) tab <- stats::ftable(tab)
tb <- summary(MASS::loglm(~1 + 2, tab))$tests
sqrt(tb[2, 1] / sum(tab))
}
sjstats/R/helpfunctions.R 0000644 0001762 0000144 00000003525 13775547147 015203 0 ustar ligges users # Help-functions
data_frame <- function(...) {
x <- data.frame(..., stringsAsFactors = FALSE)
rownames(x) <- NULL
x
}
is_merMod <- function(fit) {
inherits(fit, c("lmerMod", "glmerMod", "nlmerMod", "merModLmerTest"))
}
is_stan_model <- function(fit) {
inherits(fit, c("stanreg", "stanfit", "brmsfit"))
}
#' @importFrom sjmisc str_contains
get_glm_family <- function(fit) {
c.f <- class(fit)
# do we have glm? if so, get link family. make exceptions
# for specific models that don't have family function
if (any(c.f %in% c("lme", "plm"))) {
fitfam <- ""
logit_link <- FALSE
} else {
fitfam <- stats::family(fit)$family
logit_link <- stats::family(fit)$link == "logit"
}
# create logical for family
binom_fam <- fitfam %in% c("binomial", "quasibinomial")
poisson_fam <- fitfam %in% c("poisson", "quasipoisson") ||
sjmisc::str_contains(fitfam, "negative binomial", ignore.case = T)
list(is_bin = binom_fam, is_pois = poisson_fam, is_logit = logit_link)
}
# return names of objects passed as ellipses argument
dot_names <- function(dots) unname(unlist(lapply(dots, as.character)))
#' @importFrom tidyr nest
#' @importFrom dplyr select filter group_vars
#' @importFrom stats complete.cases
#' @importFrom rlang .data
get_grouped_data <- function(x) {
# retain observations that are complete wrt grouping vars, then nest
grps <- x %>%
dplyr::group_modify(~ dplyr::filter(.x, stats::complete.cases(.y))) %>%
tidyr::nest()
# arrange data
if (length(dplyr::group_vars(x)) == 1)
reihe <- order(grps[[1]])
else
reihe <- order(grps[[1]], grps[[2]])
grps <- grps[reihe, ]
grps
}
.compact_character <- function(x) {
x[!sapply(x, function(i) is.null(i) || nchar(i) == 0 || is.na(i) || any(i == "NULL", na.rm = TRUE))]
}
sjstats/R/mean_n.R 0000644 0001762 0000144 00000006677 13446531537 013561 0 ustar ligges users #' @title Row means with min amount of valid values
#' @name mean_n
#' @description This function is similar to the SPSS \code{MEAN.n} function and computes
#' row means from a \code{data.frame} or \code{matrix} if at least \code{n}
#' values of a row are valid (and not \code{NA}).
#'
#' @param dat A data frame with at least two columns, where row means are applied.
#' @param n May either be
#' \itemize{
#' \item a numeric value that indicates the amount of valid values per row to calculate the row mean;
#' \item or a value between 0 and 1, indicating a proportion of valid values per row to calculate the row mean (see 'Details').
#' }
#' If a row's sum of valid values is less than \code{n}, \code{NA} will be returned as row mean value.
#' @param digits Numeric value indicating the number of decimal places to be used for rounding mean
#' value. Negative values are allowed (see 'Details').
#'
#' @return A vector with row mean values of \code{df} for those rows with at least \code{n}
#' valid values. Else, \code{NA} is returned.
#'
#' @details Rounding to a negative number of \code{digits} means rounding to a power of
#' ten, so for example mean_n(df, 3, digits = -2) rounds to the
#' nearest hundred. \cr \cr
#' For \code{n}, must be a numeric value from \code{0} to \code{ncol(dat)}. If
#' a \emph{row} in \code{dat} has at least \code{n} non-missing values, the
#' row mean is returned. If \code{n} is a non-integer value from 0 to 1,
#' \code{n} is considered to indicate the proportion of necessary non-missing
#' values per row. E.g., if \code{n = .75}, a row must have at least \code{ncol(dat) * n}
#' non-missing values for the row mean to be calculated. See 'Examples'.
#'
#' @references \href{http://r4stats.com/2014/09/03/adding-the-spss-mean-n-function-to-r/}{r4stats.com}
#'
#' @examples
#' dat <- data.frame(c1 = c(1,2,NA,4),
#' c2 = c(NA,2,NA,5),
#' c3 = c(NA,4,NA,NA),
#' c4 = c(2,3,7,8))
#'
#' # needs at least 4 non-missing values per row
#' mean_n(dat, 4) # 1 valid return value
#'
#' # needs at least 3 non-missing values per row
#' mean_n(dat, 3) # 2 valid return values
#'
#' # needs at least 2 non-missing values per row
#' mean_n(dat, 2)
#'
#' # needs at least 1 non-missing value per row
#' mean_n(dat, 1) # all means are shown
#'
#' # needs at least 50% of non-missing values per row
#' mean_n(dat, .5) # 3 valid return values
#'
#' # needs at least 75% of non-missing values per row
#' mean_n(dat, .75) # 2 valid return values
#'
#' @export
mean_n <- function(dat, n, digits = 2) {
# is 'n' indicating a proportion?
digs <- n %% 1
if (digs != 0) n <- round(ncol(dat) * digs)
# coerce matrix to data frame
if (is.matrix(dat)) dat <- as.data.frame(dat)
# check if we have a data framme with at least two columns
if (!is.data.frame(dat) || ncol(dat) < 2) {
warning("`dat` must be a data frame with at least two columns.", call. = TRUE)
return(NA)
}
# n may not be larger as df's amount of columns
if (ncol(dat) < n) {
warning("`n` must be smaller or equal to number of columns in data frame.", call. = TRUE)
return(NA)
}
round(apply(dat, 1, function(x) ifelse(sum(!is.na(x)) >= n, mean(x, na.rm = TRUE), NA)), digits)
}
sjstats/R/weight.R 0000644 0001762 0000144 00000006304 13522056671 013572 0 ustar ligges users #' @title Weight a variable
#' @name weight
#' @description These functions weight the variable \code{x} by
#' a specific vector of \code{weights}.
#'
#' @param x (Unweighted) variable.
#' @param weights Vector with same length as \code{x}, which
#' contains weight factors. Each value of \code{x} has a
#' specific assigned weight in \code{weights}.
#' @param digits Numeric value indicating the number of decimal places to be
#' used for rounding the weighted values. By default, this value is
#' \code{0}, i.e. the returned values are integer values.
#'
#' @return The weighted \code{x}.
#'
#' @details \code{weight2()} sums up all \code{weights} values of the associated
#' categories of \code{x}, whereas \code{weight()} uses a
#' \code{\link[stats]{xtabs}} formula to weight cases. Thus, \code{weight()}
#' may return a vector of different length than \code{x}.
#'
#' @note The values of the returned vector are in sorted order, whereas the values'
#' order of the original \code{x} may be spread randomly. Hence, \code{x} can't be
#' used, for instance, for further cross tabulation. In case you want to have
#' weighted contingency tables or (grouped) box plots etc., use the \code{weightBy}
#' argument of most functions.
#'
#' @examples
#' v <- sample(1:4, 20, TRUE)
#' table(v)
#' w <- abs(rnorm(20))
#' table(weight(v, w))
#' table(weight2(v, w))
#'
#' set.seed(1)
#' x <- sample(letters[1:5], size = 20, replace = TRUE)
#' w <- runif(n = 20)
#'
#' table(x)
#' table(weight(x, w))
#'
#' @importFrom stats na.pass xtabs
#' @importFrom sjlabelled as_numeric
#' @export
weight <- function(x, weights, digits = 0) {
# remember if x is numeric
x.is.num <- is.numeric(x)
# init values
weightedvar <- c()
wtab <- round(stats::xtabs(weights ~ x,
data = data.frame(weights = weights, x = x),
na.action = stats::na.pass,
exclude = NULL),
digits = digits)
# iterate all table values
for (w in seq_len(length(wtab))) {
# retrieve count of each table cell
w_count <- wtab[[w]]
# retrieve "cell name" which is identical to the variable value
# first check whether values are numeric or not
nval_ <- suppressWarnings(as.numeric(names(wtab[w])))
# if value is not numeric, use as is
if (is.na(nval_))
w_value <- names(wtab[w])
else
# else, use numeric value
w_value <- nval_
# append variable value, repeating it "w_count" times.
weightedvar <- c(weightedvar, rep(w_value, w_count))
}
# if we have NA values, weighted var is coerced to character.
# coerce back to numeric then here
if (!is.numeric(weightedvar) && x.is.num) weightedvar <- sjlabelled::as_numeric(weightedvar)
# return result
weightedvar
}
#' @rdname weight
#' @export
weight2 <- function(x, weights) {
items <- unique(x)
newvar <- c()
for (i in seq_len(length(items))) {
newcount <- round(sum(weights[which(x == items[i])]))
newvar <- c(newvar, rep(items[i], newcount))
}
newvar
}
sjstats/R/confint_ncg.R 0000644 0001762 0000144 00000007532 13446531537 014602 0 ustar ligges users # This function is a modified version from package MBESS
# copied from https://github.com/cran/MBESS/blob/master/R/conf.limits.ncf.R
# Author: Ken Kelley
# License: GPL-3
#' @importFrom stats pf qf
confint_ncg <- function(F.value = NULL, conf.level = 0.95, df.1 = NULL, df.2 = NULL) {
alpha.lower <- alpha.upper <- (1 - conf.level) / 2
tol <- 1e-09
Jumping.Prop <- 0.1
FAILED <- NULL
LL.0 <- stats::qf(p = alpha.lower * 5e-04, df1 = df.1, df2 = df.2)
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.0) - (1 - alpha.lower)
if (stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.0) < (1 - alpha.lower)) {
FAILED <- if (stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = 0) < 1 - alpha.lower)
LL.0 <- 1e-08
if (stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.0) < 1 - alpha.lower)
FAILED <- TRUE
}
if (is.null(FAILED)) {
LL.1 <- LL.2 <- LL.0
while (Diff > tol) {
LL.2 <- LL.1 * (1 + Jumping.Prop)
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.2) - (1 - alpha.lower)
LL.1 <- LL.2
}
LL.1 <- LL.2 / (1 + Jumping.Prop)
LL.Bounds <- c(LL.1, (LL.1 + LL.2) / 2, LL.2)
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.Bounds[2]) - (1 - alpha.lower)
while (abs(Diff) > tol) {
Diff.1 <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.Bounds[1]) - (1 - alpha.lower) > tol
Diff.2 <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.Bounds[2]) - (1 - alpha.lower) > tol
Diff.3 <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.Bounds[3]) - (1 - alpha.lower) > tol
if (isTRUE(Diff.1) & isTRUE(Diff.2) & !isTRUE(Diff.3)) {
LL.Bounds <-
c(LL.Bounds[2], (LL.Bounds[2] + LL.Bounds[3]) / 2, LL.Bounds[3])
}
if (isTRUE(Diff.1) & !isTRUE(Diff.2) & !isTRUE(Diff.3)) {
LL.Bounds <-
c(LL.Bounds[1], (LL.Bounds[1] + LL.Bounds[2]) / 2, LL.Bounds[2])
}
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = LL.Bounds[2]) - (1 - alpha.lower)
}
LL <- LL.Bounds[2]
}
if (!is.null(FAILED)) LL <- NA
FAILED.Up <- NULL
UL.0 <- stats::qf(p = 1 - alpha.upper * 5e-04, df1 = df.1, df2 = df.2)
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.0) - alpha.upper
if (Diff < 0) UL.0 <- 1e-08
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.0) - alpha.upper
if (Diff < 0) FAILED.Up <- TRUE
if (is.null(FAILED.Up)) {
UL.1 <- UL.2 <- UL.0
while (Diff > tol) {
UL.2 <- UL.1 * (1 + Jumping.Prop)
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.2) - alpha.upper
UL.1 <- UL.2
}
UL.1 <- UL.2 / (1 + Jumping.Prop)
UL.Bounds <- c(UL.1, (UL.1 + UL.2) / 2, UL.2)
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.Bounds[2]) - alpha.upper
while (abs(Diff) > tol) {
Diff.1 <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.Bounds[1]) - alpha.upper > tol
Diff.2 <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.Bounds[2]) - alpha.upper > tol
Diff.3 <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.Bounds[3]) - alpha.upper > tol
if (isTRUE(Diff.1) & isTRUE(Diff.2) & !isTRUE(Diff.3)) {
UL.Bounds <-
c(UL.Bounds[2], (UL.Bounds[2] + UL.Bounds[3]) / 2, UL.Bounds[3])
}
if (isTRUE(Diff.1) & !isTRUE(Diff.2) & !isTRUE(Diff.3)) {
UL.Bounds <- c(UL.Bounds[1], (UL.Bounds[1] +
UL.Bounds[2])/2, UL.Bounds[2])
}
Diff <- stats::pf(q = F.value, df1 = df.1, df2 = df.2, ncp = UL.Bounds[2]) - alpha.upper
}
UL <- UL.Bounds[2]
}
if (!is.null(FAILED.Up)) UL <- NA
list(Lower.Limit = LL, Upper.Limit = UL)
}
sjstats/R/wtd_mwu.R 0000644 0001762 0000144 00000003320 13737643670 013775 0 ustar ligges users #' @rdname weighted_sd
#' @export
weighted_mannwhitney <- function(data, ...) {
UseMethod("weighted_mannwhitney")
}
#' @importFrom dplyr select
#' @rdname weighted_sd
#' @export
weighted_mannwhitney.default <- function(data, x, grp, weights, ...) {
x.name <- deparse(substitute(x))
g.name <- deparse(substitute(grp))
w.name <- deparse(substitute(weights))
# create string with variable names
vars <- c(x.name, g.name, w.name)
# get data
dat <- suppressMessages(dplyr::select(data, !! vars))
dat <- na.omit(dat)
weighted_mannwhitney_helper(dat)
}
#' @importFrom dplyr select
#' @rdname weighted_sd
#' @export
weighted_mannwhitney.formula <- function(formula, data, ...) {
vars <- all.vars(formula)
# get data
dat <- suppressMessages(dplyr::select(data, !! vars))
dat <- na.omit(dat)
weighted_mannwhitney_helper(dat)
}
weighted_mannwhitney_helper <- function(dat, vars) {
# check if pkg survey is available
if (!requireNamespace("survey", quietly = TRUE)) {
stop("Package `survey` needed to for this function to work. Please install it.", call. = FALSE)
}
x.name <- colnames(dat)[1]
group.name <- colnames(dat)[2]
colnames(dat) <- c("x", "g", "w")
if (dplyr::n_distinct(dat$g, na.rm = TRUE) > 2) {
m <- "Weighted Kruskal-Wallis test"
method <- "KruskalWallis"
} else {
m <- "Weighted Mann-Whitney-U test"
method <- "wilcoxon"
}
design <- survey::svydesign(ids = ~0, data = dat, weights = ~w)
mw <- survey::svyranktest(formula = x ~ g, design, test = method)
attr(mw, "x.name") <- x.name
attr(mw, "group.name") <- group.name
class(mw) <- c("sj_wmwu", "list")
mw$method <- m
mw
}
sjstats/R/inequ_trends.R 0000644 0001762 0000144 00000010331 13446531537 015002 0 ustar ligges users #' @title Compute trends in status inequalities
#' @name inequ_trend
#'
#' @description This method computes the proportional change of absolute
#' (rate differences) and relative (rate ratios) inequalities
#' of prevalence rates for two different status groups, as proposed
#' by Mackenbach et al. (2015).
#'
#' @param data A data frame that contains the variables with prevalence rates for both low
#' and high status groups (see 'Examples').
#' @param prev.low The name of the variable with the prevalence rates for
#' the low status groups.
#' @param prev.hi The name of the variable with the prevalence rates for
#' the hi status groups.
#'
#' @return A data frame with the prevalence rates as well as the values for the
#' proportional change in absolute (\code{rd}) and relative (\code{rr})
#' ineqqualities.
#'
#' @references Mackenbach JP, Martikainen P, Menvielle G, de Gelder R. 2015. The Arithmetic of Reducing Relative and Absolute Inequalities in Health: A Theoretical Analysis Illustrated with European Mortality Data. Journal of Epidemiology and Community Health 70(7): 730-36. \doi{10.1136/jech-2015-207018}
#'
#' @details Given the time trend of prevalence rates of an outcome for two status
#' groups (e.g. the mortality rates for people with lower and higher
#' socioeconomic status over 40 years), this function computes the
#' proportional change of absolute and relative inequalities, expressed
#' in changes in rate differences and rate ratios. The function implements
#' the algorithm proposed by \emph{Mackenbach et al. 2015}.
#'
#' @examples
#' # This example reproduces Fig. 1 of Mackenbach et al. 2015, p.5
#'
#' # 40 simulated time points, with an initial rate ratio of 2 and
#' # a rate difference of 100 (i.e. low status group starts with a
#' # prevalence rate of 200, the high status group with 100)
#'
#' # annual decline of prevalence is 1% for the low, and 3% for the
#' # high status group
#'
#' n <- 40
#' time <- seq(1, n, by = 1)
#' lo <- rep(200, times = n)
#' for (i in 2:n) lo[i] <- lo[i - 1] * .99
#'
#' hi <- rep(100, times = n)
#' for (i in 2:n) hi[i] <- hi[i - 1] * .97
#'
#' prev.data <- data.frame(lo, hi)
#'
#' # print values
#' inequ_trend(prev.data, lo, hi)
#'
#' # plot trends - here we see that the relative inequalities
#' # are increasing over time, while the absolute inequalities
#' # are first increasing as well, but later are decreasing
#' # (while rel. inequ. are still increasing)
#' plot(inequ_trend(prev.data, lo, hi))
#'
#' @importFrom dplyr select
#' @importFrom rlang quo_name enquo .data
#' @export
inequ_trend <- function(data, prev.low, prev.hi) {
# prepare data for prevalence rates for low and hi status groups
if (is.null(data) || missing(data)) {
dat <- data.frame(prev.low, prev.hi)
} else {
# get variable names
# create quosures
low <- rlang::quo_name(rlang::enquo(prev.low))
high <- rlang::quo_name(rlang::enquo(prev.hi))
dat <- dplyr::select(data, !! low, !! high)
}
# ensure common column names
colnames(dat) <- c("lo", "hi")
# trends in rate ratios
# compute relative inequality for first time point, needed
# as reference to compute proportional change over time
dat$rr <- dat$lo[1] / dat$hi[1]
# compute proportional change of relative inequalities over time
for (t in 2:nrow(dat)) {
delta.low <- (dat$lo[t] - dat$lo[t - 1]) / dat$lo[t - 1]
delta.hi <- (dat$hi[t] - dat$hi[t - 1]) / dat$hi[t - 1]
dat$rr[t] <- dat$rr[t - 1] * ((1 + delta.low) / (1 + delta.hi))
}
# trends in rate difference
# compute absolute inequality for first time point, needed
# as reference to compute proportional change over time
dat$rd <- dat$lo[1] - dat$hi[1]
# compute proportional change of absolute inequalities over time
for (t in 2:nrow(dat)) {
delta.low <- (dat$lo[t] - dat$lo[t - 1]) / dat$lo[t - 1]
delta.hi <- (dat$hi[t] - dat$hi[t - 1]) / dat$hi[t - 1]
dat$rd[t] <- dat$rd[t - 1] + (dat$lo[t - 1 ] * delta.low - dat$hi[t - 1] * delta.hi)
}
# return
structure(class = "sj_inequ_trend", list(data = dat))
}
sjstats/R/se_ybar.R 0000644 0001762 0000144 00000003224 13616600205 013715 0 ustar ligges users #' @title Standard error of sample mean for mixed models
#' @name se_ybar
#'
#' @description Compute the standard error for the sample mean for mixed models,
#' regarding the extent to which clustering affects the standard errors.
#' May be used as part of the multilevel power calculation for cluster sampling
#' (see \cite{Gelman and Hill 2007, 447ff}).
#'
#' @param fit Fitted mixed effects model (\code{\link[lme4]{merMod}}-class).
#'
#' @return The standard error of the sample mean of \code{fit}.
#'
#' @references Gelman A, Hill J. 2007. Data analysis using regression and multilevel/hierarchical models. Cambridge, New York: Cambridge University Press
#'
#' @examples
#' if (require("lme4")) {
#' fit <- lmer(Reaction ~ 1 + (1 | Subject), sleepstudy)
#' se_ybar(fit)
#' }
#' @importFrom lme4 ngrps
#' @importFrom stats nobs
#' @importFrom purrr map_dbl
#' @export
se_ybar <- function(fit) {
# get model icc
vars <- insight::get_variance(fit, verbose = FALSE)
# get group variances
tau.00 <- unname(vars$var.intercept)
# total variance
tot_var <- sum(tau.00, vars$var.residual)
# get number of groups
m.cnt <- lme4::ngrps(fit)
# compute number of observations per group (level-2-unit)
obs <- round(stats::nobs(fit) / m.cnt)
# compute simple icc
icc <- tau.00 / tot_var
# compute standard error of sample mean
se <- purrr::map_dbl(seq_len(length(m.cnt)), ~ sqrt((tot_var / stats::nobs(fit)) * design_effect(n = obs[.x], icc = icc[.x])))
# give names for se, so user sees, which random effect has what impact
names(se) <- names(m.cnt)
se
}
sjstats/R/sjStatistics.R 0000644 0001762 0000144 00000003516 13446531537 015000 0 ustar ligges users #' @title Expected and relative table values
#' @name table_values
#' @description This function calculates a table's cell, row and column percentages as
#' well as expected values and returns all results as lists of tables.
#'
#' @param tab Simple \code{\link{table}} or \code{\link[stats]{ftable}} of which
#' cell, row and column percentages as well as expected values are calculated.
#' Tables of class \code{\link[stats]{xtabs}} and other will be coerced to
#' \code{ftable} objects.
#' @param digits Amount of digits for the table percentage values.
#'
#' @return (Invisibly) returns a list with four tables:
#' \enumerate{
#' \item \code{cell} a table with cell percentages of \code{tab}
#' \item \code{row} a table with row percentages of \code{tab}
#' \item \code{col} a table with column percentages of \code{tab}
#' \item \code{expected} a table with expected values of \code{tab}
#' }
#'
#' @examples
#' tab <- table(sample(1:2, 30, TRUE), sample(1:3, 30, TRUE))
#' # show expected values
#' table_values(tab)$expected
#' # show cell percentages
#' table_values(tab)$cell
#'
#' @export
table_values <- function(tab, digits = 2) {
# convert to ftable object
if (!inherits(tab, "ftable")) tab <- ftable(tab)
tab.cell <- round(100 * prop.table(tab), digits)
tab.row <- round(100 * prop.table(tab, 1), digits)
tab.col <- round(100 * prop.table(tab, 2), digits)
tab.expected <- as.table(round(as.array(margin.table(tab, 1)) %*% t(as.array(margin.table(tab, 2))) / margin.table(tab)))
# return results
invisible(structure(class = "sjutablevalues",
list(cell = tab.cell,
row = tab.row,
col = tab.col,
expected = tab.expected)))
}
sjstats/R/samplesize_mixed.R 0000644 0001762 0000144 00000011111 13616600205 015625 0 ustar ligges users #' @title Sample size for linear mixed models
#' @name samplesize_mixed
#'
#' @description Compute an approximated sample size for linear mixed models
#' (two-level-designs), based on power-calculation for standard
#' design and adjusted for design effect for 2-level-designs.
#'
#' @param eff.size Effect size.
#' @param df.n Optional argument for the degrees of freedom for numerator. See 'Details'.
#' @param power Power of test (1 minus Type II error probability).
#' @param sig.level Significance level (Type I error probability).
#' @param k Number of cluster groups (level-2-unit) in multilevel-design.
#' @param n Optional, number of observations per cluster groups
#' (level-2-unit) in multilevel-design.
#' @param icc Expected intraclass correlation coefficient for multilevel-model.
#'
#' @return A list with two values: The number of subjects per cluster, and the
#' total sample size for the linear mixed model.
#'
#' @references Cohen J. 1988. Statistical power analysis for the behavioral sciences (2nd ed.). Hillsdale,NJ: Lawrence Erlbaum.
#' \cr \cr
#' Hsieh FY, Lavori PW, Cohen HJ, Feussner JR. 2003. An Overview of Variance Inflation Factors for Sample-Size Calculation. Evaluation and the Health Professions 26: 239-257. \doi{10.1177/0163278703255230}
#' \cr \cr
#' Snijders TAB. 2005. Power and Sample Size in Multilevel Linear Models. In: Everitt BS, Howell DC (Hrsg.). Encyclopedia of Statistics in Behavioral Science. Chichester, UK: John Wiley and Sons, Ltd. \doi{10.1002/0470013192.bsa492}
#'
#' @details The sample size calculation is based on a power-calculation for the
#' standard design. If \code{df.n} is not specified, a power-calculation
#' for an unpaired two-sample t-test will be computed (using
#' \code{\link[pwr]{pwr.t.test}} of the \CRANpkg{pwr}-package).
#' If \code{df.n} is given, a power-calculation for general linear models
#' will be computed (using \code{\link[pwr]{pwr.f2.test}} of the
#' \pkg{pwr}-package). The sample size of the standard design
#' is then adjusted for the design effect of two-level-designs (see
#' \code{\link{design_effect}}). Thus, the sample size calculation is appropriate
#' in particular for two-level-designs (see \cite{Snijders 2005}). Models that
#' additionally include repeated measures (three-level-designs) may work
#' as well, however, the computed sample size may be less accurate.
#'
#' @examples
#' # Sample size for multilevel model with 30 cluster groups and a small to
#' # medium effect size (Cohen's d) of 0.3. 27 subjects per cluster and
#' # hence a total sample size of about 802 observations is needed.
#' samplesize_mixed(eff.size = .3, k = 30)
#'
#' # Sample size for multilevel model with 20 cluster groups and a medium
#' # to large effect size for linear models of 0.2. Five subjects per cluster and
#' # hence a total sample size of about 107 observations is needed.
#' samplesize_mixed(eff.size = .2, df.n = 5, k = 20, power = .9)
#' @export
samplesize_mixed <- function(eff.size, df.n = NULL, power = .8, sig.level = .05, k, n, icc = 0.05) {
if (!requireNamespace("pwr", quietly = TRUE)) {
stop("Package `pwr` needed for this function to work. Please install it.", call. = FALSE)
}
# compute sample size for standard design
if (is.null(df.n))
# if we have no degrees of freedom specified, use t-test
obs <- 2 * pwr::pwr.t.test(d = eff.size, sig.level = sig.level, power = power)$n
else
# we have df, so power-calc for linear models
obs <- pwr::pwr.f2.test(u = df.n, f2 = eff.size, sig.level = sig.level, power = power)$v + df.n + 1
# if we have no information on the number of observations per cluster,
# compute this number now
if (missing(n) || is.null(n)) {
n <- (obs * (1 - icc)) / (k - (obs * icc))
if (n < 1) {
warning("Minimum required number of subjects per cluster is negative and was adjusted to be positive. You may reduce the requirements for the multi-level structure (i.e. reduce `k` or `icc`), or you can increase the effect-size.", call. = FALSE)
n <- 1
}
}
# adjust standard design by design effect
total.n <- obs * design_effect(n = n, icc = icc)
# sample size for each group and total n
smpsz <- list(round(total.n / k), round(total.n))
# name list
names(smpsz) <- c("Subjects per Cluster", "Total Sample Size")
smpsz
}
#' @rdname samplesize_mixed
#' @export
smpsize_lmm <- samplesize_mixed
sjstats/R/wtd_cor.R 0000644 0001762 0000144 00000004233 13565537440 013750 0 ustar ligges users #' @rdname weighted_sd
#' @export
weighted_correlation <- function(data, ...) {
UseMethod("weighted_correlation")
}
#' @rdname weighted_sd
#' @export
weighted_correlation.default <- function(data, x, y, weights, ci.lvl = .95, ...) {
if (!missing(ci.lvl) & (length(ci.lvl) != 1 || !is.finite(ci.lvl) || ci.lvl < 0 || ci.lvl > 1))
stop("'ci.lvl' must be a single number between 0 and 1")
x.name <- deparse(substitute(x))
y.name <- deparse(substitute(y))
w.name <- deparse(substitute(weights))
if (w.name == "NULL") {
w.name <- "weights"
data$weights <- 1
}
# create string with variable names
vars <- c(x.name, y.name, w.name)
# get data
dat <- suppressMessages(dplyr::select(data, !! vars))
dat <- na.omit(dat)
xv <- dat[[x.name]]
yv <- dat[[y.name]]
wv <- dat[[w.name]]
weighted_correlation_helper(xv, yv, wv, ci.lvl)
}
#' @rdname weighted_sd
#' @export
weighted_correlation.formula <- function(formula, data, ci.lvl = .95, ...) {
if (!missing(ci.lvl) & (length(ci.lvl) != 1 || !is.finite(ci.lvl) || ci.lvl < 0 || ci.lvl > 1))
stop("'ci.lvl' must be a single number between 0 and 1")
vars <- all.vars(formula)
if (length(vars) < 3) {
vars <- c(vars, "weights")
data$weights <- 1
}
# get data
dat <- suppressMessages(dplyr::select(data, !! vars))
dat <- na.omit(dat)
xv <- dat[[vars[1]]]
yv <- dat[[vars[2]]]
wv <- dat[[vars[3]]]
weighted_correlation_helper(xv, yv, wv, ci.lvl)
}
#' @importFrom stats cor.test
weighted_correlation_helper <- function(xv, yv, wv, ci.lvl) {
x <- xv - weighted_mean(xv, weights = wv)
y <- yv - weighted_mean(yv, weights = wv)
x <- x / weighted_sd(x, weights = wv)
y <- y / weighted_sd(y, weights = wv)
results <- stats::coef(summary(stats::lm(y ~ x, weights = wv)))[2, ]
ci <- ci.lvl - ((1 - ci.lvl) / 2)
ci <- results[1] + (stats::qnorm(ci) * c(-1, 1) * results[2])
structure(
class = "sj_wcor",
list(
estimate = results[1],
method = "Pearson's Correlation Coefficient",
p.value = results[4],
ci = ci,
ci.lvl = ci.lvl
)
)
}
sjstats/R/wtd_mean.R 0000644 0001762 0000144 00000001217 13565537440 014104 0 ustar ligges users #' @rdname weighted_sd
#' @export
weighted_mean <- function(x, weights = NULL) {
UseMethod("weighted_mean")
}
#' @importFrom stats weighted.mean
#' @export
weighted_mean.default <- function(x, weights = NULL) {
if (is.null(weights)) weights <- rep(1, length(x))
stats::weighted.mean(x, w = weights, na.rm = TRUE)
}
#' @importFrom stats weighted.mean
#' @importFrom purrr map_dbl
#' @importFrom dplyr select_if
#' @export
weighted_mean.data.frame <- function(x, weights = NULL) {
if (is.null(weights)) weights <- rep(1, length(x))
dplyr::select_if(x, is.numeric) %>%
purrr::map_dbl(~ weighted.mean(.x, w = weights))
}
sjstats/R/wtd_variance.R 0000644 0001762 0000144 00000000363 13565537440 014755 0 ustar ligges users weighted_variance <- function(x, w) {
if (is.null(w)) w <- rep(1, length(x))
x[is.na(w)] <- NA
w[is.na(x)] <- NA
w <- na.omit(w)
x <- na.omit(x)
xbar <- sum(w * x) / sum(w)
sum(w * ((x - xbar)^2)) / (sum(w) - 1)
}
sjstats/R/bootstrap.R 0000644 0001762 0000144 00000010506 13752226230 014312 0 ustar ligges users #' @title Generate nonparametric bootstrap replications
#' @name bootstrap
#'
#' @description Generates \code{n} bootstrap samples of \code{data} and
#' returns the bootstrapped data frames as list-variable.
#'
#' @param data A data frame.
#' @param n Number of bootstraps to be generated.
#' @param size Optional, size of the bootstrap samples. May either be a number
#' between 1 and \code{nrow(data)} or a value between 0 and 1 to sample
#' a proportion of observations from \code{data} (see 'Examples').
#'
#' @return A data frame with one column: a list-variable
#' \code{strap}, which contains resample-objects of class \code{sj_resample}.
#' These resample-objects are lists with three elements:
#' \enumerate{
#' \item the original data frame, \code{data}
#' \item the rownmumbers \code{id}, i.e. rownumbers of \code{data}, indicating the resampled rows with replacement
#' \item the \code{resample.id}, indicating the index of the resample (i.e. the position of the \code{sj_resample}-object in the list \code{strap})
#' }
#'
#' @details By default, each bootstrap sample has the same number of observations
#' as \code{data}. To generate bootstrap samples without resampling
#' same observations (i.e. sampling without replacement), use
#' \code{size} to get bootstrapped data with a specific number
#' of observations. However, specifying the \code{size}-argument is much
#' less memory-efficient than the bootstrap with replacement. Hence,
#' it is recommended to ignore the \code{size}-argument, if it is
#' not really needed.
#'
#' @note This function applies nonparametric bootstrapping, i.e. the function
#' draws samples with replacement.
#' \cr \cr
#' There is an \code{as.data.frame}- and a \code{print}-method to get or
#' print the resampled data frames. See 'Examples'. The \code{as.data.frame}-
#' method automatically applies whenever coercion is done because a data
#' frame is required as input. See 'Examples' in \code{\link{boot_ci}}.
#'
#'
#' @seealso \code{\link{boot_ci}} to calculate confidence intervals from
#' bootstrap samples.
#'
#' @examples
#' data(efc)
#' bs <- bootstrap(efc, 5)
#'
#' # now run models for each bootstrapped sample
#' lapply(bs$strap, function(x) lm(neg_c_7 ~ e42dep + c161sex, data = x))
#'
#' # generate bootstrap samples with 600 observations for each sample
#' bs <- bootstrap(efc, 5, 600)
#'
#' # generate bootstrap samples with 70% observations of the original sample size
#' bs <- bootstrap(efc, 5, .7)
#'
#' # compute standard error for a simple vector from bootstraps
#' # use the `as.data.frame()`-method to get the resampled
#' # data frame
#' bs <- bootstrap(efc, 100)
#' bs$c12hour <- unlist(lapply(bs$strap, function(x) {
#' mean(as.data.frame(x)$c12hour, na.rm = TRUE)
#' }))
#'
#' # or as tidyverse-approach
#' if (require("dplyr") && require("purrr")) {
#' bs <- efc %>%
#' bootstrap(100) %>%
#' mutate(
#' c12hour = map_dbl(strap, ~mean(as.data.frame(.x)$c12hour, na.rm = TRUE))
#' )
#'
#' # bootstrapped standard error
#' boot_se(bs, c12hour)
#' }
#' @export
bootstrap <- function(data, n, size) {
if (!missing(size) && !is.null(size)) {
# check for valid range
if (size < 0 || size > nrow(data))
stop("`size` must be greater than 0, but not greater than number of rows of `data`.", call. = F)
# check if we want proportions
if (size < 1) size <- as.integer(nrow(data) * size)
# generate bootstraps w/o replacement
repl <- FALSE
} else {
# size = observations
size <- nrow(data)
# generate bootstraps with replacement
repl <- TRUE
}
# generate bootstrap resamples
strap <- replicate(n, resample(data, size, repl), simplify = FALSE)
# add resample ID, may be used for other functions (like 'se()' for 'icc()')
for (i in seq_len(length(strap))) strap[[i]]$resample.id <- i
# return daza frame
data.frame(strap = I(strap))
}
resample <- function(data, size, replace) {
structure(
class = "sj_resample",
list(
data = data,
id = sample(nrow(data), size = size, replace = replace)
))
}
sjstats/R/wtd_sd.R 0000644 0001762 0000144 00000011605 13775552446 013602 0 ustar ligges users #' @title Weighted statistics for tests and variables
#' @name weighted_sd
#' @description \strong{Weighted statistics for variables}
#' \cr \cr
#' \code{weighted_sd()}, \code{weighted_se()}, \code{weighted_mean()} and \code{weighted_median()}
#' compute weighted standard deviation, standard error, mean or median for a
#' variable or for all variables of a data frame. \code{survey_median()} computes the
#' median for a variable in a survey-design (see \code{\link[survey]{svydesign}}).
#' \code{weighted_correlation()} computes a weighted correlation for a two-sided alternative
#' hypothesis.
#' \cr \cr
#' \strong{Weighted tests}
#' \cr \cr
#' \code{weighted_ttest()} computes a weighted t-test, while \code{weighted_mannwhitney()}
#' computes a weighted Mann-Whitney-U test or a Kruskal-Wallis test
#' (for more than two groups). \code{weighted_chisqtest()} computes a weighted
#' Chi-squared test for contigency tables.
#'
#' @param x (Numeric) vector or a data frame. For \code{survey_median()}, \code{weighted_ttest()},
#' \code{weighted_mannwhitney()} and \code{weighted_chisqtest()} the bare (unquoted) variable
#' name, or a character vector with the variable name.
#' @param weights Bare (unquoted) variable name, or a character vector with
#' the variable name of the numeric vector of weights. If \code{weights = NULL},
#' unweighted statistic is reported.
#' @param data A data frame.
#' @param formula A formula of the form \code{lhs ~ rhs1 + rhs2} where \code{lhs} is a
#' numeric variable giving the data values and \code{rhs1} a factor with two
#' levels giving the corresponding groups and \code{rhs2} a variable with weights.
#' @param y Optional, bare (unquoted) variable name, or a character vector with
#' the variable name.
#' @param grp Bare (unquoted) name of the cross-classifying variable, where
#' \code{x} is grouped into the categories represented by \code{grp},
#' or a character vector with the variable name.
#' @param mu A number indicating the true value of the mean (or difference in
#' means if you are performing a two sample test).
#' @param ci.lvl Confidence level of the interval.
#' @param alternative A character string specifying the alternative hypothesis,
#' must be one of \code{"two.sided"} (default), \code{"greater"} or
#' \code{"less"}. You can specify just the initial letter.
#' @param paired Logical, whether to compute a paired t-test.
#' @param ... For \code{weighted_ttest()} and \code{weighted_mannwhitney()}, currently not used.
#' For \code{weighted_chisqtest()}, further arguments passed down to
#' \code{\link[stats]{chisq.test}}.
#'
#' @inheritParams svyglm.nb
#'
#' @return The weighted (test) statistic.
#'
#' @note \code{weighted_chisq()} is a convenient wrapper for \code{\link{crosstable_statistics}}.
#' For a weighted one-way Anova, use \code{means_by_group()} with
#' \code{weights}-argument.
#' \cr \cr
#' \code{weighted_ttest()} assumes unequal variance between the two groups.
#'
#' @examples
#' # weighted sd and se ----
#' weighted_sd(rnorm(n = 100, mean = 3), runif(n = 100))
#'
#' data(efc)
#' weighted_sd(efc[, 1:3], runif(n = nrow(efc)))
#' weighted_se(efc[, 1:3], runif(n = nrow(efc)))
#'
#' # survey_median ----
#' # median for variables from weighted survey designs
#' if (require("survey")) {
#' data(nhanes_sample)
#'
#' des <- svydesign(
#' id = ~SDMVPSU,
#' strat = ~SDMVSTRA,
#' weights = ~WTINT2YR,
#' nest = TRUE,
#' data = nhanes_sample
#' )
#'
#' survey_median(total, des)
#' survey_median("total", des)
#' }
#'
#' # weighted t-test ----
#' efc$weight <- abs(rnorm(nrow(efc), 1, .3))
#' weighted_ttest(efc, e17age, weights = weight)
#' weighted_ttest(efc, e17age, c160age, weights = weight)
#' weighted_ttest(e17age ~ e16sex + weight, efc)
#'
#' # weighted Mann-Whitney-U-test ----
#' weighted_mannwhitney(c12hour ~ c161sex + weight, efc)
#'
#' # weighted Chi-squared-test ----
#' weighted_chisqtest(efc, c161sex, e16sex, weights = weight, correct = FALSE)
#' weighted_chisqtest(c172code ~ c161sex + weight, efc)
#'
#' # weighted Chi-squared-test for given probabilities ----
#' weighted_chisqtest(c172code ~ weight, efc, p = c(.33, .33, .34))
#' @export
weighted_sd <- function(x, weights = NULL) {
UseMethod("weighted_sd")
}
#' @rdname weighted_sd
#' @export
wtd_sd <- weighted_sd
#' @export
weighted_sd.data.frame <- function(x, weights = NULL) {
sd_result <- purrr::map_dbl(x, ~ sqrt(weighted_variance(.x, weights)))
names(sd_result) <- colnames(x)
sd_result
}
#' @export
weighted_sd.matrix <- function(x, weights = NULL) {
sd_result <- purrr::map_dbl(x, ~ sqrt(weighted_variance(.x, weights)))
names(sd_result) <- colnames(x)
sd_result
}
#' @export
weighted_sd.default <- function(x, weights = NULL) {
sqrt(weighted_variance(x, weights))
}
sjstats/R/svy_median.R 0000644 0001762 0000144 00000001037 13565537440 014444 0 ustar ligges users #' @rdname weighted_sd
#' @importFrom stats as.formula
#' @export
survey_median <- function(x, design) {
# check if pkg survey is available
if (!requireNamespace("survey", quietly = TRUE)) {
stop("Package `survey` needed to for this function to work. Please install it.", call. = FALSE)
}
# deparse
v <- stats::as.formula(paste("~", as.character(substitute(x))))
as.vector(
survey::svyquantile(
v,
design = design,
quantiles = 0.5,
ci = FALSE,
na.rm = TRUE
)
)
}
sjstats/R/auto_prior.R 0000644 0001762 0000144 00000012530 13470603205 014455 0 ustar ligges users #' @title Create default priors for brms-models
#' @name auto_prior
#'
#' @description This function creates default priors for brms-regression
#' models, based on the same automatic prior-scale adjustment as in
#' \pkg{rstanarm}.
#'
#' @param formula A formula describing the model, which just needs to contain
#' the model terms, but no notation of interaction, splines etc. Usually,
#' you want only those predictors in the formula, for which automatic
#' priors should be generated. Add informative priors afterwards to the
#' returned \code{brmsprior}-object.
#' @param data The data that will be used to fit the model.
#' @param gaussian Logical, if the outcome is gaussian or not.
#' @param locations A numeric vector with location values for the priors. If
#' \code{locations = NULL}, \code{0} is used as location parameter.
#'
#' @return A \code{brmsprior}-object.
#'
#' @details \code{auto_prior()} is a small, convenient function to create
#' some default priors for brms-models with automatically adjusted prior
#' scales, in a similar way like \pkg{rstanarm} does. The default scale for
#' the intercept is 10, for coefficients 2.5. If the outcome is gaussian,
#' both scales are multiplied with \code{sd(y)}. Then, for categorical
#' variables, nothing more is changed. For numeric variables, the scales
#' are divided by the standard deviation of the related variable.
#' \cr \cr
#' All prior distributions are \emph{normal} distributions. \code{auto_prior()}
#' is intended to quickly create default priors with feasible scales. If
#' more precise definitions of priors is necessary, this needs to be done
#' directly with brms-functions like \code{set_prior()}.
#'
#' @note As \code{auto_prior()} also sets priors on the intercept, the model
#' formula used in \code{brms::brm()} must be rewritten to something like
#' \code{y ~ 0 + intercept ...}, see \code{\link[brms]{set_prior}}.
#'
#' @examples
#' library(sjmisc)
#' data(efc)
#' efc$c172code <- as.factor(efc$c172code)
#' efc$c161sex <- to_label(efc$c161sex)
#'
#' mf <- formula(neg_c_7 ~ c161sex + c160age + c172code)
#'
#' if (requireNamespace("brms", quietly = TRUE))
#' auto_prior(mf, efc, TRUE)
#'
#' ## compare to
#' # library(rstanarm)
#' # m <- stan_glm(mf, data = efc, chains = 2, iter = 200)
#' # ps <- prior_summary(m)
#' # ps$prior_intercept$adjusted_scale
#' # ps$prior$adjusted_scale
#'
#' ## usage
#' # ap <- auto_prior(mf, efc, TRUE)
#' # brm(mf, data = efc, priors = ap)
#'
#' # add informative priors
#' mf <- formula(neg_c_7 ~ c161sex + c172code)
#'
#' if (requireNamespace("brms", quietly = TRUE)) {
#' auto_prior(mf, efc, TRUE) +
#' brms::prior(normal(.1554, 40), class = "b", coef = "c160age")
#' }
#'
#' # example with binary response
#' efc$neg_c_7d <- ifelse(efc$neg_c_7 < median(efc$neg_c_7, na.rm = TRUE), 0, 1)
#' mf <- formula(neg_c_7d ~ c161sex + c160age + c172code + e17age)
#'
#' if (requireNamespace("brms", quietly = TRUE))
#' auto_prior(mf, efc, FALSE)
#'
#' @importFrom stats sd na.omit
#' @importFrom dplyr select n_distinct
#' @importFrom insight find_predictors find_response
#' @export
auto_prior <- function(formula, data, gaussian, locations = NULL) {
if (!requireNamespace("brms", quietly = TRUE))
stop("Package `brms` required.", call. = FALSE)
scale.b <- 2.5
scale.y <- 10
pred <- insight::find_predictors(formula, effects = "all", flatten = TRUE)
y.name <- insight::find_response(formula, combine = TRUE)
cols <- c(y.name, pred)
data <- data %>%
dplyr::select(!! cols) %>%
stats::na.omit() %>%
as.data.frame()
y <- data[[y.name]]
# check if response is binary
if (missing(gaussian) && dplyr::n_distinct(y, na.rm = TRUE) == 2) gaussian <- FALSE
if (isTRUE(gaussian) && dplyr::n_distinct(y, na.rm = TRUE) == 2)
warning("Priors were calculated based on assumption that the response is Gaussian, however it seems to be binary.", call. = F)
if (gaussian) {
scale.factor <- stats::sd(y, na.rm = TRUE)
scale.b <- scale.b * scale.factor
scale.y <- scale.y * scale.factor
}
if (!is.null(locations))
location.y <- locations[1]
else
location.y <- 0
priors <- brms::set_prior(
sprintf("normal(%s, %s)", round(location.y, 2), round(scale.y, 2)),
class = "Intercept"
)
is.fac <- NULL
term.names <- NULL
scale.pred <- NULL
# we need to check which predictors are categorical and then "mimic"
# their coefficient name as it is represented in the model (i.e. variable
# name + category name)
for (i in pred) {
f <- data[[i]]
if (is.factor(f)) {
i <- sprintf("%s%s", i, levels(f)[2:nlevels(f)])
is.fac <- c(is.fac, rep(TRUE, nlevels(f) - 1))
scale.pred <- c(scale.pred, rep(scale.b, nlevels(f) - 1))
} else {
is.fac <- c(is.fac, FALSE)
scale.pred <- c(scale.pred, scale.b / stats::sd(f, na.rm = TRUE))
}
term.names <- c(term.names, i)
}
for (i in 1:length(term.names)) {
if (!is.null(locations) && length(locations) >= (i + 1))
location.b <- locations[i + 1]
else
location.b <- 0
priors <- priors + brms::set_prior(
sprintf("normal(%s, %s)", round(location.b, 2), round(scale.pred[i], 2)),
class = "b",
coef = term.names[i]
)
}
priors
}
sjstats/R/xtab_statistics.R 0000644 0001762 0000144 00000023343 13775603126 015520 0 ustar ligges users #' @title Measures of association for contingency tables
#' @name crosstable_statistics
#'
#' @description This function calculates various measure of association for
#' contingency tables and returns the statistic and p-value.
#' Supported measures are Cramer's V, Phi, Spearman's rho,
#' Kendall's tau and Pearson's r.
#'
#' @param data A data frame or a table object. If a table object, \code{x1} and
#' \code{x2} will be ignored. For Kendall's \emph{tau}, Spearman's \emph{rho}
#' or Pearson's product moment correlation coefficient, \code{data} needs
#' to be a data frame. If \code{x1} and \code{x2} are not specified,
#' the first two columns of the data frames are used as variables
#' to compute the crosstab.
#' @param formula A formula of the form \code{lhs ~ rhs} where \code{lhs} is a
#' numeric variable giving the data values and \code{rhs} a factor giving the
#' corresponding groups.
#' @param tab A \code{\link{table}} or \code{\link[stats]{ftable}}. Tables of class
#' \code{\link[stats]{xtabs}} and other will be coerced to \code{ftable}
#' objects.
#' @param x1 Name of first variable that should be used to compute the
#' contingency table. If \code{data} is a table object, this argument
#' will be irgnored.
#' @param x2 Name of second variable that should be used to compute the
#' contingency table. If \code{data} is a table object, this argument
#' will be irgnored.
#' @param statistics Name of measure of association that should be computed. May
#' be one of \code{"auto"}, \code{"cramer"}, \code{"phi"}, \code{"spearman"},
#' \code{"kendall"}, \code{"pearson"} or \code{"fisher"}. See 'Details'.
#' @param ci.lvl Scalar between 0 and 1. If not \code{NULL}, returns a data
#' frame including lower and upper confidence intervals.
#' @param ... Other arguments, passed down to the statistic functions
#' \code{\link[stats]{chisq.test}}, \code{\link[stats]{fisher.test}} or
#' \code{\link[stats]{cor.test}}.
#'
#' @inheritParams means_by_group
#' @inheritParams bootstrap
#' @inheritParams boot_ci
#'
#' @return For \code{phi()}, the table's Phi value. For \code{cramer()}, the
#' table's Cramer's V.
#' \cr \cr
#' For \code{crosstable_statistics()}, a list with following components:
#' \describe{
#' \item{\code{estimate}}{the value of the estimated measure of association.}
#' \item{\code{p.value}}{the p-value for the test.}
#' \item{\code{statistic}}{the value of the test statistic.}
#' \item{\code{stat.name}}{the name of the test statistic.}
#' \item{\code{stat.html}}{if applicable, the name of the test statistic, in HTML-format.}
#' \item{\code{df}}{the degrees of freedom for the contingency table.}
#' \item{\code{method}}{character string indicating the name of the measure of association.}
#' \item{\code{method.html}}{if applicable, the name of the measure of association, in HTML-format.}
#' \item{\code{method.short}}{the short form of association measure, equals the \code{statistics}-argument.}
#' \item{\code{fisher}}{logical, if Fisher's exact test was used to calculate the p-value.}
#' }
#'
#' @details The p-value for Cramer's V and the Phi coefficient are based
#' on \code{chisq.test()}. If any expected value of a table cell is
#' smaller than 5, or smaller than 10 and the df is 1, then \code{fisher.test()}
#' is used to compute the p-value, unless \code{statistics = "fisher"}; in
#' this case, the use of \code{fisher.test()} is forced to compute the
#' p-value. The test statistic is calculated with \code{cramer()} resp.
#' \code{phi()}.
#' \cr \cr
#' Both test statistic and p-value for Spearman's rho, Kendall's tau
#' and Pearson's r are calculated with \code{cor.test()}.
#' \cr \cr
#' When \code{statistics = "auto"}, only Cramer's V or Phi are calculated,
#' based on the dimension of the table (i.e. if the table has more than
#' two rows or columns, Cramer's V is calculated, else Phi).
#'
#' @examples
#' # Phi coefficient for 2x2 tables
#' tab <- table(sample(1:2, 30, TRUE), sample(1:2, 30, TRUE))
#' phi(tab)
#'
#' # Cramer's V for nominal variables with more than 2 categories
#' tab <- table(sample(1:2, 30, TRUE), sample(1:3, 30, TRUE))
#' cramer(tab)
#'
#' # formula notation
#' data(efc)
#' cramer(e16sex ~ c161sex, data = efc)
#'
#' # bootstrapped confidence intervals
#' cramer(e16sex ~ c161sex, data = efc, ci.lvl = .95, n = 100)
#'
#' # 2x2 table, compute Phi automatically
#' crosstable_statistics(efc, e16sex, c161sex)
#'
#' # more dimensions than 2x2, compute Cramer's V automatically
#' crosstable_statistics(efc, c172code, c161sex)
#'
#' # ordinal data, use Kendall's tau
#' crosstable_statistics(efc, e42dep, quol_5, statistics = "kendall")
#'
#' # calcilate Spearman's rho, with continuity correction
#' crosstable_statistics(efc,
#' e42dep,
#' quol_5,
#' statistics = "spearman",
#' exact = FALSE,
#' continuity = TRUE
#' )
#'
#' @importFrom stats fisher.test chisq.test cor.test ftable
#' @importFrom dplyr case_when
#' @importFrom MASS loglm
#' @importFrom rlang quo_name enquo
#' @export
crosstable_statistics <- function(data, x1 = NULL, x2 = NULL, statistics = c("auto", "cramer", "phi", "spearman", "kendall", "pearson", "fisher"), weights = NULL, ...) {
# match arguments
statistics <- match.arg(statistics)
# name for test statistics in HTML
stat.html <- NULL
# check if data is a table
if (!is.table(data)) {
# evaluate unquoted names
x1 <- deparse(substitute(x1))
x2 <- deparse(substitute(x2))
weights <- deparse(substitute(weights))
# if names were quotes, remove quotes
x1 <- gsub("\"", "", x1, fixed = T)
x2 <- gsub("\"", "", x2, fixed = T)
weights <- gsub("\"", "", weights, fixed = T)
if (sjmisc::is_empty(weights) || weights == "NULL")
weights <- NULL
else
weights <- data[[weights]]
# check for "NULL" and get data
if (x1 != "NULL" && x2 != "NULL")
data <- data[, c(x1, x2)]
else
data <- data[, 1:2]
if (!is.null(weights)) data <- cbind(data, weights)
# make table
if (!is.null(weights)) {
tab <- as.table(round(stats::xtabs(data[[3]] ~ data[[1]] + data[[2]])))
class(tab) <- "table"
} else
tab <- table(data)
} else {
# 'data' is a table - copy to table object
tab <- data
# check if statistics are possible to compute
if (statistics %in% c("spearman", "kendall", "pearson")) {
stop(
sprintf(
"Need arguments `data`, `x1` and `x2` to compute %s-statistics.",
statistics
),
call. = F
)
}
}
# get expected values
tab.val <- table_values(tab)
# remember whether fisher's exact test was used or not
use.fisher <- FALSE
# select statistics automatically, based on number of rows/columns
if (statistics %in% c("auto", "cramer", "phi", "fisher")) {
# get chisq-statistics, for df and p-value
chsq <- suppressWarnings(stats::chisq.test(tab, ...))
pv <- chsq$p.value
test <- chsq$statistic
# set statistics name
names(test) <- "Chi-squared"
stat.html <- "χ2"
# check row/columns
if ((nrow(tab) > 2 || ncol(tab) > 2 || statistics %in% c("cramer", "fisher")) && statistics != "phi") {
# get cramer's V
s <- cramer(tab)
# if minimum expected values below 5, compute fisher's exact test
if (statistics == "fisher" ||
min(tab.val$expected) < 5 ||
(min(tab.val$expected) < 10 && chsq$parameter == 1)) {
pv <- stats::fisher.test(tab, simulate.p.value = TRUE, ...)$p.value
use.fisher <- TRUE
}
# set statistics
statistics <- "cramer"
} else {
# get Phi
s <- phi(tab)
# if minimum expected values below 5 and df=1, compute fisher's exact test
if (min(tab.val$expected) < 5 ||
(min(tab.val$expected) < 10 && chsq$parameter == 1)) {
pv <- stats::fisher.test(tab, ...)$p.value
use.fisher <- TRUE
}
# set statistics
statistics <- "phi"
}
} else {
# compute correlation coefficient
cv <- stats::cor.test(x = data[[1]], y = data[[2]], method = statistics, ...)
# get statistics and p-value
s <- cv$estimate
pv <- cv$p.value
test <- cv$statistic
stat.html <- names(test)
}
# compute method string
method <- dplyr::case_when(
statistics == "kendall" ~ "Kendall's tau",
statistics == "spearman" ~ "Spearman's rho",
statistics == "pearson" ~ "Pearson's r",
statistics == "cramer" ~ "Cramer's V",
statistics == "phi" ~ "Phi"
)
# compute method string
method.html <- dplyr::case_when(
statistics == "kendall" ~ "Kendall's τ",
statistics == "spearman" ~ "Spearman's ρ",
statistics == "pearson" ~ "Pearson's r",
statistics == "cramer" ~ "Cramer's V",
statistics == "phi" ~ "φ"
)
# return result
structure(class = "sj_xtab_stat", list(
estimate = s,
p.value = pv,
statistic = test,
stat.name = names(test),
stat.html = stat.html,
df = (nrow(tab) - 1) * (ncol(tab) - 1),
n_obs = sum(tab, na.rm = TRUE),
method = method,
method.html = method.html,
method.short = statistics,
fisher = use.fisher
))
}
#' @rdname crosstable_statistics
#' @export
xtab_statistics <- crosstable_statistics
sjstats/NEWS.md 0000644 0001762 0000144 00000032601 13775643062 013062 0 ustar ligges users # sjstats 0.18.1
## Deprecated and defunct
_sjstats_ is being re-structured, and many functions are re-implemented in new packages that are part of a new project called **easystats**.
Therefore, following functions are now defunct:
* `mediation()`, , please use `bayestestR::mediation()`.
* `eta_sq()`, please use `effectsize::eta_squared()`.
* `omega_sq()`, please use `effectsize::omega_squared()`.
* `epsilon_sq()`, please use `effectsize::epsilon_squared()`.
* `odds_to_rr()`, please use `effectsize::oddsratio_to_riskratio()`.
* `std_beta()`, please use `effectsize::standardize_parameters()`.
* `robust()`, please use `parameters::standard_error_robust()`.
* `scale_weights()`, , please use `parameters::rescale_weights()`.
## General
* Improved printing for `weighted_mannwhitney()`.
* `weighted_chisqtest()` can now be computed for given probabilities.
* `means_by_group()` now contains numeric values in the returned data frame. Value formatting is completely done insight the print-method.
* Updated imports.
# sjstats 0.18.0
## General
* Effect size computation functions (like `eta_sq()`) now internally call the related functions from the *effectsize* package.
* Remove packages from "Suggest" that have been removed from CRAN.
# sjstats 0.17.9
## Bug fixes
* Fixed documentation for `chisq_gof()`.
* Fixed issue in `anova_stats()` with incorrect effect sizes for certain Anova types (that included an intercept).
# sjstats 0.17.8
## Deprecated and defunct
_sjstats_ is being re-structured, and many functions are re-implemented in new packages that are part of a new project called **easystats**.
Therefore, following functions are now deprecated:
* `cohens_f()`, please use `effectsize::cohens_f()`.
* `std_beta()`, please use `effectsize::standardize_parameters()`.
* `tidy_stan()`, please use `parameters::model_parameters()`.
* `scale_weights()`, please use `parameters::rescale_weights()`.
* `robust()`, please use `parameters::standard_error_robust()`.
## General
* Functions for weighted statistics with prefix `wtd_*()` have been renamed to `weighted_*()`.
* `svy_md()` was renamed to `survey_median()`.
* `mannwhitney()` is an alias for `mwu()`.
* `means_by_group()` is an alias for `grpmean()`.
# sjstats 0.17.7
## Deprecated and defunct
_sjstats_ is being re-structured, and many functions are re-implemented in new packages that are part of a new project called **easystats**. The aim of **easystats** is to provide a unifying and consistent framework to tame, discipline and harness the scary R statistics and their pesky models.
Therefore, following functions are now deprecated:
* `p_value()`, please use `parameters::p_value()`
* `se()`, please use `parameters::standard_error()`
## General
* Revise some functions to cope with the forthcoming _insight_ update.
# sjstats 0.17.6
## General
* Minor revisions to meet the changes in the forthcoming update from *tidyr*.
* `design_effect()` is an alias for `deff()`.
* `samplesize_mixed()` is an alias for `smpsize_lmm()`.
* `crosstable_statistics()` is an alias for `xtab_statistics()`.
## New functions
* `svyglm.zip()` to fit zero-inflated Poisson models for survey-designs.
## Changes to functions
* `phi()` and `cramer()` can now compute confidence intervals.
* `tidy_stan()` removes prior parameters from output.
* `tidy_stan()` now also prints the probability of direction.
## Bug fixes
* Fix bug with wrong computation in `odds_to_rr()`.
# sjstats 0.17.5
## New functions
* `epsilon_sq()`, to compute epsilon-squared effect-size.
## Deprecated and defunct
_sjstats_ is being re-structured, and many functions are re-implemented in new packages that are part of a new project called **easystats**. The aim of **easystats** is to provide a unifying and consistent framework to tame, discipline and harness the scary R statistics and their pesky models.
Therefore, following functions are now deprecated:
* `link_inverse()`, please use `insight::link_inverse()`
* `model_family()`, please use `insight::model_info()`
* `model_frame()`, please use `insight::get_data()`
* `pred_vars()`, please use `insight::find_predictors()`
* `re_grp_var()`, please use `insight::find_random()`
* `grp_var()`, please use `insight::find_random()`
* `resp_val()`, please use `insight::get_response()`
* `resp_var()`, please use `insight::find_response()`
* `var_names()`, please use `insight::clean_names()`
* `overdisp()`, please use `performance::check_overdispersion()`
* `zero_count()`, please use `performance::check_zeroinflation()`
* `converge_ok()`, please use `performance::check_convergence()`
* `is_singular()`, please use `performance::check_singularity()`
* `reliab_test()`, please use `performance::item_reliability()`
* `split_half()`, please use `performance::item_split_half()`
* `predictive_accurarcy()`, please use `performance::performance_accuracy()`
* `cronb()`, please use `performance::cronbachs_alpha()`
* `difficulty()`, please use `performance::item_difficulty()`
* `mic()`, please use `performance::item_intercor()`
* `pca()`, please use `parameters::principal_components()`
* `pca_rotate()`, please use `parameters::principal_components()`
* `r2()`, please use `performance::r2()`
* `icc()`, please use `performance::icc()`
* `rmse()`, please use `performance::rmse()`
* `rse()`, please use `performance::rse()`
* `mse()`, please use `performance::mse()`
* `hdi()`, please use `bayestestR::hdi()`
* `cred_int()`, please use `bayestestR::ci()`
* `rope()`, please use `bayestestR::rope()`
* `n_eff()`, please use `bayestestR::effective_sample()`
* `equi_test()`, please use `bayestestR::equivalence_test()`
* `multicollin()`, please use `performance::check_collinearity()`
* `normality()`, please use `performance::check_normality()`
* `autocorrelation()`, please use `performance::check_autocorrelation()`
* `heteroskedastic()`, please use `performance::check_heteroscedasticity()`
* `outliers()`, please use `performance::check_outliers()`
## Changes to functions
* Anova-stats functions (like `eta_sq()`) get a `method`-argument to define the method for computing confidence intervals from bootstrapping.
## Bug fixes
* In some situations, `smpsize_lmm()` could result in negative sample-size recommendations. This was fixed, and a warning is now shown indicating that the parameters for the power-calculation should be modified.
* Fixed issue with wrong calculated effect size `r` in `mwu()` if group-factor contained more than two groups.
# sjstats 0.17.4
## General
* Following models/objects are now supported by model-information functions like `model_family()`, `link_inverse()` or `model_frame()`: `MixMod` (package **GLMMadaptive**), **MCMCglmm**, `mlogit` and `gmnl`.
* Reduce package dependencies.
## New functions
* `cred_int()`, to compute uncertainty intervals of Bayesian models. Mimics the behaviour and style of `hdi()` and is thus a convenient complement to functions like `posterior_interval()`.
## Changes to functions
* `equi_test()` now finds better defaults for models with binomial outcome (like logistic regression models).
* `r2()` for mixed models now also should work properly for mixed models fitted with **rstanarm**.
* `anova_stats()` and alike (e.g. `eta_sq()`) now all preserve original term names.
* `model_family()` now returns `$is_count = TRUE`, when model is a count-model, and `$is_beta = TRUE` for models with beta-family.
* `pred_vars()` checks that return value has only unique values.
* `pred_vars()` gets a `zi`-argument to return the variables from a model's zero-inflation-formula.
## Bug fixes
* Fix minor issues in `wtd_sd()` and `wtd_mean()` when weight was `NULL` (which usually shoudln't be the case anyway).
* Fix potential issue with `deparse()`, cutting off very long formulas in various functions.
* Fix encoding issues in help-files.
# sjstats 0.17.3
## General
* Export `dplyr::n()`, to meet forthcoming changes in dplyr 0.8.0.
## Changes to functions
* `boot_ci()` gets a `ci.lvl`-argument.
* The `rotation`-argument in `pca_rotate()` now supports all rotations from `psych::principal()`.
* `pred_vars()` gets a `fe.only`-argument to return only fixed effects terms from mixed models, and a `disp`-argument to return the variables from a model's dispersion-formula.
* `icc()` for Bayesian models gets a `adjusted`-argument, to calculate adjusted and conditional ICC (however, only for Gaussian models).
* For `icc()` for non-Gaussian Bayes-models, a message is printed that recommends setting argument `ppd` to `TRUE`.
* `resp_val()` and `resp_var()` now also work for **brms**-models with additional response information (like `trial()` in formula).
* `resp_var()` gets a `combine`-argument, to return either the name of the matrix-column or the original variable names for matrix-columns.
* `model_frame()` now also returns the original variables for matrix-column-variables.
* `model_frame()` now also returns the variable from the dispersion-formula of **glmmTMB**-models.
* `model_family()` and `link_inverse()` now supports **glmmPQL**, **felm** and **lm_robust**-models.
* `anova_stats()` and alike (`omeqa_sq()` etc.) now support gam-models from package **gam**.
* `p_value()` now supports objects of class `svyolr`.
## Bug fixes
* Fix issue with `se()` and `get_re_var()` for objects returned by `icc()`.
* Fix issue with `icc()` for Stan-models.
* `var_names()` did not clear terms with log-log transformation, e.g. `log(log(y))`.
* Fix issue in `model_frame()` for models with splines with only one column.
# sjstats 0.17.2
## General
* Revised help-files for `r2()` and `icc()`, also by adding more references.
## New functions
* `re_grp_var()` to find group factors of random effects in mixed models.
## Changes to functions
* `omega_sq()` and `eta_sq()` give more informative messages when using non-supported objects.
* `r2()` and `icc()` give more informative warnings and messages.
* `tidy_stan()` supports printing simplex parameters of monotonic effects of **brms** models.
* `grpmean()` and `mwu()` get a `file` and `encoding` argument, to save the HTML output as file.
## Bug fixes
* `model_frame()` now correctly names the offset-columns for terms provided as `offset`-argument (i.e. for models where the offset was not specified inside the formula).
* Fixed issue with `weights`-argument in `grpmean()` when variable name was passed as character vector.
* Fixed issue with `r2()` for **glmmTMB** models with `ar1` random effects structure.
# sjstats 0.17.1
## New functions
* `wtd_chisqtest()` to compute a weighted Chi-squared test.
* `wtd_median()` to compute the weighted median of variables.
* `wtd_cor()` to compute weighted correlation coefficients of variables.
## Changes to functions
* `mediation()` can now cope with models from different families, e.g. if the moderator or outcome is binary, while the treatment-effect is continuous.
* `model_frame()`, `link_inverse()`, `pred_vars()`, `resp_var()`, `resp_val()`, `r2()` and `model_family()` now support `clm2`-objects from package **ordinal**.
* `anova_stats()` gives a more informative message for non-supported models or ANOVA-options.
## Bug fixes
* Fixed issue with `model_family()` and `link_inverse()` for models fitted with `pscl::hurdle()` or `pscl::zeroinfl()`.
* Fixed issue with wrong title in `grpmean()` for grouped data frames, when grouping variable was an unlabelled factor.
* Fix issue with `model_frame()` for **coxph**-models with polynomial or spline-terms.
* Fix issue with `mediation()` for logical variables.
# sjstats 0.17.0
## General
* Reduce package dependencies.
## New functions
* `wtd_ttest()` to compute a weighted t-test.
* `wtd_mwu()` to compute a weighted Mann-Whitney-U or Kruskal-Wallis test.
## Changes to functions
* `robust()` was revised, getting more arguments to specify different types of covariance-matrix estimation, and handling these more flexible.
* Improved `print()`-method for `tidy_stan()` for _brmsfit_-objects with categorical-families.
* `se()` now also computes standard errors for relative frequencies (proportions) of a vector.
* `r2()` now also computes r-squared values for _glmmTMB_-models from `genpois`-families.
* `r2()` gives more precise warnings for non-supported model-families.
* `xtab_statistics()` gets a `weights`-argument, to compute measures of association for contingency tables for weighted data.
* The `statistics`-argument in `xtab_statistics()` gets a `"fisher"`-option, to force Fisher's Exact Test to be used.
* Improved variance calculation in `icc()` for generalized linear mixed models with Poisson or negative binomial families.
* `icc()` gets an `adjusted`-argument, to calculate the adjusted and conditional ICC for mixed models.
* To get consistent argument names across functions, argument `weight.by` is now deprecated and renamed into `weights`.
## Bug fixes
* Fix issues with effect size computation for repeated-measure Anova when using bootstrapping to compute confidence intervals.
* `grpmean()` now also adjusts the `n`-columm for weighted data.
* `icc()`, `re_var()` and `get_re_var()` now correctly compute the random-effect-variances for models with multiple random slopes per random effect term (e.g., `(1 + rs1 + rs2 | grp)`).
* Fix issues in `tidy_stan()`, `mcse()`, `hdi()` and `n_eff()` for `stan_polr()`-models.
* Plotting `equi_test()` did not work for intercept-only models.
sjstats/MD5 0000644 0001762 0000144 00000010151 13776332212 012261 0 ustar ligges users b7966baa7122c37cbc430fca38db1e98 *DESCRIPTION
f2a898ea73bbd52122cadb117eee1e76 *NAMESPACE
47ffcf50509287551b9aeeb4077809ca *NEWS.md
a8f77a308188589b960ef47a9a23b18c *R/Deprecated.R
fb8d6eb125fee2fabf009b867db1d1b5 *R/S3-methods.R
ad27262ce66eb9c9dbea01bce9b6fb52 *R/anova_stats.R
f07eed02567e501ebc291a4ebdbbd9b2 *R/auto_prior.R
926b2f1a188efc0e698871f96c5e5ed6 *R/boot_ci.R
1d29c0c9220a3e3cc6b40a8df483caa6 *R/bootstrap.R
ea51177798ebdfd83ad092412b937b63 *R/confint_ncg.R
d536ef944364404cd1eedc2bf6f3300d *R/cramer.R
14e247414c7be80d273cd60b8e44c1e8 *R/cv.R
572a948ece805e4f15769713798c111d *R/cv_error.R
b826d04f20826fbf7e12669244ca6e1f *R/design_effect.R
393c5a76c2a9592e1979b0c34d85d093 *R/find_beta.R
a61407560a52844cc57f2db4f6f32811 *R/gmd.R
2649cb20ef7ee2dd4f2de1a2af15c2e9 *R/gof.R
e3bd665daaa8d429d2fa925d33f5238f *R/grpmean.R
261300bda7318ffeb672b73bd46103c1 *R/helpfunctions.R
1b9e99c02100ee536af9059f2a80a8d5 *R/inequ_trends.R
dfccc2131f58c0a3641918a664039ad0 *R/is_prime.R
072cc67c0e694bbb3ebbb67dcf525096 *R/mean_n.R
c9bde8a5b6cfb500d72a792431d1d6de *R/mwu.R
95ac928d84740007386966a5acd85477 *R/nhanes_sample.R
63eccf7ae760a9fd1497fd374c168f16 *R/phi.R
8f44ddf80b2c82cbf6709d3f3967340d *R/prop.R
dfc5bc76bc96881840ccdc1d20c0d28d *R/re-exports.R
ec1e70b39f84ece79ba1bbc6e66c5b1e *R/samplesize_mixed.R
86af38a4c7f24e92bfa4156dd0be571b *R/se_ybar.R
d6df9bca022b5be049b3a00a93103588 *R/select_helpers.R
d792df143be0e996bbb0250b8040b4b0 *R/sjStatistics.R
9f085ad99cbf2a750a2983a2a24b8853 *R/svy_median.R
ff40d9acba8b23b58f79a64594b58656 *R/svyglmnb.R
dc33faa5c79b0f3570d3cb735b64214c *R/svyglmzip.R
d549884ec18b554f9c6580b889139352 *R/var_pop.R
c2c15305243436e9e9a3e3267b6c9566 *R/weight.R
0a98761ea167301e89cb12bf21e89403 *R/wtd_chisqtest.R
27a862c6531a93dade159942c38d2d68 *R/wtd_cor.R
43e3310d2af50ef270842e050f3bb5c3 *R/wtd_mean.R
a6e86670a86c94b5f1ba7cb75a696232 *R/wtd_median.R
982d73e8af2a410167963f3bcbb1de79 *R/wtd_mwu.R
fe7484f3ad2bd6c0844db42b5531f0b3 *R/wtd_sd.R
553b33cbd7cb656ad3e3fe104f89c409 *R/wtd_se.R
b4b6dab951e3e86d5b895c9dd0b64776 *R/wtd_ttest.R
941be6a71a50e541fbc4f868c3baf7e5 *R/wtd_variance.R
b60f53ee2a8ce45d43d453fde6256537 *R/xtab_statistics.R
8ff2c67601e1a844d2cf3ad10868c43f *README.md
c77daf072b42f0b3114f2f2cb506249c *build/partial.rdb
3172b22b3d87d0f86d78326bc26891fc *data/efc.RData
ad3f18b79c24699a3c122d8b377b5028 *data/nhanes_sample.RData
87f8a6a5cb2f59e0b2110feef3926498 *inst/CITATION
16046e6b6e6cadab6fd578c36ca48068 *man/anova_stats.Rd
3aec13c45b1db134d328251fc90c62e3 *man/auto_prior.Rd
47683ecf898416021113278f4732fd7f *man/boot_ci.Rd
059263f9a19bfa1bd80ef05a536137a2 *man/bootstrap.Rd
1baa9c02deed5d6cdf58ef8e0056367f *man/chisq_gof.Rd
190898720e6d9388c1f67c69e1672bd5 *man/crosstable_statistics.Rd
fb53c0eb619eef30a654341f6bb02737 *man/cv.Rd
2cb00c307543ac8e799df75227b37c6e *man/cv_error.Rd
cc8c96d49a9ff5e7638c6bd7ba85f759 *man/design_effect.Rd
07b7d0ca4d598d4623ef85ce91255f2c *man/efc.Rd
00a3f8db1d678464d37705968d42286f *man/figures/logo.png
6e4050c7d457ebcdd164526512ff122b *man/find_beta.Rd
a1a4bead83e969bed2a3382748273f0f *man/gmd.Rd
ae3b5572ebfd84fd612e84f9e0add80e *man/inequ_trend.Rd
dd8cf1ee0d3efa4a89706be8804764b5 *man/is_prime.Rd
1aa949852b5c1efbc383a7325af19f97 *man/mean_n.Rd
da2ce27f4b07911e872826d78704ba17 *man/means_by_group.Rd
b163fa3f5ba0da21c47f36a0c718fd88 *man/mwu.Rd
56194e97259a636ddc45a645824c90a5 *man/nhanes_sample.Rd
388b81647b359b025365090d02e2167f *man/prop.Rd
0bff2025be74cf3d90b0472d76f15b72 *man/r2.Rd
a2c07995753a1b6e01a6a437fcada3ad *man/reexports.Rd
e4c6c9e95a114be42c5b95a57d513ecd *man/samplesize_mixed.Rd
06d31eef5a3c62468b5419c32e0e7379 *man/se_ybar.Rd
9e1209f05bdd6685104b1606b6edd7a1 *man/svyglm.nb.Rd
427d552b579c751150f14f534134fadd *man/svyglm.zip.Rd
f30a70c9da7de433db7fad6cb9917cea *man/table_values.Rd
d4d7e8473a71fe077b9622eb976af019 *man/var_pop.Rd
c152a771236fc6a552193935e3de8b94 *man/weight.Rd
8e07223e8564dc59da760611d7cc8591 *man/weighted_sd.Rd
2db0f4e0dfa8eb2416dc74ed964a588f *tests/testthat.R
d3b3614a71dfbe719d14509f44d920a1 *tests/testthat/test-autoprior.R
83ed2fcd29ec5e33da24fee2e41eed49 *tests/testthat/test-grpmean.R
4d88ab7bd90a4b5bbbf92162cd7b88b6 *tests/testthat/test-wtd.R
sjstats/inst/ 0000755 0001762 0000144 00000000000 13467616467 012746 5 ustar ligges users sjstats/inst/CITATION 0000644 0001762 0000144 00000000557 13446531537 014101 0 ustar ligges users year <- sub("-.*", "", meta$Date)
title <- sprintf("sjstats: Statistical Functions for Regression Models (Version %s)", meta$Version)
bibentry(bibtype="manual",
title = title,
author = person("Daniel", "Lüdecke"),
year = year,
url = "https://CRAN.R-project.org/package=sjstats",
doi = "10.5281/zenodo.1284472")