parameters/ 0000755 0001762 0000144 00000000000 14761611437 012427 5 ustar ligges users parameters/tests/ 0000755 0001762 0000144 00000000000 14413515226 013562 5 ustar ligges users parameters/tests/testthat/ 0000755 0001762 0000144 00000000000 14761611436 015430 5 ustar ligges users parameters/tests/testthat/test-p_direction.R 0000644 0001762 0000144 00000003257 14716604201 021026 0 ustar ligges users skip_on_cran()
skip_if_not_installed("bayestestR")
skip_if_not_installed("distributional")
test_that("p_direction", {
data(mtcars)
m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
set.seed(123)
x <- p_direction(m)
expect_identical(c(nrow(x), ncol(x)), c(5L, 5L))
expect_named(x, c("Parameter", "CI", "CI_low", "CI_high", "pd"))
expect_snapshot(print(x))
set.seed(123)
x <- p_direction(m, ci = 0.8)
expect_equal(x$pd, c(1, 0.6359, 0.9992, 0.882, 0.9117), tolerance = 1e-3)
set.seed(123)
x <- p_direction(m, null = 0.2)
expect_equal(x$pd, c(1, 0.5567, 0.9997, 0.9309, 1), tolerance = 1e-3)
})
test_that("p_direction", {
skip_if_not_installed("sandwich")
data(mtcars)
m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
set.seed(123)
x <- p_direction(m, ci = 0.8, vcov = "HC3")
expect_equal(x$pd, c(1, 0.6162, 0.9984, 0.8323, 0.8962), tolerance = 1e-3)
set.seed(123)
x <- p_direction(m, null = 0.2, vcov = "HC3")
expect_equal(x$pd, c(1, 0.5464, 0.9989, 0.88, 1), tolerance = 1e-3)
})
test_that("p_direction, glmmTMB", {
skip_if_not_installed("glmmTMB")
data(Salamanders, package = "glmmTMB")
m1 <- glmmTMB::glmmTMB(count ~ mined + cover + (1 | site),
zi = ~mined,
family = poisson,
data = Salamanders
)
out <- p_direction(m1)
expect_identical(c(nrow(out), ncol(out)), c(5L, 6L))
expect_named(out, c("Parameter", "CI", "CI_low", "CI_high", "pd", "Component"))
expect_equal(out$pd, c(0.8245, 1, 0.9974, 1, 1), tolerance = 1e-4)
expect_identical(
out$Parameter,
c(
"(Intercept)_cond", "minedno_cond", "cover_cond", "(Intercept)_zi",
"minedno_zi"
)
)
})
parameters/tests/testthat/test-glmmTMB-profile_CI.R 0000644 0001762 0000144 00000001006 14413515226 022027 0 ustar ligges users test_that("glmmTMB profiled and uniroot CI work", {
skip_on_cran()
skip_if_not_installed("TMB")
skip_if_not_installed("glmmTMB")
skip_if_not_installed("lme4")
data(sleepstudy, package = "lme4")
m <- glmmTMB::glmmTMB(Reaction ~ Days + (Days | Subject), data = sleepstudy)
expect_silent({
mp1 <- model_parameters(m, ci_method = "uniroot")
})
expect_silent({
mp2 <- model_parameters(m, ci_method = "profile")
})
expect_snapshot(print(mp1))
expect_snapshot(print(mp2))
})
parameters/tests/testthat/test-svylme.R 0000644 0001762 0000144 00000001242 14716604201 020036 0 ustar ligges users skip_on_cran()
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not_installed("withr")
skip_if_not_installed("survey")
skip_if_not_installed("lme4")
skip_if_not_installed("svylme")
withr::with_environment(
new.env(),
test_that("model_parameters svylme", {
data(api, package = "survey")
# two-stage cluster sample
dclus2 <- survey::svydesign(
id = ~ dnum + snum,
fpc = ~ fpc1 + fpc2,
data = apiclus2
)
m <- svylme::svy2lme(
api00 ~ ell + mobility + api99 + (1 + api99 | dnum),
design = dclus2,
method = "nested"
)
mp <- model_parameters(m)
expect_snapshot(print(mp))
})
)
parameters/tests/testthat/test-model_parameters.coxme.R 0000644 0001762 0000144 00000001211 14716604201 023150 0 ustar ligges users skip_on_cran()
skip_if_not_installed("coxme")
skip_if_not_installed("survival")
skip_if_not_installed("withr")
# modelparameters ----------------------------------
## TODO: works only interactively
# test_that("model_parameters.coxme", {
# data(eortc, package = "coxme")
# d <- coxme::eortc
# d$surv <- survival::Surv(d$y, d$uncens)
# m1 <- coxme::coxme(surv ~ trt + (1 | center), data = d)
# out <- model_parameters(m1)
# expect_named(
# out,
# c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "z", "df_error", "p")
# )
# expect_equal(out$Coefficient, 0.7086127, tolerance = 1e-4)
# })
parameters/tests/testthat/test-complete_separation.R 0000644 0001762 0000144 00000002261 14716604201 022556 0 ustar ligges users skip_if(getRversion() < "4.0.0")
skip_if_not_installed("withr")
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("print warning about complete separation", {
d_sep <- data.frame(
y = c(0, 0, 0, 0, 1, 1, 1, 1),
x1 = c(1, 2, 3, 3, 5, 6, 10, 11),
x2 = c(3, 2, -1, -1, 2, 4, 1, 0)
)
m_sep <- suppressWarnings(glm(y ~ x1 + x2, data = d_sep, family = binomial))
out <- model_parameters(m_sep)
expect_snapshot(print(out))
})
)
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("print warning about complete separation", {
data(mtcars)
m_sep2 <- suppressWarnings(glm(am ~ gear, data = mtcars, family = binomial))
out <- model_parameters(m_sep2)
expect_snapshot(print(out))
})
)
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("print warning about quasi complete separation", {
data(mtcars)
set.seed(323)
m_sep3 <- suppressWarnings(glm(vs ~ qsec, data = mtcars[sample.int(32, 27, replace = TRUE), ], family = binomial)) # nolint
out <- model_parameters(m_sep3)
expect_snapshot(print(out))
})
)
parameters/tests/testthat/test-p_value.R 0000644 0001762 0000144 00000007236 14736731407 020176 0 ustar ligges users test_that("p_value", {
expect_equal(p_value(c(1, 1, 1)), p_value(-c(1, 1, 1)), tolerance = 1e-3)
set.seed(123)
x <- rnorm(100, mean = 1.5)
expect_equal(p_value(x), p_value(-x), tolerance = 1e-3)
expect_gt(p_value(x, null = 1), p_value(x))
expect_gt(p_value(x), p_value(x, null = -1))
expect_equal(p_value(x, null = -1), p_value(-x, null = 1), tolerance = 1e-3)
})
skip_on_cran()
test_that("p_value", {
skip_if_not_installed("curl")
skip_if_offline()
skip_if_not_installed("httr2")
skip_if_not_installed("lme4")
# h-tests
model <- insight::download_model("htest_1")
expect_equal(p_value(model), 0.04136799, tolerance = 0.01)
model <- insight::download_model("htest_2")
expect_equal(p_value(model), 0.1518983, tolerance = 0.01)
model <- insight::download_model("htest_3")
expect_equal(p_value(model), 0.182921, tolerance = 0.01)
model <- insight::download_model("htest_4")
expect_equal(p_value(model), 0, tolerance = 0.01)
model <- insight::download_model("htest_5")
expect_equal(p_value(model), 0, tolerance = 0.01)
model <- insight::download_model("htest_6")
expect_equal(p_value(model), 0, tolerance = 0.01)
model <- insight::download_model("htest_7")
expect_equal(p_value(model), 0, tolerance = 0.01)
model <- insight::download_model("htest_8")
expect_equal(p_value(model), 0, tolerance = 0.01)
# ANOVAs
model <- insight::download_model("aov_1")
expect_equal(p_value(model)$p, 0, tolerance = 0.01)
model <- insight::download_model("anova_1")
expect_equal(p_value(model)$p, 0, tolerance = 0.01)
model <- insight::download_model("aovlist_1")
expect_equal(p_value(model)$p, 0, tolerance = 0.01)
model <- insight::download_model("aov_2")
expect_equal(p_value(model)$p[1], 0, tolerance = 0.01)
model <- insight::download_model("anova_2")
expect_equal(p_value(model)$p[1], 0, tolerance = 0.01)
model <- insight::download_model("aovlist_2")
expect_equal(p_value(model)$p[1], 0, tolerance = 0.01)
model <- insight::download_model("aov_3")
expect_equal(p_value(model)$p[1], 0, tolerance = 0.01)
model <- insight::download_model("anova_3")
expect_equal(p_value(model)$p[1], 0, tolerance = 0.01)
model <- insight::download_model("aovlist_3")
expect_equal(p_value(model)$p[1], 0, tolerance = 0.01)
model <- insight::download_model("anova_4")
expect_equal(p_value(model)$p[2], 0, tolerance = 0.01)
# ANOVA lmer
model <- insight::download_model("anova_lmerMod_0")
expect_identical(p_value(model), NA)
model <- insight::download_model("anova_lmerMod_1")
expect_identical(p_value(model), NA)
model <- insight::download_model("anova_lmerMod_2")
expect_identical(p_value(model), NA)
model <- insight::download_model("anova_lmerMod_3")
expect_identical(p_value(model), NA)
model <- insight::download_model("anova_lmerMod_4")
expect_identical(p_value(model), NA)
model <- insight::download_model("anova_lmerMod_5")
expect_identical(p_value(model), NA)
model <- insight::download_model("anova_lmerMod_6")
expect_equal(p_value(model)$p[2], 0, tolerance = 0.01)
# Mixed models
model <- lme4::lmer(wt ~ cyl + (1 | gear), data = mtcars)
expect_equal(p_value(model)$p[1], 0.206219, tolerance = 0.01)
expect_equal(p_value(model, method = "normal")$p[1], 0.1956467, tolerance = 0.01)
expect_equal(p_value(model, method = "kr")$p[1], 0.319398, tolerance = 0.01)
model <- insight::download_model("merMod_1")
expect_equal(p_value(model)$p[1], 0.06578, tolerance = 0.01)
model <- insight::download_model("merMod_2")
expect_equal(p_value(model)$p[1], 0.29912, tolerance = 0.01)
})
parameters/tests/testthat/test-model_parameters.lqmm.R 0000644 0001762 0000144 00000005223 14413515226 023014 0 ustar ligges users # lqm -----------------------
test_that("model_parameters - lqm", {
skip_if_not_installed("lqmm")
# data
set.seed(123)
n <- 500
p <- 1:3 / 4
set.seed(123)
x <- runif(n, 0, 1)
y <- 30 + x + rnorm(n)
test <<- data.frame(x, y)
# model
set.seed(123)
fit.lqm <-
lqmm::lqm(
y ~ x,
data = test,
tau = p,
control = list(verbose = FALSE, loop_tol_ll = 1e-9),
fit = TRUE
)
df_lqm <- as.data.frame(model_parameters(fit.lqm))
expect_equal(df_lqm$Coefficient,
c(
29.3220715172958, 1.1244506550584, 29.9547605920406, 1.1822574944936,
30.6283792821576, 1.25165747424685
),
tolerance = 0.001
)
})
# lqmm -----------------------
test_that("model_parameters - lqmm", {
skip("TODO: fix this test")
skip_if_not_installed("lqmm")
# setup
set.seed(123)
# data
M <- 50
n <- 10
set.seed(123)
x <- runif(n * M, 0, 1)
group <- rep(1:M, each = n)
y <- 10 * x + rep(rnorm(M, 0, 2), each = n) + rchisq(n * M, 3)
test <<- data.frame(x, y, group)
# model
set.seed(123)
fit.lqmm <-
lqmm::lqmm(
fixed = y ~ x,
random = ~1,
group = group,
data = test,
tau = 0.5,
nK = 11,
type = "normal"
)
df_lqmm <- as.data.frame(model_parameters(fit.lqmm))
expect_equal(df_lqmm,
structure(
list(
Parameter = c("(Intercept)", "x"),
Coefficient = c(
3.44347538706013,
9.25833091219961
),
SE = c(0.491049614414579, 0.458163772053399),
CI = c(0.95, 0.95),
CI_low = c(2.47868633791118, 8.35815427623814),
CI_high = c(4.40826443620908, 10.1585075481611),
t = c(
7.01247956617455,
20.207470509302
),
df_error = c(497L, 497L),
p = c(
6.34497395571023e-09,
2.05172540270515e-25
)
),
row.names = 1:2,
pretty_names = c(
`(Intercept)` = "(Intercept)",
x = "x"
),
ci = 0.95,
verbose = TRUE,
exponentiate = FALSE,
ordinal_model = FALSE,
linear_model = TRUE,
mixed_model = TRUE,
n_obs = 500L,
model_class = "lqmm",
bootstrap = FALSE,
iterations = 1000,
ignore_group = TRUE,
ran_pars = TRUE,
weighted_nobs = 500,
model_formula = "y ~ x",
coefficient_name = "Coefficient",
zi_coefficient_name = "Log-Odds",
digits = 2,
ci_digits = 2,
p_digits = 3,
class = "data.frame",
object_name = "fit.lqmm"
),
tolerance = 0.001
)
})
parameters/tests/testthat/test-sort_parameters.R 0000644 0001762 0000144 00000003465 14355245205 021746 0 ustar ligges users # easystats convention ------------------------
mod <- parameters(stats::lm(wt ~ am * cyl, data = mtcars))
test_that("sort_parameters returns original object when no sorting - easystats", {
expect_equal(sort_parameters(mod), mod)
})
test_that("sort_parameters returns sorted object when necessary - easystats", {
expect_equal(
sort_parameters(mod, sort = "ascending")$Coefficient,
sort(mod$Coefficient)
)
expect_equal(
sort_parameters(mod, sort = "descending")$Coefficient,
sort(mod$Coefficient, decreasing = TRUE)
)
expect_s3_class(sort_parameters(mod, sort = "ascending"), "parameters_model")
})
# broom convention ------------------------
df <- structure(list(
term = c("(Intercept)", "am", "cyl", "am:cyl"),
estimate = c(
1.65820588235294, -0.956184605757196, 0.303811274509804,
0.0328057467667917
), std.error = c(
0.587149249513266, 0.792732452856412,
0.0826018347687406, 0.130209483362154
), statistic = c(
2.82416418606949,
-1.20618829506957, 3.67802089820863, 0.251945909926916
),
p.value = c(
0.00863653784417726, 0.237838251537444, 0.000989221758576308,
0.802923027949227
)
), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -4L))
test_that("sort_parameters returns original object when no sorting - broom", {
expect_equal(sort_parameters(df), df)
})
test_that("sort_parameters returns sorted object when necessary - broom", {
expect_equal(
sort_parameters(df, sort = "ascending", column = "estimate")$estimate,
sort(df$estimate)
)
expect_equal(
sort_parameters(df, sort = "descending", column = "estimate")$estimate,
sort(df$estimate, decreasing = TRUE)
)
expect_s3_class(sort_parameters(df, sort = "ascending", column = "estimate"), "tbl_df")
})
parameters/tests/testthat/test-emmGrid-df_colname.R 0000644 0001762 0000144 00000002017 14413515226 022173 0 ustar ligges users skip_on_cran()
skip_if_not_installed("emmeans")
skip_if_not_installed("lme4")
data(sleep)
data(fiber, package = "emmeans")
m <- lm(strength ~ diameter + machine, data = fiber)
emm <- emmeans::emmeans(m, "machine")
es1 <- emmeans::eff_size(emm, sigma = sigma(m), edf = df.residual(m))
sleep$group <- as.factor(sleep$group)
m2 <- lme4::lmer(extra ~ group + (1 | ID), sleep)
emm2 <- emmeans::emmeans(m2, ~group, df = NA)
es2 <- emmeans::eff_size(emm2, sigma = sigma(m2), edf = df.residual(m2))
test_that("df", {
expect_identical(
colnames(model_parameters(es1)),
c(
"contrast", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"t", "df_error", "p"
)
)
expect_identical(
colnames(model_parameters(es2)),
c(
"contrast", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"z", "df_error", "p"
)
)
})
test_that("print model_parameters", {
mp <- model_parameters(emm)
expect_snapshot(mp)
mp <- model_parameters(es1)
expect_snapshot(mp)
})
parameters/tests/testthat/test-glmmTMB-2.R 0000644 0001762 0000144 00000004371 14413515226 020165 0 ustar ligges users skip_on_cran()
skip_if_not(getRversion() >= "4.0.0")
skip_if_not_installed("glmmTMB")
data(Salamanders, package = "glmmTMB")
model <- suppressWarnings(glmmTMB::glmmTMB(
count ~ spp + mined + spp * mined,
ziformula = ~ spp + mined + spp * mined,
family = glmmTMB::truncated_poisson,
data = Salamanders
))
mp <- model_parameters(model, effects = "fixed", component = "conditional")
test_that("model_parameters", {
expect_equal(mp$Coefficient, as.vector(glmmTMB::fixef(model)[[1]]), tolerance = 1e-3)
expect_equal(mp$Parameter, names(glmmTMB::fixef(model)[[1]]))
})
mp <- model_parameters(model, effects = "fixed", component = "all")
test_that("model_parameters", {
expect_equal(mp$Coefficient, as.vector(unlist(glmmTMB::fixef(model))), tolerance = 1e-3)
expect_equal(mp$Parameter, gsub("^(cond\\.|zi\\.)", "", names(unlist(glmmTMB::fixef(model)))))
expect_equal(
mp$Component,
c(
"conditional", "conditional", "conditional", "conditional",
"conditional", "conditional", "conditional", "conditional", "conditional",
"conditional", "conditional", "conditional", "conditional", "conditional",
"zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated",
"zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated",
"zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated",
"zero_inflated", "zero_inflated"
)
)
})
sim1 <- function(nfac = 40, nt = 100, facsd = 0.1, tsd = 0.15, mu = 0, residsd = 1) {
dat <- expand.grid(fac = factor(letters[1:nfac]), t = 1:nt)
n <- nrow(dat)
dat$REfac <- rnorm(nfac, sd = facsd)[dat$fac]
dat$REt <- rnorm(nt, sd = tsd)[dat$t]
dat$x <- rnorm(n, mean = mu, sd = residsd) + dat$REfac + dat$REt
dat
}
set.seed(101)
d1 <- sim1(mu = 100, residsd = 10)
d2 <- sim1(mu = 200, residsd = 5)
d1$sd <- "ten"
d2$sd <- "five"
dat <- rbind(d1, d2)
model <- suppressWarnings(glmmTMB::glmmTMB(x ~ sd + (1 | t), dispformula = ~sd, data = dat))
mp <- model_parameters(model, effects = "fixed")
test_that("model_parameters", {
expect_equal(mp$Coefficient, as.vector(unlist(glmmTMB::fixef(model))), tolerance = 1e-3)
expect_equal(mp$Component, c("conditional", "conditional", "dispersion", "dispersion"))
})
parameters/tests/testthat/test-format.R 0000644 0001762 0000144 00000000401 14412513617 020006 0 ustar ligges users test_that("format_order", {
expect_identical(format_order(2), "second")
expect_identical(format_order(45), "forty fifth")
expect_identical(format_order(2, textual = FALSE), "2nd")
expect_identical(format_order(45, textual = FALSE), "45th")
})
parameters/tests/testthat/test-model_parameters.fixest_multi.R 0000644 0001762 0000144 00000001420 14413515226 024555 0 ustar ligges users skip_if_not_installed("fixest")
skip_on_cran()
set.seed(123)
iris$x <- rnorm(150)
test_that("model_parameters.fixest_multi", {
mod <- fixest::feols(c(Petal.Width, Sepal.Width) ~ x + csw0(Petal.Length, Sepal.Length) | Species, iris)
expect_snapshot(print(model_parameters(mod)))
expect_snapshot(print(ci(mod)))
})
test_that("model_parameters.fixest_multi", {
mod <- fixest::feols(c(Petal.Width, Sepal.Width) ~ x + Petal.Length | Species, iris)
expect_snapshot(print(model_parameters(mod)))
expect_snapshot(print(ci(mod)))
})
test_that("model_parameters.fixest_multi", {
mod <- fixest::feols(Petal.Width ~ x + csw0(Petal.Length, Sepal.Length) | Species, iris)
expect_snapshot(print(model_parameters(mod)))
expect_snapshot(print(ci(mod)))
})
parameters/tests/testthat/test-model_parameters_robust.R 0000644 0001762 0000144 00000012676 14716604201 023455 0 ustar ligges users skip_if_not_installed("sandwich")
skip_if_not_installed("clubSandwich")
data(mtcars)
mtcars$am <- as.factor(mtcars$am)
model <- lm(mpg ~ wt * am + cyl + gear, data = mtcars)
test_that("model_parameters, robust CL", {
params1 <- model_parameters(
model,
vcov = "CL",
vcov_args = list(type = "HC1"),
verbose = FALSE
)
robust_se <- unname(sqrt(diag(sandwich::vcovCL(model))))
expect_equal(params1$SE, robust_se, tolerance = 1e-3)
expect_equal(params1$p, c(0, 0.00695, 0.00322, 0.00435, 0.94471, 0.00176), tolerance = 1e-3)
})
test_that("model_parameters, robust", {
params <- model_parameters(model, vcov = "HC", verbose = FALSE)
robust_se <- unname(sqrt(diag(sandwich::vcovHC(model))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0, 0.0259, 0.01478, 0.01197, 0.95238, 0.01165), tolerance = 1e-3)
})
test_that("ci, robust", {
params <- ci(model, vcov = "HC", verbose = FALSE)
robust_se <- unname(sqrt(diag(sandwich::vcovHC(model))))
upper_ci <- as.vector(coef(model) + qt(0.975, df.residual(model)) * robust_se)
expect_equal(params$CI_high, upper_ci, tolerance = 1e-3, ignore_attr = TRUE)
})
test_that("model_parameters, robust CL", {
params <- model_parameters(model, vcov = "vcovCL", verbose = FALSE)
robust_se <- unname(sqrt(diag(sandwich::vcovCL(model))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0, 0.00695, 0.00322, 0.00435, 0.94471, 0.00176), tolerance = 1e-3)
})
model2 <- lm(mpg ~ wt * am + cyl + gear, data = datawizard::standardize(mtcars))
test_that("model_parameters, robust", {
params <- model_parameters(model, standardize = "refit", vcov = "HC", verbose = FALSE)
robust_se <- unname(sqrt(diag(sandwich::vcovHC(model2))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0.28624, 0.0259, 0.43611, 0.01197, 0.95238, 0.01165), tolerance = 1e-3)
})
# cluster-robust standard errors, using clubSandwich
data(iris)
model <- lm(Petal.Length ~ Sepal.Length * Species, data = iris)
iris$cluster <- factor(rep(LETTERS[1:8], length.out = nrow(iris)))
test_that("model_parameters, robust CR", {
params <- model_parameters(
model,
vcov = "CR1",
vcov_args = list(cluster = iris$cluster),
verbose = FALSE
)
robust_se <- unname(sqrt(diag(clubSandwich::vcovCR(model, type = "CR1", cluster = iris$cluster))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0.01246, 0.04172, 0.18895, 0.57496, 0, 0), tolerance = 1e-3)
})
test_that("model_parameters, normal", {
params <- model_parameters(model)
expect_equal(params$p, c(0.13267, 0.21557, 0.36757, 0.77012, 3e-05, 0), tolerance = 1e-3)
})
data(mtcars)
mtcars$am <- as.factor(mtcars$am)
model <- lm(mpg ~ wt * am + cyl + gear, data = mtcars)
test_that("model_parameters, robust", {
params <- model_parameters(model, vcov = "HC3")
robust_se <- unname(sqrt(diag(sandwich::vcovHC(model))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0, 0.0259, 0.01478, 0.01197, 0.95238, 0.01165), tolerance = 1e-3)
})
test_that("ci, robust", {
params <- ci(model, vcov = "HC3")
robust_se <- unname(sqrt(diag(sandwich::vcovHC(model))))
upper_ci <- as.vector(coef(model) + qt(0.975, df.residual(model)) * robust_se)
expect_equal(params$CI_high, upper_ci, tolerance = 1e-3, ignore_attr = TRUE)
})
test_that("model_parameters, robust CL", {
params <- model_parameters(model, vcov = "vcovCL", vcov_args = list(type = "HC1"))
robust_se <- unname(sqrt(diag(sandwich::vcovCL(model))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0, 0.00695, 0.00322, 0.00435, 0.94471, 0.00176), tolerance = 1e-3)
})
d <- datawizard::standardize(mtcars)
model2 <- lm(mpg ~ wt * am + cyl + gear, data = d)
test_that("model_parameters, robust", {
params <- model_parameters(model, standardize = "refit", vcov = "HC3")
robust_se <- unname(sqrt(diag(sandwich::vcovHC(model2))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0.28624, 0.0259, 0.43611, 0.01197, 0.95238, 0.01165), tolerance = 1e-3)
})
# cluster-robust standard errors, using clubSandwich
data(iris)
model <- lm(Petal.Length ~ Sepal.Length * Species, data = iris)
iris$cluster <- factor(rep(LETTERS[1:8], length.out = nrow(iris)))
test_that("model_parameters, robust CR", {
params <- model_parameters(model, vcov = "vcovCR", vcov_args = list(type = "CR1", cluster = iris$cluster))
robust_se <- unname(sqrt(diag(clubSandwich::vcovCR(model, type = "CR1", cluster = iris$cluster))))
expect_equal(params$SE, robust_se, tolerance = 1e-3)
expect_equal(params$p, c(0.01246, 0.04172, 0.18895, 0.57496, 0, 0), tolerance = 1e-3)
})
test_that("model_parameters, normal", {
params <- model_parameters(model)
expect_equal(params$p, c(0.13267, 0.21557, 0.36757, 0.77012, 3e-05, 0), tolerance = 1e-3)
})
test_that("ci_ml1, robust", {
skip("TODO: this one actually is not correct.")
skip_if_not(packageVersion("parameters") < "0.16.9.9")
skip_if_not_installed("lme4")
model <- lme4::lmer(Petal.Length ~ Sepal.Length + (1 | Species), data = iris)
params <- ci_ml1(model, vcov = "CR", vcov_args = list(cluster = iris$Species))
robust_se <- unname(sqrt(diag(clubSandwich::vcovCR(model, type = "CR1", cluster = iris$Species))))
upper_ci <- fixef(model) + qt(0.975, dof_ml1(model)) * robust_se
})
parameters/tests/testthat/test-model_parameters.logistf.R 0000644 0001762 0000144 00000001413 14716604201 023510 0 ustar ligges users skip_on_cran()
skip_if_not_installed("logistf")
skip_if_not_installed("withr")
withr::with_options(
list(parameters_exponentiate = FALSE),
{
data(sex2, package = "logistf")
m1 <- logistf::logistf(case ~ age + oc + vic + vicl + vis + dia, data = sex2)
m2 <- logistf::flic(m1)
m3 <- logistf::flac(m1, data = sex2)
test_that("model_parameters.logistf", {
params <- model_parameters(m1)
expect_snapshot(params, variant = "windows")
})
test_that("model_parameters.flic", {
params <- model_parameters(m2)
expect_snapshot(params, variant = "windows")
})
test_that("model_parameters.flac", {
params <- model_parameters(m3)
expect_snapshot(params, variant = "windows")
})
}
)
parameters/tests/testthat/test-gls.R 0000644 0001762 0000144 00000001510 14413515226 017304 0 ustar ligges users skip_if_not_installed("nlme")
data(Ovary, package = "nlme")
m1 <- nlme::gls(follicles ~ sin(2 * pi * Time) + cos(2 * pi * Time),
data = Ovary,
correlation = nlme::corAR1(form = ~ 1 | Mare)
)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(10.90853, -4.04402, -2.2722),
tolerance = 1e-4
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.664643651063474, 0.645047778144975, 0.697538308948056),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(2.6187369542827e-51, 2.28628382225752e-05, 0.198137111907874),
tolerance = 1e-4
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
c(12.2163981810227, -2.77471219793581, -0.899604717105857),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-model_parameters.mfx.R 0000644 0001762 0000144 00000004217 14413515226 022642 0 ustar ligges users skip_if_not_installed("mfx")
skip_if_not_installed("MASS")
set.seed(12345)
n <- 1000
x <- rnorm(n)
y <- rbeta(n, shape1 = plogis(1 + 0.5 * x), shape2 = (abs(0.2 * x)))
y <- (y * (n - 1) + 0.5) / n
data <- data.frame(y, x)
model <- mfx::betamfx(y ~ x | x, data = data)
params <- suppressWarnings(model_parameters(model))
test_that("model_parameters.betamfx", {
expect_equal(params$Parameter, c("x", "(Intercept)", "x", "(Intercept)", "x"))
expect_equal(params$Coefficient, c(0.02259, 1.35961, 0.13947, 0.07498, 0.12071), tolerance = 1e-2)
expect_equal(params$Component, c("marginal", "conditional", "conditional", "precision", "precision"))
})
model <- mfx::betaor(y ~ x | x, data = data)
params <- suppressWarnings(model_parameters(model))
test_that("model_parameters.betaor", {
expect_equal(params$Parameter, c("(Intercept)", "x"))
expect_equal(params$Coefficient, c(1.35961, 0.13947), tolerance = 1e-2)
expect_null(params$Component)
})
params <- suppressWarnings(model_parameters(model, component = "all"))
test_that("model_parameters.betaor", {
expect_equal(params$Parameter, c("(Intercept)", "x", "(Intercept)", "x"))
expect_equal(params$Coefficient, unname(do.call(rbind, coef(summary(model$fit)))[, 1]), tolerance = 1e-2)
expect_equal(params$Component, c("conditional", "conditional", "precision", "precision"))
})
set.seed(12345)
n <- 1000
x <- rnorm(n)
y <- MASS::rnegbin(n, mu = exp(1 + 0.5 * x), theta = 0.5)
data <- data.frame(y, x)
model <- mfx::poissonmfx(formula = y ~ x, data = data)
params <- suppressWarnings(model_parameters(model))
test_that("model_parameters.poissonmfx", {
expect_equal(params$Parameter, c("x", "(Intercept)", "x"))
expect_equal(params$Coefficient, c(1.46009, 0.96036, 0.54496), tolerance = 1e-2)
expect_equal(params$Component, c("marginal", "conditional", "conditional"))
})
params <- suppressWarnings(model_parameters(model, component = "cond"))
test_that("model_parameters.poissonmfx", {
expect_equal(params$Parameter, c("(Intercept)", "x"))
expect_equal(params$Coefficient, c(0.96036, 0.54496), tolerance = 1e-2)
expect_null(params$Component)
})
parameters/tests/testthat/test-panelr.R 0000644 0001762 0000144 00000004266 14716610124 020012 0 ustar ligges users skip_on_cran()
skip_if_not_installed("panelr")
data("WageData", package = "panelr")
wages <- panelr::panel_data(WageData, id = id, wave = t)
m1 <- panelr::wbm(lwage ~ lag(union) + wks | blk + fem | blk * lag(union), data = wages)
m2 <- suppressWarnings(panelr::wbm(lwage ~ lag(union) + wks | blk + fem | blk * (t | id), data = wages))
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(0.00807, -0.00376, 6.14479, -0.09624, -0.00507, -0.34607, -0.53918, -0.37071),
tolerance = 1e-3
)
expect_equal(
ci(m2)$CI_low,
c(-0.01668, -0.00139, 6.01762, -0.08795, -0.0055, -0.32126, -0.54359),
tolerance = 1e-3
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.0256, 0.00108, 0.2313, 0.03482, 0.00482, 0.05952, 0.04971, 0.12418),
tolerance = 1e-3
)
expect_equal(
standard_error(m2)$SE,
c(0.01838, 0.00073, 0.22549, 0.03394, 0.0047, 0.05803, 0.04846),
tolerance = 1e-3
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0.02295, 0.13007, 0, 0.42167, 0.36422, 0.00013, 0, 0.30533),
tolerance = 1e-3
)
expect_equal(
p_value(m2)$p,
c(0.29282, 0.9538, 0, 0.52805, 0.43004, 0.00038, 0),
tolerance = 1e-3
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1, effects = "fixed")$Coefficient,
c(0.05825, -0.00164, 6.59813, -0.028, 0.00438, -0.22941, -0.44176, -0.12732),
tolerance = 1e-3
)
expect_equal(
model_parameters(m1, effects = "all")$Coefficient,
c(
0.05825, -0.00164, 6.59813, -0.028, 0.00438, -0.22941, -0.44176,
-0.12732, 0.35399, 0.23264
),
tolerance = 1e-3
)
expect_equal(
model_parameters(m2, effects = "fixed")$Coefficient,
c(0.01934, 4e-05, 6.45957, -0.02143, 0.00371, -0.20753, -0.44861),
tolerance = 1e-3
)
})
skip_if_not_installed("car")
skip_if_not_installed("clubSandwich")
test_that("model_parameters, asym", {
data("teen_poverty", package = "panelr")
teen <- panelr::long_panel(teen_poverty, begin = 1, end = 5)
m4 <- panelr::asym(hours ~ lag(pov) + spouse, data = teen, use.wave = TRUE)
expect_snapshot(print(model_parameters(m4)))
})
parameters/tests/testthat/test-model_parameters_std.R 0000644 0001762 0000144 00000003572 14413515226 022726 0 ustar ligges users skip_on_cran()
skip_if_not_installed("effectsize")
data(mtcars)
mtcars$am <- as.factor(mtcars$am)
d <- mtcars
model <- lm(mpg ~ wt * am, data = d)
test_that("model_parameters, standardize-refit", {
params <- model_parameters(model, standardize = "refit")
expect_identical(c(nrow(params), ncol(params)), c(4L, 9L))
expect_equal(params$Coefficient, c(-0.14183, -0.61463, -0.35967, -0.86017), tolerance = 1e-3)
expect_equal(params$SE, c(0.12207, 0.12755, 0.23542, 0.23454), tolerance = 1e-3)
expect_equal(params$CI_high, c(0.10821, -0.35336, 0.12257, -0.37973), tolerance = 1e-3)
})
test_that("model_parameters, standardize-posthoc", {
params <- model_parameters(model, standardize = "posthoc")
expect_identical(c(nrow(params), ncol(params)), c(4L, 9L))
expect_equal(params$Std_Coefficient, c(0, -0.61463, 2.46865, -0.87911), tolerance = 1e-3)
expect_equal(params$SE, c(0, 0.12755, 0.7075, 0.23971), tolerance = 1e-3)
expect_equal(params$CI_high, c(0, -0.35336, 3.91789, -0.38809), tolerance = 0.1)
})
test_that("model_parameters, standardize-basic", {
params <- model_parameters(model, standardize = "basic")
expect_identical(c(nrow(params), ncol(params)), c(4L, 9L))
expect_equal(params$Std_Coefficient, c(0, -0.61463, 1.23183, -1.11016), tolerance = 1e-3)
expect_equal(params$SE, c(0, 0.12755, 0.35303, 0.30271), tolerance = 1e-3)
expect_equal(params$CI_high, c(0, -0.35336, 1.95499, -0.4901), tolerance = 0.1)
})
test_that("model_parameters, standardize-smart", {
params <- model_parameters(model, standardize = "smart")
expect_identical(c(nrow(params), ncol(params)), c(4L, 9L))
expect_equal(params$Std_Coefficient, c(0, -0.61463, 2.41278, -0.85922), tolerance = 1e-3)
expect_equal(params$SE, c(0, 0.12755, 0.69148, 0.23428), tolerance = 1e-3)
expect_equal(params$CI_high, c(0, -0.35336, 3.82922, -0.37931), tolerance = 0.1)
})
parameters/tests/testthat/test-gamm.R 0000644 0001762 0000144 00000002107 14413515226 017443 0 ustar ligges users skip_if_not_installed("mgcv")
set.seed(123)
void <- capture.output({
dat <- mgcv::gamSim(6, n = 200, scale = 0.2, dist = "poisson")
})
m1_gamm <- mgcv::gamm(
y ~ s(x0) + s(x1) + s(x2),
family = poisson,
data = dat,
random = list(fac = ~1),
verbosePQL = FALSE
)
test_that("ci", {
expect_equal(
ci(m1_gamm)$CI_low,
c(2.361598, NA, NA, NA),
tolerance = 1e-3
)
})
test_that("se", {
expect_equal(
standard_error(m1_gamm)$SE,
c(0.3476989, NA, NA, NA),
tolerance = 1e-3
)
})
test_that("p_value", {
expect_equal(
p_value(m1_gamm)$p,
c(0, 0, 0, 0),
tolerance = 1e-3
)
})
mp <- model_parameters(m1_gamm)
test_that("model_parameters", {
expect_equal(
mp$Coefficient,
c(3.0476, NA, NA, NA),
tolerance = 1e-3
)
})
test_that("model_parameters", {
expect_equal(
mp$df,
c(NA, 3.84696, 3.17389, 8.51855),
tolerance = 1e-3
)
})
test_that("model_parameters", {
expect_equal(
mp$df_error,
c(183.4606, NA, NA, NA),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-equivalence_test.R 0000644 0001762 0000144 00000007077 14717111737 022103 0 ustar ligges users skip_if_not_installed("bayestestR")
test_that("equivalence_test", {
data(mtcars)
m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
x <- equivalence_test(m)
expect_identical(c(nrow(x), ncol(x)), c(5L, 9L))
expect_type(capture.output(equivalence_test(m)), "character")
expect_snapshot(print(x))
})
test_that("equivalence_test, robust", {
skip_if_not_installed("sandwich")
data(mtcars)
m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
x <- equivalence_test(m, vcov = "HC3")
expect_snapshot(print(x))
})
test_that("equivalence_test, unequal rope-range", {
data(iris)
m <- lm(Sepal.Length ~ Species, data = iris)
rez <- equivalence_test(m, range = c(-Inf, 0.1))
expect_identical(rez$ROPE_Equivalence, c("Rejected", "Rejected", "Rejected"))
expect_identical(rez$ROPE_low, c(-Inf, -Inf, -Inf))
rez <- equivalence_test(m, range = c(-99, 0.1))
expect_identical(rez$ROPE_Equivalence, c("Rejected", "Rejected", "Rejected"))
expect_identical(rez$ROPE_low, c(-99, -99, -99))
data(mtcars)
mtcars[c("gear", "cyl")] <- lapply(mtcars[c("gear", "cyl")], as.factor)
m <- lm(mpg ~ hp + gear + cyl, data = mtcars)
rez <- equivalence_test(m, range = c(-Inf, 0.5))
expect_identical(
rez$ROPE_Equivalence,
c("Rejected", "Accepted", "Undecided", "Rejected", "Accepted", "Undecided")
)
# validate that range of CI equals approximated normal distribution
diff_ci <- abs(diff(c(rez$CI_low[3], rez$CI_high[3])))
set.seed(123)
out <- bayestestR::distribution_normal(
n = 1000,
mean = rez$CI_high[3] - (diff_ci / 2),
sd = (diff_ci / 2) / 3.290525
)
expect_equal(range(out)[1], rez$CI_low[3], tolerance = 1e-4)
expect_equal(range(out)[2], rez$CI_high[3], tolerance = 1e-4)
# need procedure for SGP here...
diff_ci <- abs(diff(c(rez$CI_low[3], rez$CI_high[3])))
z_value <- stats::qnorm((1 + 0.95) / 2)
sd_dist <- diff_ci / diff(c(-1 * z_value, z_value))
set.seed(123)
out <- bayestestR::distribution_normal(
n = 10000,
mean = rez$CI_high[3] - (diff_ci / 2),
sd = sd_dist
)
expect_equal(
rez$SGPV[3],
bayestestR::rope(out, range = c(-Inf, 0.5), ci = 1)$ROPE_Percentage,
tolerance = 1e-4
)
rez <- equivalence_test(m, range = c(-0.5, 0.5))
expect_identical(
rez$ROPE_Equivalence,
c("Rejected", "Accepted", "Undecided", "Rejected", "Rejected", "Undecided")
)
rez <- equivalence_test(m, range = c(-2, 2))
expect_identical(
rez$ROPE_Equivalence,
c("Rejected", "Accepted", "Undecided", "Rejected", "Rejected", "Undecided")
)
})
test_that("equivalence_test, unequal rope-range, plots", {
skip_on_cran()
skip_if_not_installed("see")
skip_if_not_installed("vdiffr")
data(iris)
m <- lm(Sepal.Length ~ Species, data = iris)
rez <- equivalence_test(m, range = c(-Inf, 0.1))
vdiffr::expect_doppelganger(
"Equivalence-Test 1",
plot(rez)
)
rez <- equivalence_test(m, range = c(-99, 0.1))
vdiffr::expect_doppelganger(
"Equivalence-Test 2",
plot(rez)
)
data(mtcars)
mtcars[c("gear", "cyl")] <- lapply(mtcars[c("gear", "cyl")], as.factor)
m <- lm(mpg ~ hp + gear + cyl, data = mtcars)
rez <- equivalence_test(m, range = c(-Inf, 0.5))
vdiffr::expect_doppelganger(
"Equivalence-Test 3",
plot(rez)
)
rez <- equivalence_test(m, range = c(-0.5, 0.5))
vdiffr::expect_doppelganger(
"Equivalence-Test 4",
plot(rez)
)
rez <- equivalence_test(m, range = c(-2, 2))
vdiffr::expect_doppelganger(
"Equivalence-Test 5",
plot(rez)
)
})
parameters/tests/testthat/test-model_parameters.gam.R 0000644 0001762 0000144 00000001314 14716604201 022605 0 ustar ligges users test_that("model_parameters.gam", {
skip_if_not_installed("mgcv")
set.seed(123)
model <-
mgcv::gam(
formula = mpg ~ s(hp) + s(wt) + factor(cyl) + am + qsec,
family = stats::quasi(),
data = mtcars
)
params <- model_parameters(model)
expect_equal(params$SE, c(10.83359, 1.80704, 2.82608, 1.71366, 0.53172, NA, NA), tolerance = 1e-2)
expect_equal(params$df_error, c(23.3923, 23.3923, 23.3923, 23.3923, 23.3923, NA, NA), tolerance = 1e-2)
expect_equal(params$CI[[1]], 0.95, tolerance = 1e-2)
expect_named(
params,
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t / F",
"df", "df_error", "p", "Component"
)
)
})
parameters/tests/testthat/test-MCMCglmm.R 0000644 0001762 0000144 00000001666 14413515226 020127 0 ustar ligges users skip_if_not_installed("MCMCglmm")
data(PlodiaPO, package = "MCMCglmm")
set.seed(123)
m1 <- MCMCglmm::MCMCglmm(
PO ~ plate,
random = ~FSfamily,
data = PlodiaPO,
verbose = FALSE,
nitt = 1300,
burnin = 300,
thin = 1
)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(0.97495, 0.03407),
tolerance = 0.01
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.02309, 0.00509),
tolerance = 0.01
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 0),
tolerance = 0.01
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1, centrality = "mean", verbose = FALSE)$Mean,
c(1.0132, 0.04232),
tolerance = 0.01
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1, centrality = "median", verbose = FALSE)$Median,
c(1.01382, 0.04207),
tolerance = 0.01
)
})
parameters/tests/testthat/test-standardize_info.R 0000644 0001762 0000144 00000001251 14716604201 022042 0 ustar ligges users test_that("standardize_info", {
skip_if_not_installed("datawizard", minimum_version = "0.12.0")
skip_if_not_installed("nlme")
skip_if_not_installed("lme4")
fm1 <- nlme::lme(mpg ~ cyl, mtcars, random = ~ 1 | gear)
fm2 <- nlme::gls(mpg ~ cyl, mtcars)
i1 <- standardize_info(fm1)
i2 <- standardize_info(fm2)
expect_equal(i1$Deviation_Response_Basic, c(sd(mtcars$mpg), sd(mtcars$mpg)), tolerance = 1e-3)
expect_equal(i2$Deviation_Response_Basic, c(sd(mtcars$mpg), sd(mtcars$mpg)), tolerance = 1e-3)
expect_equal(i1$Deviation_Basic, c(0, sd(mtcars$cyl)), tolerance = 1e-3)
expect_equal(i2$Deviation_Basic, c(0, sd(mtcars$cyl)), tolerance = 1e-3)
})
parameters/tests/testthat/test-p_calibrate.R 0000644 0001762 0000144 00000003052 14716604201 020765 0 ustar ligges users data(mtcars)
model <- lm(mpg ~ wt + as.factor(gear) + am, data = mtcars)
test_that("p_calibrate model", {
expect_silent(p_calibrate(model, verbose = FALSE))
expect_warning({
out <- p_calibrate(model)
})
expect_identical(dim(out), c(5L, 3L))
expect_named(out, c("Parameter", "p", "p_calibrated"))
expect_equal(out$p_calibrated, c(0, 5e-05, 0.48261, NA, NA), tolerance = 1e-4)
expect_warning({
out <- p_calibrate(model, type = "bayes")
})
expect_equal(out$p_calibrated, c(0, 5e-05, 0.93276, NA, NA), tolerance = 1e-4)
})
test_that("p_calibrate numeric", {
p <- c(0.2, 0.1, 0.05, 0.01, 0.005, 0.001)
# See Table 1 Sellke et al. doi: 10.1198/000313001300339950
out <- p_calibrate(p)
expect_equal(out, c(0.4667, 0.385, 0.2893, 0.1113, 0.0672, 0.0184), tolerance = 1e-3)
out <- p_calibrate(p, type = "bayes")
expect_equal(out, c(0.875, 0.6259, 0.4072, 0.1252, 0.072, 0.0188), tolerance = 1e-3)
})
test_that("p_calibrate print", {
out <- p_calibrate(model, verbose = FALSE)
ref <- capture.output(print(out))
expect_identical(
ref,
c(
"Parameter | p | p (calibrated)",
"------------------------------------------",
"(Intercept) | < .001 | < .001",
"wt | < .001 | < .001",
"as.factor(gear)4 | 0.242 | 0.483 ",
"as.factor(gear)5 | 0.660 | ",
"am | 0.925 | ",
"Calibrated p-values indicate the posterior probability of H0."
)
)
})
parameters/tests/testthat/test-gam.R 0000644 0001762 0000144 00000001242 14413515226 017265 0 ustar ligges users skip_if_not_installed("mgcv")
set.seed(123)
dat <- mgcv::gamSim(1, n = 400, dist = "normal", scale = 2, verbose = FALSE)
m1 <- mgcv::gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(7.771085, NA, NA, NA, NA),
tolerance = 1e-2
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.1020741, NA, NA, NA, NA),
tolerance = 1e-2
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 0, 0, 0, 0.00196),
tolerance = 1e-2
)
})
skip_on_cran()
mp <- model_parameters(m1)
test_that("model_parameters", {
expect_snapshot(mp)
})
parameters/tests/testthat/test-model_parameters.pairwise.htest.R 0000644 0001762 0000144 00000001502 14355245205 025015 0 ustar ligges users test_that("model_parameters.pairwise.htest", {
data(airquality)
airquality$Month <- factor(airquality$Month, labels = month.abb[5:9])
model <- pairwise.t.test(airquality$Ozone, airquality$Month)
mp <- model_parameters(model)
expect_equal(
mp$Group1,
c("Jun", "Jul", "Jul", "Aug", "Aug", "Aug", "Sep", "Sep", "Sep", "Sep")
)
expect_equal(
mp$p,
c(1, 0.00026, 0.05113, 0.00019, 0.04987, 1, 1, 1, 0.00488, 0.00388),
tolerance = 1e-3
)
smokers <- c(83, 90, 129, 70)
patients <- c(86, 93, 136, 82)
model <- suppressWarnings(pairwise.prop.test(smokers, patients))
mp <- model_parameters(model)
expect_equal(
mp$Group1,
c("2", "3", "3", "4", "4", "4")
)
expect_equal(
mp$p,
c(1, 1, 1, 0.11856, 0.09322, 0.12377),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-gee.R 0000644 0001762 0000144 00000001376 14413515226 017271 0 ustar ligges users skip_if_not_installed("gee")
data(warpbreaks)
void <- capture.output({
m1_gee <- suppressMessages(gee::gee(breaks ~ tension, id = wool, data = warpbreaks))
})
test_that("ci", {
expect_equal(
suppressMessages(ci(m1_gee))$CI_low,
c(30.90044, -17.76184, -22.48406),
tolerance = 1e-3
)
})
test_that("se", {
expect_equal(
standard_error(m1_gee)$SE,
c(2.80028, 3.96019, 3.96019),
tolerance = 1e-3
)
})
test_that("p_value", {
expect_equal(
p_value(m1_gee)$p,
c(0, 0.01157, 2e-04),
tolerance = 1e-3
)
})
mp <- suppressWarnings(model_parameters(m1_gee))
test_that("model_parameters", {
expect_equal(
mp$Coefficient,
c(36.38889, -10, -14.72222),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-pipe.R 0000644 0001762 0000144 00000001544 14716604201 017461 0 ustar ligges users skip_on_cran()
skip_if(getRversion() < "4.2.0")
test_that("print in pipe", {
data(iris)
out <- capture.output({
lm(Sepal.Length ~ Petal.Length + Species, data = iris) |>
model_parameters() |>
print(include_reference = TRUE)
})
expect_identical(
out[5],
"Species [setosa] | 0.00 | | | | "
)
})
skip_if_not_installed("withr")
withr::with_options(
list(easystats_table_width = Inf),
test_that("print in pipe, on-the-fly factor", {
data(mtcars)
out <- capture.output({
mtcars |>
lm(mpg ~ cut(wt, c(0, 2.5, 3, 5)), data = _) |>
model_parameters(include_reference = TRUE)
})
expect_identical(
out[4],
"cut(wt, c(0, 2.5, 3, 5)) [>0-2.5] | 0.00 | | | | "
)
})
)
parameters/tests/testthat/test-printing2.R 0000644 0001762 0000144 00000010132 14716604201 020431 0 ustar ligges users skip_if_not_installed("withr")
skip_if(getRversion() < "4.0.0")
withr::with_options(
list(parameters_interaction = "*", easystats_table_width = Inf),
{
lm1 <- lm(Sepal.Length ~ Species, data = iris)
lm2 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris)
lm3 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris)
# Basic -------
out <- compare_parameters(lm1, lm2, lm3)
test_that("multiple model", {
expect_snapshot(print(out))
})
# templates --------------
out <- compare_parameters(lm1, lm2, lm3, select = "se_p")
test_that("templates", {
expect_snapshot(print(out))
})
out <- compare_parameters(lm1, lm2, lm3, select = "{estimate}{stars} ({se})")
test_that("templates, glue-1", {
expect_snapshot(print(out))
})
out <- compare_parameters(lm1, lm2, lm3, select = "{estimate} ({ci_low}, {ci_high}), p={p}{stars}")
test_that("templates, glue-2", {
expect_snapshot(print(out))
})
out <- compare_parameters(lm1, lm2, lm3, select = "{estimate} ({se})|{p}")
test_that("templates, glue-3, separate columnns", {
expect_snapshot(print(out))
})
# grouping parameters --------------
lm1 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris)
lm2 <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
# remove intercept
out <- compare_parameters(lm1, lm2, drop = "^\\(Intercept")
test_that("templates, glue-3, separate columnns", {
expect_snapshot(
print(out, groups = list(
Species = c(
"Species [versicolor]",
"Species [virginica]"
),
Interactions = c(
"Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
),
Controls = "Petal Length"
))
)
expect_snapshot(
print(out, groups = list(
Species = c(
"Species [versicolor]",
"Species [virginica]"
),
Interactions = c(
"Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
),
Controls = "Petal Length"
), select = "{estimate}{stars}")
)
expect_snapshot(
print(out, groups = list(
Species = c(
"Species [versicolor]",
"Species [virginica]"
),
Interactions = c(
"Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
),
Controls = "Petal Length"
), select = "{estimate}|{p}")
)
})
test_that("combination of different models", {
skip_on_cran()
skip_if_not_installed("glmmTMB")
data("fish")
m0 <- glm(count ~ child + camper, data = fish, family = poisson())
m1 <- glmmTMB::glmmTMB(
count ~ child + camper + (1 | persons) + (1 | ID),
data = fish,
family = poisson()
)
m2 <- glmmTMB::glmmTMB(
count ~ child + camper + zg + (1 | ID),
ziformula = ~ child + (1 | persons),
data = fish,
family = glmmTMB::truncated_poisson()
)
cp <- compare_parameters(m0, m1, m2, effects = "all", component = "all")
expect_snapshot(print(cp))
})
}
)
withr::with_options(
list(parameters_interaction = "*"),
{
lm1 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris)
lm2 <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
# remove intercept
out <- compare_parameters(lm1, lm2, drop = "^\\(Intercept")
test_that("templates, glue-3, separate columnns", {
expect_snapshot(
print(out, groups = list(
Species = c(
"Species [versicolor]",
"Species [virginica]"
),
Interactions = c(
"Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
),
Controls = "Petal Length"
), select = "{estimate}|{p}")
)
})
}
)
parameters/tests/testthat/test-marginaleffects.R 0000644 0001762 0000144 00000010105 14752352271 021656 0 ustar ligges users skip_if_not_installed("marginaleffects", minimum_version = "0.25.0")
skip_if_not_installed("rstanarm")
test_that("marginaleffects()", {
# Frequentist
x <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
model <- marginaleffects::avg_slopes(x, newdata = insight::get_datagrid(x, by = "Species"), variables = "Petal.Length")
out <- parameters(model)
expect_identical(nrow(out), 1L)
cols <- c("Parameter", "Comparison", "Coefficient", "SE", "Statistic", "p", "S", "CI", "CI_low", "CI_high")
expect_true(all(cols %in% colnames(out)))
out <- model_parameters(model, exponentiate = TRUE)
expect_equal(out$Coefficient, 1.394, tolerance = 1e-3)
# Bayesian
x <- suppressWarnings(
rstanarm::stan_glm(
Sepal.Width ~ Species * Petal.Length,
data = iris,
refresh = 0,
iter = 100,
chains = 1
)
)
model <- marginaleffects::avg_slopes(x, newdata = insight::get_datagrid(x, by = "Species"), variables = "Petal.Length")
expect_identical(nrow(parameters(model)), 1L)
})
test_that("predictions()", {
x <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
p <- marginaleffects::avg_predictions(x, by = "Species")
out <- parameters(p)
expect_identical(nrow(out), 3L)
expect_named(out, c(
"Predicted", "SE", "CI", "CI_low", "CI_high", "S", "Statistic",
"p", "Species"
))
out <- parameters(p, exponentiate = TRUE)
expect_equal(out$Predicted, c(30.81495, 15.95863, 19.57004), tolerance = 1e-4)
})
test_that("comparisons()", {
data(iris)
# Frequentist
x <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
m <- marginaleffects::avg_comparisons(x, newdata = insight::get_datagrid(x, by = "Species"), variables = "Petal.Length")
expect_identical(nrow(parameters(m)), 1L)
out <- parameters(m, exponentiate = TRUE)
expect_equal(out$Coefficient, 1.393999, tolerance = 1e-4)
# Bayesian
x <- suppressWarnings(
rstanarm::stan_glm(
Sepal.Width ~ Species * Petal.Length,
data = iris,
refresh = 0,
iter = 100,
chains = 1
)
)
m <- marginaleffects::avg_slopes(
x,
newdata = insight::get_datagrid(x, by = "Species"),
variables = "Petal.Length"
)
expect_identical(nrow(parameters(m)), 1L)
})
test_that("hypotheses()", {
data(mtcars)
x <- lm(mpg ~ hp + wt, data = mtcars)
m <- marginaleffects::hypotheses(x, "hp = wt")
expect_identical(nrow(parameters(m)), 1L)
})
test_that("multiple contrasts: Issue #779", {
skip_if(getRversion() < "4.0.0")
data(mtcars)
mod <- lm(mpg ~ as.factor(gear) * as.factor(cyl), data = mtcars)
cmp <- suppressWarnings(marginaleffects::comparisons(
mod,
variables = c("gear", "cyl"),
newdata = insight::get_datagrid(mod, by = c("gear", "cyl")),
cross = TRUE
))
cmp <- suppressWarnings(parameters(cmp))
expect_true("Comparison: gear" %in% colnames(cmp))
expect_true("Comparison: cyl" %in% colnames(cmp))
})
test_that("model_parameters defaults to FALSE: Issue #916", {
data(mtcars)
mod <- lm(mpg ~ wt, data = mtcars)
pred <- marginaleffects::predictions(mod, newdata = marginaleffects::datagrid(wt = c(1, 2)))
out1 <- model_parameters(pred)
out2 <- model_parameters(pred, exponentiate = FALSE)
expect_equal(out1$Predicted, out2$Predicted, tolerance = 1e-4)
})
test_that("digits and ci_digits for marginaleffects", {
data(mtcars)
skip_if(getRversion() < "4.2.0")
out <- lm(mpg ~ wt, data = mtcars) |>
marginaleffects::hypotheses(hypothesis = "10*wt = 0") |>
model_parameters(digits = 1)
expect_snapshot(out)
})
test_that("preserve columns with same name as reserved words", {
data(mtcars)
skip_if(getRversion() < "4.2.0")
skip_if_not_installed("modelbased")
set.seed(1234)
x <- rnorm(200)
z <- rnorm(200)
# quadratic relationship
y <- 2 * x + x^2 + 4 * z + rnorm(200)
d <- data.frame(x, y, z)
model <- lm(y ~ x + z, data = d)
pred <- modelbased::estimate_means(model, c("x", "z"))
expect_named(pred, c("x", "z", "Mean", "SE", "CI_low", "CI_high", "t", "df"))
})
parameters/tests/testthat/test-pca.R 0000644 0001762 0000144 00000005622 14716604201 017270 0 ustar ligges users skip_if_not_installed("psych")
skip_if_not_installed("nFactors")
skip_if_not_installed("GPArotation")
test_that("principal_components", {
x <- principal_components(mtcars[, 1:7], rotation = "varimax")
expect_equal(
x$RC1,
c(
-0.836114674884308,
0.766808147590597,
0.85441780762136,
0.548502661888057,
-0.889046093964722,
0.931879020871552,
-0.030485507571411
),
tolerance = 0.01
)
expect_named(x, c("Variable", "RC1", "RC2", "Complexity", "Uniqueness", "MSA"))
expect_identical(dim(predict(x)), c(32L, 2L))
expect_named(predict(x, names = c("A", "B")), c("A", "B"))
expect_identical(nrow(predict(x, newdata = mtcars[1:3, 1:7])), 3L)
})
test_that("principal_components, n", {
data(iris)
x <- principal_components(iris[1:4], n = 2)
expect_named(x, c("Variable", "PC1", "PC2", "Complexity"))
x <- principal_components(iris[1:4], n = 1)
expect_named(x, c("Variable", "PC1", "Complexity"))
})
test_that("principal_components", {
x <- principal_components(mtcars[, 1:7])
expect_equal(
x$PC1,
c(
-0.930866058535747,
0.9578708009312,
0.952846253483008,
0.874493647245971,
-0.746868056938478,
0.882509152331738,
-0.541093678419456
),
tolerance = 0.01
)
expect_named(x, c("Variable", "PC1", "PC2", "Complexity"))
expect_identical(dim(predict(x)), c(32L, 2L))
})
# print ----
test_that("print model_parameters pca", {
data(mtcars)
expect_snapshot(print(principal_components(mtcars[, 1:4], n = "auto")))
expect_snapshot(print(
principal_components(mtcars[, 1:4], n = "auto"),
labels = c(
"Miles/(US) gallon",
"Number of cylinders",
"Displacement (cu.in.)",
"Gross horsepower"
)
))
})
# predict ----------------------
# N.B tests will fail if `GPArotation` package is not installed
test_that("predict model_parameters fa", {
d <- na.omit(psych::bfi[, 1:25])
model <- psych::fa(d, nfactors = 5)
mp <- model_parameters(model, sort = TRUE, threshold = "max")
pr <- suppressMessages(
predict(mp, names = c("Neuroticism", "Conscientiousness", "Extraversion", "Agreeableness", "Opennness"))
)
out <- head(pr, 5)
expect_equal(
out$Neuroticism,
c(-0.22242, 0.1618, 0.61907, -0.11692, -0.17372),
tolerance = 0.01
)
expect_equal(
out$Opennness,
c(-1.6092, -0.17222, 0.23341, -1.06152, -0.66086),
tolerance = 0.01
)
expect_identical(nrow(predict(mp, keep_na = FALSE)), 2436L)
expect_identical(nrow(predict(mp, newdata = d[1:10, ], keep_na = FALSE)), 10L)
expect_named(
predict(mp, names = c("A", "B", "C", "D", "E"), keep_na = FALSE),
c("A", "B", "C", "D", "E")
)
model <- factor_analysis(d, n = 5)
expect_identical(nrow(predict(model, keep_na = FALSE)), 2436L)
})
unloadNamespace("GPArotation")
parameters/tests/testthat/test-compare_parameters.R 0000644 0001762 0000144 00000017317 14721357710 022410 0 ustar ligges users skip_if_not_installed("withr")
# make sure we have the correct interaction mark for tests
withr::with_options(
list(parameters_interaction = "*", easystats_table_width = Inf),
{
data(iris)
m1 <- lm(Sepal.Length ~ Species, data = iris)
m2 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris)
counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12)
outcome <- gl(3, 1, 9)
treatment <- gl(3, 3)
m3 <- glm(counts ~ outcome + treatment, family = poisson())
x <- compare_parameters(m1, m2, m3)
test_that("compare_parameters, default", {
expect_identical(
colnames(x),
c(
"Parameter", "Component", "Effects", "Coefficient.m1", "SE.m1", "CI.m1",
"CI_low.m1", "CI_high.m1", "t.m1", "df_error.m1", "p.m1", "Coefficient.m2",
"SE.m2", "CI.m2", "CI_low.m2", "CI_high.m2", "t.m2", "df_error.m2",
"p.m2", "Log-Mean.m3", "SE.m3", "CI.m3", "CI_low.m3", "CI_high.m3",
"z.m3", "df_error.m3", "p.m3"
)
)
out <- capture.output(x)
expect_length(out, 14)
out <- format(x, select = "ci")
expect_identical(colnames(out), c("Parameter", "m1", "m2", "m3"))
expect_identical(
out$Parameter,
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length", "outcome [2]", "outcome [3]",
"treatment [2]", "treatment [3]", NA, "Observations"
)
)
})
x <- compare_parameters(m1, m2, m3, select = "se_p2")
test_that("compare_parameters, se_p2", {
expect_identical(
colnames(x),
c(
"Parameter", "Component", "Effects", "Coefficient.m1", "SE.m1", "CI.m1",
"CI_low.m1", "CI_high.m1", "t.m1", "df_error.m1", "p.m1", "Coefficient.m2",
"SE.m2", "CI.m2", "CI_low.m2", "CI_high.m2", "t.m2", "df_error.m2",
"p.m2", "Log-Mean.m3", "SE.m3", "CI.m3", "CI_low.m3", "CI_high.m3",
"z.m3", "df_error.m3", "p.m3"
)
)
out <- capture.output(x)
expect_length(out, 14)
out <- format(x, select = "se_p2")
expect_identical(
colnames(out),
c(
"Parameter", "Estimate (SE) (m1)", "p (m1)", "Estimate (SE) (m2)",
"p (m2)", "Estimate (SE) (m3)", "p (m3)"
)
)
expect_identical(
out$Parameter,
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length", "outcome [2]", "outcome [3]",
"treatment [2]", "treatment [3]", NA, "Observations"
)
)
})
data(mtcars)
m1 <- lm(mpg ~ wt, data = mtcars)
m2 <- glm(vs ~ wt + cyl, data = mtcars, family = "binomial")
test_that("compare_parameters, column name with escaping regex characters", {
out <- utils::capture.output(compare_parameters(m1, m2, column_names = c("linear model (m1)", "logistic reg. (m2)")))
expect_identical(out[1], "Parameter | linear model (m1) | logistic reg. (m2)")
})
data(mtcars)
m1 <- lm(mpg ~ hp, mtcars)
m2 <- lm(mpg ~ hp, mtcars)
test_that("compare_parameters, proper printing for CI=NULL #820", {
expect_snapshot(compare_parameters(m1, m2, ci = NULL))
})
skip_on_cran()
test_that("compare_parameters, correct random effects", {
suppressWarnings(skip_if_not_installed("glmmTMB"))
skip_if_not(getRversion() >= "4.0.0")
data("fish")
m0 <- glm(count ~ child + camper, data = fish, family = poisson())
m1 <- glmmTMB::glmmTMB(
count ~ child + camper + (1 | persons) + (1 | ID),
data = fish,
family = poisson()
)
m2 <- glmmTMB::glmmTMB(
count ~ child + camper + zg + (1 | ID),
ziformula = ~ child + (1 | persons),
data = fish,
family = glmmTMB::truncated_poisson()
)
cp <- compare_parameters(m0, m1, m2, effects = "all", component = "all")
expect_snapshot(cp)
})
test_that("compare_parameters, print_md", {
skip_if_not_installed("lme4")
data(sleepstudy, package = "lme4")
set.seed(1234)
sleepstudy$grp <- as.factor(sample.int(3, nrow(sleepstudy), replace = TRUE))
lm1 <- lme4::lmer(Reaction ~ Days + grp + (1 | Subject), data = sleepstudy)
lm2 <- lme4::lmer(Reaction ~ Days * grp + (1 | Subject), data = sleepstudy)
cp <- compare_parameters(lm1, lm2, select = "{estimate} ({ci})|{p}", drop = "^\\(Intercept")
out <- print_md(cp, groups = list(
Groups = c("grp (2)", "grp (3)"),
Interactions = c("Days * grp (2)", "Days * grp (3)"),
Controls = "Days"
))
expect_snapshot(print(out))
cp <- compare_parameters(lm1, lm2, select = "{estimate} ({ci})|{p}", drop = "^\\(Intercept", effects = "all")
expect_snapshot(print_md(cp))
# error
expect_error(
print_md(cp, groups = list(
Groups = c("grp (2)", "grp (3)"),
Interactions = c("Days * grp (2)", "Days * grp (3)"),
Controls = "Days"
)),
regex = "Cannot combine"
)
# with reference level
cp <- compare_parameters(lm1, lm2, select = "{estimate} ({ci})|{p}", drop = "^\\(Intercept", include_reference = TRUE)
out <- print_md(cp, groups = list(
Groups = 2:4,
Interactions = 5:6,
Controls = 1
))
expect_snapshot(print(out))
# with reference level
cp <- compare_parameters(lm1, lm2, drop = "^\\(Intercept", include_reference = TRUE)
out <- print_md(cp, groups = list(
Groups = 2:4,
Interactions = 5:6,
Controls = 1
))
expect_snapshot(print(out))
# error
cp <- compare_parameters(lm1, lm2, select = "{estimate} ({ci})|{p}", drop = "^\\(Intercept")
expect_error(
print_md(cp, groups = list(
Groups = c("grp (2)", "grp (3)"),
Interactions = c("Days * grp (2)", "Days * grp (3)"),
Controls = "XDays"
)),
regex = "Some group indices"
)
expect_error(
print_md(cp, groups = list(
Groups = 1:2,
Interactions = 4:5,
Controls = 10
)),
regex = "Some group indices"
)
# output identical for both calls
cp1 <- compare_parameters(lm1, lm2, select = "{estimate} ({ci})|{p}", drop = "^\\(Intercept")
out1 <- capture.output(print_md(cp1, groups = list(
Groups = c("grp (2)", "grp (3)"),
Interactions = c("Days * grp (2)", "Days * grp (3)"),
Controls = "Days"
)))
cp2 <- compare_parameters(
lm1,
lm2,
select = "{estimate} ({ci})|{p}",
drop = "^\\(Intercept",
groups = list(
Groups = c("grp (2)", "grp (3)"),
Interactions = c("Days * grp (2)", "Days * grp (3)"),
Controls = "Days"
)
)
out2 <- capture.output(print_md(cp2))
expect_identical(out1, out2)
})
}
)
skip_on_cran()
skip_if_not_installed("blme")
skip_if_not_installed("glmmTMB")
skip_if_not_installed("lme4")
test_that("compare_parameters, works with blmer and glmmTMB", {
data(sleepstudy, package = "lme4")
control <- lme4::lmerControl(check.conv.grad = "ignore")
fm1 <- blme::blmer(Reaction ~ Days + (0 + Days | Subject), sleepstudy,
control = control,
cov.prior = gamma
)
fm2 <- glmmTMB::glmmTMB(Reaction ~ Days + (1 + Days | Subject), sleepstudy)
expect_silent(compare_parameters(fm1, fm2))
})
parameters/tests/testthat/test-Hmisc.R 0000644 0001762 0000144 00000002060 14413515226 017563 0 ustar ligges users test_that("issue 697", {
skip_if_not_installed("Hmisc")
skip_if_not_installed("rms")
# for some reason, Hmisc::transcan() doesn't find na.retain (which is an internal
# function in Hmisc)
na.retain <<- Hmisc:::na.retain
set.seed(1)
n <- 100
df <- data.frame(
y = round(runif(n), 2),
x1 = sample(c(-1, 0, 1), n, TRUE),
x2 = sample(c(-1, 0, 1), n, TRUE)
)
df$x1[c(0, 1, 2)] <- NA
imputer <- suppressWarnings(Hmisc::transcan(
~ x1 + x2,
data = df,
imputed = TRUE,
n.impute = 2,
pr = FALSE,
pl = FALSE
))
suppressWarnings(
mod <- Hmisc::fit.mult.impute(
y ~ x1 + x2,
fitter = rms::orm,
xtrans = imputer,
data = df,
pr = FALSE
)
)
expect_s3_class(parameters(mod), "parameters_model")
expect_s3_class(standard_error(mod), "data.frame")
expect_s3_class(p_value(mod), "data.frame")
expect_identical(nrow(parameters(mod)), 3L)
expect_identical(nrow(standard_error(mod)), 3L)
expect_identical(nrow(p_value(mod)), 3L)
})
parameters/tests/testthat/test-helper.R 0000644 0001762 0000144 00000000762 14716604201 020004 0 ustar ligges users skip_on_cran()
skip_if_not_installed("withr")
withr::with_options(
list(easystats_errors = TRUE),
test_that(".safe works with options", {
expect_error(parameters:::.safe(mean(fd)), regex = "object 'fd' not found")
expect_identical(parameters:::.safe(mean(fd), 1L), 1L)
expect_identical(parameters:::.safe(mean(c(1, 2, 3))), 2)
})
)
test_that(".safe works", {
expect_null(parameters:::.safe(mean(fd)))
expect_identical(parameters:::.safe(mean(c(1, 2, 3))), 2)
})
parameters/tests/testthat/test-random_effects_ci.R 0000644 0001762 0000144 00000030754 14736731407 022176 0 ustar ligges users skip_on_os("mac")
skip_if_not_installed("lme4")
skip_on_cran()
data(sleepstudy, package = "lme4")
data(cake, package = "lme4")
set.seed(123)
sleepstudy$Months <- sample.int(4, nrow(sleepstudy), TRUE)
m1 <- suppressMessages(lme4::lmer(
angle ~ temperature + (temperature | recipe) + (temperature | replicate),
data = cake
))
m2 <- suppressMessages(lme4::lmer(Reaction ~ Days + (Days | Subject), data = sleepstudy))
m3 <- suppressMessages(lme4::lmer(angle ~ temperature + (temperature | recipe), data = cake))
m4 <- suppressMessages(lme4::lmer(angle ~ temperature + (temperature | replicate), data = cake))
m5 <- suppressMessages(lme4::lmer(Reaction ~ Days + (Days + Months | Subject), data = sleepstudy))
## TODO also check messages for profiled CI
expect_message(
{
mp1 <- model_parameters(m1, ci_random = TRUE)
},
regex = "meaningful"
)
mp2 <- model_parameters(m2, ci_random = TRUE)
expect_message(
{
mp3 <- model_parameters(m3, ci_random = TRUE)
},
regex = "meaningful"
)
expect_message(
{
mp4 <- model_parameters(m4, ci_random = TRUE)
},
regex = "meaningful"
)
expect_message(
{
mp5 <- model_parameters(m5, ci_random = TRUE)
},
regex = "meaningful"
)
# model 1 ---------------------
test_that("random effects CIs, two slopes, categorical", {
expect_equal(
mp1$CI_low,
c(
28.75568, 4.97893, -1.95002, -2.69995, -3.62201, -2.69102,
4.28558, 0.21474, 0.40062, 0.10169, 0.04953, 1e-05, 0.55398,
0, 2e-05, 0.6333, 1.09851, 0.00944, -0.65406, -0.69103, -1, -0.95271,
-0.90617, -1, -1, -1, -1, -1, -1, -0.99802, -1, -0.75274, -0.99836,
-1, -0.96895, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, 4.07985
),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp1$Parameter,
c(
"(Intercept)", "temperature.L", "temperature.Q", "temperature.C",
"temperature^4", "temperature^5", "SD (Intercept)", "SD (Intercept)",
"SD (temperature.L)", "SD (temperature.Q)", "SD (temperature.C)",
"SD (temperature^4)", "SD (temperature^5)", "SD (temperature.L)",
"SD (temperature.Q)", "SD (temperature.C)", "SD (temperature^4)",
"SD (temperature^5)", "Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (Intercept~temperature.L)",
"Cor (Intercept~temperature.Q)", "Cor (Intercept~temperature.C)",
"Cor (Intercept~temperature^4)", "Cor (Intercept~temperature^5)",
"Cor (temperature.L~temperature.Q)", "Cor (temperature.L~temperature.C)",
"Cor (temperature.L~temperature^4)", "Cor (temperature.L~temperature^5)",
"Cor (temperature.Q~temperature.C)", "Cor (temperature.Q~temperature^4)",
"Cor (temperature.Q~temperature^5)", "Cor (temperature.C~temperature^4)",
"Cor (temperature.C~temperature^5)", "Cor (temperature^4~temperature^5)",
"Cor (temperature.L~temperature.Q)", "Cor (temperature.L~temperature.C)",
"Cor (temperature.L~temperature^4)", "Cor (temperature.L~temperature^5)",
"Cor (temperature.Q~temperature.C)", "Cor (temperature.Q~temperature^4)",
"Cor (temperature.Q~temperature^5)", "Cor (temperature.C~temperature^4)",
"Cor (temperature.C~temperature^5)", "Cor (temperature^4~temperature^5)",
"SD (Observations)"
)
)
expect_identical(
mp1$Group,
c(
"", "", "", "", "", "", "replicate", "recipe", "replicate",
"replicate", "replicate", "replicate", "replicate", "recipe",
"recipe", "recipe", "recipe", "recipe", "replicate", "replicate",
"replicate", "replicate", "replicate", "recipe", "recipe", "recipe",
"recipe", "recipe", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "recipe", "recipe", "Residual"
)
)
})
# model 2 ---------------------
test_that("random effects CIs, simple slope", {
expect_equal(
mp2$CI_low,
c(237.93546, 7.41637, 15.5817, 3.91828, -0.50907, 22.80044),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp2$Parameter,
c(
"(Intercept)", "Days", "SD (Intercept)", "SD (Days)", "Cor (Intercept~Days)",
"SD (Observations)"
)
)
expect_identical(
mp2$Group,
c("", "", "Subject", "Subject", "Subject", "Residual")
)
})
# model 3 ---------------------
test_that("random effects CIs, categorical slope-1", {
expect_equal(
mp3$CI_low[14:28],
c(-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 7.09933),
tolerance = 1e-2,
ignore_attr = TRUE
)
expect_equal(
mp3$CI_low[1:12],
c(
30.91139, 4.33247, -2.6798, -3.20703, -4.07681, -3.27237, 0.06301,
0, 0, 0.1192, 0.32213, 0
),
tolerance = 1e-2,
ignore_attr = TRUE
)
expect_identical(
mp3$Parameter,
c(
"(Intercept)", "temperature.L", "temperature.Q", "temperature.C",
"temperature^4", "temperature^5", "SD (Intercept)", "SD (temperature.L)",
"SD (temperature.Q)", "SD (temperature.C)", "SD (temperature^4)",
"SD (temperature^5)", "Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (temperature.L~temperature.Q)",
"Cor (temperature.L~temperature.C)", "Cor (temperature.L~temperature^4)",
"Cor (temperature.L~temperature^5)", "Cor (temperature.Q~temperature.C)",
"Cor (temperature.Q~temperature^4)", "Cor (temperature.Q~temperature^5)",
"Cor (temperature.C~temperature^4)", "Cor (temperature.C~temperature^5)",
"Cor (temperature^4~temperature^5)", "SD (Observations)"
)
)
expect_identical(
mp3$Group,
c(
"", "", "", "", "", "", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "Residual"
)
)
})
# model 4 ---------------------
test_that("random effects CIs, categorical slope-2", {
expect_equal(
mp4$CI_low,
c(
28.88523, 4.96796, -1.93239, -1.98597, -2.68858, -2.5524, 4.27899,
0.35378, 0.08109, 0.03419, 0, 0.49982, -0.68893, -0.71984, -1,
-0.96725, -0.92158, -1, -0.99894, -1, -0.80378, -0.99924, -1,
-0.9778, -1, -1, -1, 4.21143
),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp4$Parameter,
c(
"(Intercept)", "temperature.L", "temperature.Q", "temperature.C",
"temperature^4", "temperature^5", "SD (Intercept)", "SD (temperature.L)",
"SD (temperature.Q)", "SD (temperature.C)", "SD (temperature^4)",
"SD (temperature^5)", "Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (temperature.L~temperature.Q)",
"Cor (temperature.L~temperature.C)", "Cor (temperature.L~temperature^4)",
"Cor (temperature.L~temperature^5)", "Cor (temperature.Q~temperature.C)",
"Cor (temperature.Q~temperature^4)", "Cor (temperature.Q~temperature^5)",
"Cor (temperature.C~temperature^4)", "Cor (temperature.C~temperature^5)",
"Cor (temperature^4~temperature^5)", "SD (Observations)"
)
)
expect_identical(
mp4$Group,
c(
"", "", "", "", "", "", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "Residual"
)
)
})
# model 5 ---------------------
test_that("random effects CIs, double slope", {
expect_equal(
mp5$CI_low,
c(237.99863, 7.4022, 12.63814, 0.58664, 0, -0.58599, -1, -1, 22.65226),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp5$Parameter,
c(
"(Intercept)", "Days", "SD (Intercept)", "SD (Days)", "SD (Months)",
"Cor (Intercept~Days)", "Cor (Intercept~Months)",
"Cor (Days~Months)", "SD (Observations)"
)
)
expect_identical(
mp5$Group,
c(
"", "", "Subject", "Subject", "Subject", "Subject", "Subject",
"Subject", "Residual"
)
)
})
# no random intercept --------------------------
test_that("random effects CIs, simple slope", {
data(sleepstudy, package = "lme4")
set.seed(123)
sleepstudy$Months <- sample.int(4, nrow(sleepstudy), TRUE)
m2 <- lme4::lmer(Reaction ~ Days + (0 + Days | Subject), data = sleepstudy)
m5 <- lme4::lmer(Reaction ~ Days + (0 + Days + Months | Subject), data = sleepstudy)
mp2 <- model_parameters(m2)
mp5 <- model_parameters(m5)
expect_equal(
mp2$CI_low,
c(243.47155, 6.77765, 5.09041, 26.01525),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp2$Parameter,
c("(Intercept)", "Days", "SD (Days)", "SD (Observations)")
)
expect_equal(
mp5$CI_low,
c(241.61021, 7.43503, 4.11446, 2.69857, -0.40595, 24.632),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp5$Parameter,
c(
"(Intercept)", "Days", "SD (Days)", "SD (Months)", "Cor (Days~Months)",
"SD (Observations)"
)
)
})
# poly random slope --------------------------
test_that("random effects CIs, poly slope", {
data(cake, package = "lme4")
suppressMessages({
m <- lme4::lmer(angle ~ poly(temp, 2) + (poly(temp, 2) | replicate) + (1 | recipe), data = cake)
})
mp <- model_parameters(m, ci_random = TRUE)
expect_equal(
mp$CI_low,
c(
28.7884, 33.56318, -12.84259, 4.27435, 0.16222, 7.78988, 0.87668,
-0.8172, -1, -1, 4.32855
),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp$Parameter,
c(
"(Intercept)", "poly(temp, 2)1", "poly(temp, 2)2", "SD (Intercept)",
"SD (Intercept)", "SD (poly(temp, 2)1)", "SD (poly(temp, 2)2)",
"Cor (Intercept~poly(temp, 2)1)", "Cor (Intercept~poly(temp, 2)2)",
"Cor (poly(temp, 2)1~poly(temp, 2)2)", "SD (Observations)"
)
)
})
# poly and categorical random slope --------------------------
test_that("random effects CIs, poly categorical slope", {
## NOTE check back every now and then and see if tests still work
skip("works interactively")
m <- lme4::lmer(angle ~ poly(temp, 2) + (poly(temp, 2) | replicate) + (temperature | recipe),
data = cake
)
mp <- model_parameters(m, effects = "random")
expect_equal(
mp$CI_low,
c(
4.27846, 0.22005, 8.22659, 1.17579, 0, 5e-05, 0.37736, 1.24258,
0, -0.77207, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, 4.22056
),
tolerance = 1e-3,
ignore_attr = TRUE
)
expect_identical(
mp$Parameter,
c(
"SD (Intercept)", "SD (Intercept)", "SD (poly(temp, 2)1)",
"SD (poly(temp, 2)2)", "SD (temperature.L)", "SD (temperature.Q)",
"SD (temperature.C)", "SD (temperature^4)", "SD (temperature^5)",
"Cor (Intercept~poly(temp, 2)1)", "Cor (Intercept~poly(temp, 2)2)",
"Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (poly(temp, 2)1~poly(temp, 2)2)",
"Cor (temperature.L~temperature.Q)", "Cor (temperature.L~temperature.C)",
"Cor (temperature.L~temperature^4)", "Cor (temperature.L~temperature^5)",
"Cor (temperature.Q~temperature.C)", "Cor (temperature.Q~temperature^4)",
"Cor (temperature.Q~temperature^5)", "Cor (temperature.C~temperature^4)",
"Cor (temperature.C~temperature^5)", "Cor (temperature^4~temperature^5)",
"SD (Observations)"
)
)
expect_identical(
mp$Group,
c(
"replicate", "recipe", "replicate", "replicate", "recipe",
"recipe", "recipe", "recipe", "recipe", "replicate", "replicate",
"recipe", "recipe", "recipe", "recipe", "recipe", "replicate",
"recipe", "recipe", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "Residual"
)
)
})
parameters/tests/testthat/test-model_parameters.aov.R 0000644 0001762 0000144 00000011647 14761570351 022650 0 ustar ligges users skip_on_cran()
iris$Cat1 <- rep_len(c("X", "X", "Y"), nrow(iris))
iris$Cat2 <- rep_len(c("A", "B"), nrow(iris))
# aov ----------------------------------
test_that("model_parameters.aov", {
skip_if_not_installed("effectsize", minimum_version = "0.5.0")
model <- aov(Sepal.Width ~ Species, data = iris)
mp <- suppressMessages(model_parameters(model, es_type = c("omega", "eta", "epsilon")))
expect_identical(mp$Parameter, c("Species", "Residuals"))
expect_equal(mp$Sum_Squares, c(11.34493, 16.962), tolerance = 1e-3)
})
test_that("model_parameters.aov", {
skip_if_not_installed("effectsize", minimum_version = "0.5.0")
model <- aov(Sepal.Width ~ Species, data = iris)
mp <- suppressMessages(model_parameters(model, es_type = c("omega", "eta", "epsilon")))
expect_identical(sum(mp$df), 149)
expect_named(mp, c(
"Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Omega2", "Eta2", "Epsilon2"
))
model <- aov(Sepal.Length ~ Species * Cat1 * Cat2, data = iris)
expect_identical(sum(model_parameters(model, es_type = c("omega", "eta", "epsilon"), verbose = FALSE)$df), 149)
model <- aov(Sepal.Length ~ Species / Cat1 * Cat2, data = iris)
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 149)
})
test_that("model_parameters.anova", {
skip_if_not_installed("lme4")
model <- anova(lm(Sepal.Width ~ Species, data = iris))
expect_identical(sum(model_parameters(model)$df), 149L)
model <- anova(lm(Sepal.Length ~ Species * Cat1 * Cat2, data = iris))
expect_identical(sum(model_parameters(model)$df), 149L)
model <- anova(lme4::lmer(wt ~ 1 + (1 | gear), data = mtcars))
expect_identical(nrow(model_parameters(model)), 0L)
model <- anova(lme4::lmer(wt ~ cyl + (1 | gear), data = mtcars))
expect_identical(sum(model_parameters(model)$df), 1L)
model <- anova(lme4::lmer(wt ~ drat + cyl + (1 | gear), data = mtcars))
expect_identical(sum(model_parameters(model)$df), 2L)
model <- anova(lme4::lmer(wt ~ drat * cyl + (1 | gear), data = mtcars))
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 3L)
model <- anova(lme4::lmer(wt ~ drat / cyl + (1 | gear), data = mtcars))
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 2L)
})
test_that("model_parameters.anova", {
skip_if_not_installed("curl")
skip_if_offline()
skip_if_not_installed("httr2")
model <- insight::download_model("anova_3")
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 149L)
model <- insight::download_model("anova_4")
expect_identical(sum(model_parameters(model, verbose = FALSE)$df, na.rm = TRUE), 2)
model <- insight::download_model("anova_lmerMod_5")
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 1L)
model <- insight::download_model("anova_lmerMod_6")
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 12)
})
test_that("model_parameters.anova", {
model <- aov(wt ~ cyl + Error(gear), data = mtcars)
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 31)
model <- aov(Sepal.Length ~ Species * Cat1 + Error(Cat2), data = iris)
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 149)
model <- aov(Sepal.Length ~ Species / Cat1 + Error(Cat2), data = iris)
expect_identical(sum(model_parameters(model, verbose = FALSE)$df), 149)
})
test_that("model_parameters.aov - table_wide", {
skip_if_not_installed("effectsize")
skip_if_not_installed("datawizard")
data("iris")
# can't use the pipe yet :(
iris_long <- datawizard::data_modify(iris, id = seq_along(Species))
iris_long <- datawizard::data_to_long(iris_long, select = colnames(iris)[1:4])
iris_long <- datawizard::data_separate(iris_long,
select = "name", separator = "\\.",
new_columns = c("attribute", "measure")
)
mod1 <- stats::aov(
formula = value ~ attribute * measure + Error(id),
data = iris_long
)
mod2 <- stats::aov(
formula = value ~ attribute * measure + Error(id / (attribute * measure)),
data = iris_long
)
mp1 <- model_parameters(mod1, eta_squared = "partial", ci = 0.95, table_wide = TRUE)
mp2 <- model_parameters(mod2, eta_squared = "partial", ci = 0.95, table_wide = TRUE)
expect_identical(nrow(mp1), 3L)
expect_identical(nrow(mp2), 6L)
mod1 <- aov(yield ~ N * P * K + Error(block), data = npk)
out1 <- model_parameters(mod1, table_wide = FALSE)
out2 <- model_parameters(mod1, table_wide = TRUE)
idx <- which(out1$Parameter == "Residuals")
expect_true(all(out2$Sum_Squares_Error %in% out1$Sum_Squares[idx]))
expect_true(all(out1$Sum_Squares[idx] %in% out2$Sum_Squares_Error))
expect_true(all(out2$Mean_Square_Error %in% out1$Mean_Square[idx]))
expect_true(all(out1$Mean_Square[idx] %in% out2$Mean_Square_Error))
expect_true(all(out2$df_error %in% out1$df[idx]))
expect_true(all(out1$df[idx] %in% out2$df_error))
})
parameters/tests/testthat/test-dominance_analysis.R 0000644 0001762 0000144 00000004107 14726272305 022371 0 ustar ligges users skip_if_not_installed("performance")
skip_if_not_installed("domir")
skip_if_not_installed("datawizard")
DA_test_model <- lm(mpg ~ vs + cyl + carb, data = mtcars)
DA_performance <- dominance_analysis(DA_test_model)
DA_domir <- domir::domin(mpg ~ vs + cyl + carb, lm, list(performance::r2, "R2"), data = mtcars)
test_that("dominance_analysis$general_dominance", {
gnrl_domir <- c(NA, DA_domir$General_Dominance)
names(gnrl_domir) <- NULL
gnrl_da <- DA_performance$General$General_Dominance
expect_identical(gnrl_domir, gnrl_da)
})
test_that("dominance_analysis$conditional_dominance", {
cdl_domir <- DA_domir$Conditional_Dominance
dimnames(cdl_domir) <- c(NULL, NULL)
cdl_da <- as.matrix(DA_performance$Conditional[, -1])
dimnames(cdl_da) <- c(NULL, NULL)
expect_identical(cdl_domir, cdl_da)
})
test_that("dominance_analysis$complete_dominance", {
cpt_domir <- DA_domir$Complete_Dominance
dimnames(cpt_domir) <- list(NULL, NULL)
cpt_da <- t(DA_performance$Complete[, -1])
dimnames(cpt_da) <- list(NULL, NULL)
expect_identical(cpt_domir, cpt_da)
})
DA_performance2 <- dominance_analysis(
DA_test_model,
all = ~vs,
sets = c(~carb),
complete = FALSE,
conditional = FALSE
)
DA_domir2 <- domir::domin(
mpg ~ cyl,
lm,
list(performance::r2, "R2"),
all = "vs",
sets = list("carb"),
data = mtcars,
complete = FALSE,
conditional = FALSE
)
test_that("dominance_analysis$general_dominance with sets/all", {
domir_all_sub_r2 <- DA_domir2$Fit_Statistic_All_Subsets
names(domir_all_sub_r2) <- NULL
expect_identical(
domir_all_sub_r2,
with(DA_performance2$General, General_Dominance[Subset == "all"])
)
gnrl_domir2 <- DA_domir2$General_Dominance
names(gnrl_domir2) <- NULL
gnrl_da2 <- aggregate(
DA_performance2$General$General_Dominance,
list(DA_performance2$General$Subset), mean
)
gnrl_da2 <- gnrl_da2[which(gnrl_da2$Group.1 %in% c("cyl", "set1")), ]
gnrl_da2 <- gnrl_da2$x
names(gnrl_da2) <- NULL
expect_identical(gnrl_domir2, gnrl_da2)
})
parameters/tests/testthat/test-estimatr.R 0000644 0001762 0000144 00000000655 14413515226 020360 0 ustar ligges users test_that("multivariate used to break: Insight Issue #618", {
skip_if_not_installed("estimatr")
# multivariate
mod1 <- estimatr::lm_robust(cbind(mpg, qsec) ~ cyl + disp, data = mtcars)
m <- model_parameters(mod1)
expect_s3_class(m, "parameters_model")
# univariate
mod2 <- estimatr::lm_robust(mpg ~ cyl + disp, data = mtcars)
m <- model_parameters(mod2)
expect_s3_class(m, "parameters_model")
})
parameters/tests/testthat/test-model_parameters.hurdle.R 0000644 0001762 0000144 00000001366 14413515226 023335 0 ustar ligges users test_that("model_parameters.hurdle", {
skip_if_not_installed("pscl")
set.seed(123)
data("bioChemists", package = "pscl")
model <- pscl::hurdle(formula = art ~ ., data = bioChemists, zero = "geometric")
params <- model_parameters(model)
expect_equal(
params$SE,
c(
0.12246,
0.06522,
0.07283,
0.04845,
0.0313,
0.00228,
0.29552,
0.15911,
0.18082,
0.11113,
0.07956,
0.01302
),
tolerance = 1e-3
)
expect_equal(
params$Coefficient,
unname(coef(model)),
tolerance = 1e-3
)
expect_equal(
params$z,
unname(c(coef(summary(model))[[1]][, 3], coef(summary(model))[[2]][, 3])),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-model_parameters.afex_aov.R 0000644 0001762 0000144 00000002003 14413515226 023627 0 ustar ligges users test_that("afex_aov", {
skip_if_not_installed("afex")
data(obk.long, package = "afex")
m_between <- suppressMessages(suppressWarnings(
afex::aov_car(value ~ treatment * gender + Error(id), data = obk.long)
))
m_within <- suppressMessages(suppressWarnings(
afex::aov_car(value ~ Error(id / (phase * hour)), data = obk.long)
))
mp1 <- model_parameters(m_between, verbose = FALSE)
mp2 <- model_parameters(m_within, verbose = FALSE)
expect_equal(c(nrow(mp1), ncol(mp1)), c(5, 7))
expect_equal(mp1$Sum_Squares, c(450.62069, 11.98202, 5.56322, 8.68275, 15.2037), tolerance = 1e-3)
expect_equal(c(nrow(mp2), ncol(mp2)), c(3, 9))
expect_equal(mp2$Sum_Squares, c(167.5, 106.29167, 11.08333), tolerance = 1e-3)
expect_equal(
colnames(mp1),
c("Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p", "Method")
)
expect_equal(
colnames(mp2),
c("Parameter", "Sum_Squares", "Sum_Squares_Error", "df", "df_error", "Mean_Square", "F", "p", "Method")
)
})
parameters/tests/testthat/test-p_function.R 0000644 0001762 0000144 00000004340 14716604201 020665 0 ustar ligges users data(iris)
model <- lm(Sepal.Length ~ Species, data = iris)
test_that("p_function ci-levels", {
out <- p_function(model)
expect_equal(
out$CI_low,
c(
4.982759, 0.897132, 1.549132, 4.956774, 0.860384, 1.512384,
4.92192, 0.811093, 1.463093, 4.862126, 0.726531, 1.378531
),
tolerance = 1e-4
)
expect_identical(dim(out), c(12L, 5L))
expect_equal(
out$CI,
c(0.25, 0.25, 0.25, 0.5, 0.5, 0.5, 0.75, 0.75, 0.75, 0.95, 0.95, 0.95),
tolerance = 1e-4
)
ref <- ci(model)
expect_equal(
out$CI_low[out$CI == 0.95],
ref$CI_low,
tolerance = 1e-4
)
ref <- ci(model, ci = 0.5)
expect_equal(
out$CI_low[out$CI == 0.5],
ref$CI_low,
tolerance = 1e-4
)
out <- p_function(model, ci_levels = c(0.3, 0.6, 0.9))
expect_equal(
out$CI,
c(0.3, 0.3, 0.3, 0.6, 0.6, 0.6, 0.9, 0.9, 0.9),
tolerance = 1e-4
)
skip_if_not_installed("sandwich")
out <- p_function(model, vcov = "HC3")
expect_equal(
out$CI_low,
c(
4.989925, 0.901495, 1.548843, 4.971951, 0.869624, 1.511772,
4.947844, 0.826875, 1.462047, 4.906485, 0.753538, 1.376742
),
tolerance = 1e-4
)
})
test_that("p_function keep-drop", {
out <- p_function(model, keep = "Speciesversicolor")
expect_identical(dim(out), c(4L, 5L))
expect_equal(
out$CI,
c(0.25, 0.5, 0.75, 0.95),
tolerance = 1e-4
)
expect_identical(
out$Parameter,
c(
"Speciesversicolor", "Speciesversicolor", "Speciesversicolor",
"Speciesversicolor"
)
)
})
test_that("p_function print", {
out <- p_function(model)
ref <- capture.output(print(out))
expect_identical(
ref,
c(
"Consonance Function",
"",
"Parameter | 25% CI | 50% CI | 75% CI | 95% CI",
"--------------------------------------------------------------------------------",
"(Intercept) | [4.98, 5.03] | [4.96, 5.06] | [4.92, 5.09] | [4.86, 5.15]",
"Species [versicolor] | [0.90, 0.96] | [0.86, 1.00] | [0.81, 1.05] | [0.73, 1.13]",
"Species [virginica] | [1.55, 1.61] | [1.51, 1.65] | [1.46, 1.70] | [1.38, 1.79]"
)
)
})
parameters/tests/testthat/test-nestedLogit.R 0000644 0001762 0000144 00000005012 14433114017 020774 0 ustar ligges users skip_if_not_installed("nestedLogit")
skip_if_not_installed("broom")
skip_if_not_installed("car")
skip_if_not_installed("carData")
test_that("model_parameters.nestedLogit", {
data(Womenlf, package = "carData")
comparisons <- nestedLogit::logits(
work = nestedLogit::dichotomy("not.work", working = c("parttime", "fulltime")),
full = nestedLogit::dichotomy("parttime", "fulltime")
)
mnl1 <- nestedLogit::nestedLogit(
partic ~ hincome + children,
dichotomies = comparisons,
data = Womenlf
)
out <- model_parameters(mnl1)
expect_identical(
out$Parameter,
c(
"(Intercept)", "hincome", "childrenpresent", "(Intercept)",
"hincome", "childrenpresent"
)
)
expect_equal(
out$Coefficient,
unname(c(coef(mnl1)[, 1], coef(mnl1)[, 2])),
ignore_attr = TRUE,
tolerance = 1e-3
)
expect_equal(
out$SE,
unname(do.call(rbind, lapply(summary(mnl1), coef))[, "Std. Error"]),
ignore_attr = TRUE,
tolerance = 1e-3
)
expect_equal(
out$CI_low,
c(0.60591, -0.08226, -2.16144, 2.11087, -0.18921, -3.80274),
ignore_attr = TRUE,
tolerance = 1e-3
)
out <- model_parameters(mnl1, ci_method = "wald")
expect_equal(
out$CI_low,
c(0.58367, -0.08108, -2.14847, 1.97427, -0.184, -3.71194),
ignore_attr = TRUE,
tolerance = 1e-3
)
out <- model_parameters(mnl1, exponentiate = TRUE)
expect_equal(
out$Coefficient,
exp(unname(c(coef(mnl1)[, 1], coef(mnl1)[, 2]))),
ignore_attr = TRUE,
tolerance = 1e-3
)
out <- model_parameters(mnl1, vcov = "HC3")
expect_equal(
out$SE,
c(0.41738, 0.02256, 0.29565, 0.76467, 0.0373, 0.56165),
ignore_attr = TRUE,
tolerance = 1e-3
)
out <- model_parameters(mnl1, component = "work")
expect_identical(nrow(out), 3L)
})
test_that("simulate_parameters.nestedLogit", {
skip_if(getRversion() < "4.2.0")
skip_on_os(c("linux", "mac"))
data(Womenlf, package = "carData")
comparisons <- nestedLogit::logits(
work = nestedLogit::dichotomy("not.work", working = c("parttime", "fulltime")),
full = nestedLogit::dichotomy("parttime", "fulltime")
)
mnl1 <- nestedLogit::nestedLogit(
partic ~ hincome + children,
dichotomies = comparisons,
data = Womenlf
)
set.seed(123)
out <- simulate_parameters(mnl1, iterations = 100)
expect_equal(
out$Coefficient,
c(1.35612, -0.04667, -1.59096, 3.45594, -0.10316, -2.69807),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-glmer.R 0000644 0001762 0000144 00000005061 14736731407 017643 0 ustar ligges users skip_on_cran()
skip_if_not_installed("lme4")
data("cbpp", package = "lme4")
set.seed(123)
model <- lme4::glmer(
cbind(incidence, size - incidence) ~ period + (1 | herd),
data = cbpp,
family = binomial(),
nAGQ = 0
)
params <- model_parameters(model, effects = "fixed")
test_that("model_parameters.glmer", {
expect_equal(params$SE, c(0.22758, 0.30329, 0.32351, 0.42445), tolerance = 1e-2)
})
test_that("print model_parameters", {
skip_if_not_installed("withr")
skip_if_not_installed("merDeriv")
withr::local_options(
list(
parameters_exponentiate = TRUE,
parameters_warning_exponentiate = TRUE
)
)
expect_snapshot(params)
suppressMessages({
mp <- model_parameters(model, effects = "all", exponentiate = TRUE)
})
expect_snapshot(mp)
set.seed(123)
model <- lme4::glmer(
cbind(incidence, size - incidence) ~ period + (1 | herd),
data = cbpp,
family = binomial(),
nAGQ = 2
)
mp <- model_parameters(model, effects = "all")
expect_snapshot(mp)
})
test_that("model_parameters.glmer ml1", {
params <- model_parameters(model, ci_method = "ml1", effects = "fixed")
expect_equal(params$SE, c(0.22758, 0.30329, 0.32351, 0.42445), tolerance = 1e-2)
expect_equal(params$df, c(54, 54, 54, 54), tolerance = 1e-2)
})
test_that("model_parameters.glmer betwithin", {
params <- model_parameters(model, ci_method = "betwithin", effects = "fixed")
expect_equal(params$SE, c(0.23009, 0.30433, 0.32476, 0.42632), tolerance = 1e-2)
expect_equal(params$df, c(822, 822, 822, 822), tolerance = 1e-2)
})
set.seed(123)
cbpp$time <- runif(nrow(cbpp), 1, 4)
model <- lme4::glmer(
cbind(incidence, size - incidence) ~ period + time + (1 + time | herd),
data = cbpp,
family = binomial(),
nAGQ = 0
)
test_that("model_parameters.glmer", {
params <- model_parameters(model, effects = "fixed")
expect_equal(params$SE, c(0.66539, 0.36178, 0.36223, 0.45528, 0.2379), tolerance = 1e-2)
})
test_that("model_parameters.glmer ml1", {
params <- model_parameters(model, ci_method = "ml1", effects = "fixed")
expect_equal(params$SE, c(0.66539, 0.36178, 0.36223, 0.45528, 0.2379), tolerance = 1e-2)
expect_equal(params$df, c(53, 53, 53, 53, 53), tolerance = 1e-2)
})
test_that("model_parameters.glmer betwithin", {
params <- model_parameters(model, ci_method = "betwithin", effects = "fixed")
expect_equal(params$SE, c(0.66539, 0.36178, 0.36223, 0.45528, 0.2379), tolerance = 1e-2)
expect_equal(params$df, c(821, 821, 821, 821, 9), tolerance = 1e-2)
})
parameters/tests/testthat/test-model_parameters.glmgee.R 0000644 0001762 0000144 00000000761 14716604201 023306 0 ustar ligges users skip_on_cran()
skip_if_not_installed("glmtoolbox")
skip_if_not_installed("withr")
withr::with_options(
list(parameters_exponentiate = FALSE),
test_that("model_parameters.glmgee", {
data(spruces, package = "glmtoolbox")
fit1 <- glmtoolbox::glmgee(
size ~ poly(days, 4) + treat,
id = tree,
family = Gamma("log"),
corstr = "AR-M-dependent(1)",
data = spruces
)
out <- model_parameters(fit1)
expect_snapshot(print(out))
})
)
parameters/tests/testthat/test-mira.R 0000644 0001762 0000144 00000000752 14413515226 017456 0 ustar ligges users skip_if_not_installed("mice")
data("nhanes2", package = "mice")
imp <- mice::mice(nhanes2, printFlag = FALSE)
fit <- with(data = imp, exp = lm(bmi ~ age + hyp + chl))
mp1 <- model_parameters(fit)
mp2 <- summary(mice::pool(fit))
test_that("param", {
expect_equal(mp1$Parameter, as.vector(mp2$term))
})
test_that("coef", {
expect_equal(mp1$Coefficient, mp2$estimate, tolerance = 1e-3)
})
test_that("se", {
expect_equal(mp1$SE, mp2$std.error, tolerance = 1e-3)
})
parameters/tests/testthat/test-printing_reference_level.R 0000644 0001762 0000144 00000004106 14716604201 023560 0 ustar ligges users test_that("print in pipe", {
data(iris)
model <- lm(Sepal.Length ~ Petal.Length + Species, data = iris)
out <- model_parameters(model, include_reference = TRUE)
expect_identical(
out$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciessetosa", "Speciesversicolor",
"Speciesvirginica"
)
)
expect_equal(out$Coefficient, c(3.68353, 0.90456, 0, -1.60097, -2.11767), tolerance = 1e-4)
out <- model_parameters(model, include_reference = TRUE, pretty_names = FALSE)
expect_identical(
out$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciessetosa", "Speciesversicolor",
"Speciesvirginica"
)
)
expect_equal(out$Coefficient, c(3.68353, 0.90456, 0, -1.60097, -2.11767), tolerance = 1e-4)
})
# skip_if(getRversion() < "4.0.0")
# test_that("simple reference level", {
# data(PlantGrowth)
# d <<- PlantGrowth
# m <- lm(weight ~ group, data = d)
# mp <- model_parameters(m)
# expect_snapshot(print(mp, include_reference = TRUE))
# data(mtcars)
# d <<- mtcars
# d$cyl <- as.factor(d$cyl)
# d$am <- as.factor(d$am)
# m <- lm(mpg ~ hp + cyl + gear + am, data = d)
# mp <- model_parameters(m)
# expect_snapshot(print(mp, include_reference = TRUE))
# data(iris)
# d <<- iris
# m <- lm(Sepal.Length ~ Sepal.Width * Species, data = d)
# mp <- model_parameters(m)
# expect_snapshot(print(mp, include_reference = TRUE))
# data(mtcars)
# d <<- mtcars
# d$gear <- as.factor(d$gear)
# m <- glm(vs ~ wt + gear, data = d, family = "binomial")
# expect_snapshot(print(model_parameters(m, exponentiate = TRUE, drop = "(Intercept)"), include_reference = TRUE))
# })
# test_that("reference for models with multiple components", {
# skip_on_cran()
# skip_if_not_installed("glmmTMB")
# data("fish")
# m1 <- glmmTMB::glmmTMB(
# count ~ child + camper + zg + (1 | ID),
# ziformula = ~ child + camper + (1 | persons),
# data = fish,
# family = glmmTMB::truncated_poisson()
# )
# print(model_parameters(m1), include_reference = TRUE)
# })
parameters/tests/testthat/test-model_parameters.mle2.R 0000644 0001762 0000144 00000001073 14413515226 022704 0 ustar ligges users test_that("model_parameters.mle2", {
skip_if_not_installed("bbmle")
x <- 0:10
y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
d <- data.frame(x, y)
LL <- function(ymax = 15, xhalf = 6) {
-sum(stats::dpois(y, lambda = ymax / (1 + x / xhalf), log = TRUE))
}
model <- suppressWarnings(bbmle::mle2(LL))
params <- model_parameters(model)
expect_equal(params$SE, c(4.224444, 1.034797), tolerance = 1e-3)
expect_equal(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "z", "df_error", "p")
)
})
parameters/tests/testthat/test-model_parameters.BFBayesFactor.R 0000644 0001762 0000144 00000012501 14716604201 024453 0 ustar ligges users skip_on_os("linux")
test_that("model_parameters.BFBayesFactor", {
skip_on_cran()
skip("TODO")
skip_if_not_installed("BayesFactor")
model <- BayesFactor::ttestBF(iris$Sepal.Width, iris$Petal.Length, paired = TRUE)
expect_equal(model_parameters(model)$BF, c(492.770567186302, NA), tolerance = 1e-2)
})
# make sure BF is returned, even if NA
# see https://github.com/easystats/correlation/issues/269
test_that("model_parameters.BFBayesFactor", {
skip_if_not_installed("BayesFactor")
var_x <- c(
12.1, 8.7, 10.1, 17.4, 12.5, 2.7, 6.2, 19.4, 11, 14.5, 15.8,
10.4, 13.5, 3.5, 5.6, 5.2, 6.3, 12.5, 9.8
)
var_y <- c(
11.9, 15.3, 13.9, 6.6, 11.5, 21.35, 17.8, 4.6, 13, 9.5, 8.2,
13.6, 10.5, 20.5, 18.45, 18.8, 17.7, 11.5, 14.2
)
expect_warning({
model <- BayesFactor::correlationBF(var_x, var_y, rscale = "medium")
})
params <- model_parameters(model)
expect_identical(
colnames(params),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "Prior_Distribution",
"Prior_Location", "Prior_Scale", "BF", "Method"
)
)
expect_true(is.na(params$BF))
})
test_that("model_parameters.BFBayesFactor", {
skip_if_not_installed("BayesFactor")
model <- BayesFactor::correlationBF(iris$Sepal.Width, iris$Petal.Length)
expect_equal(model_parameters(model)$BF, 348853.6, tolerance = 10)
})
test_that("model_parameters.BFBayesFactor", {
skip_if_not_installed("BayesFactor")
set.seed(123)
model <- BayesFactor::anovaBF(Sepal.Length ~ Species, data = iris, progress = FALSE)
expect_equal(
model_parameters(model, centrality = "median")$Median,
c(5.8431, -0.8266, 0.092, 0.734, 0.2681, 2.0415),
tolerance = 2
)
})
# test_that("model_parameters.BFBayesFactor", {
# skip_on_cran()
# model <- BayesFactor::ttestBF(formula = mpg ~ am, data = df)
# expect_equal(model_parameters(model)$BF, c(86.58973, NA), tolerance = 1)
# })
test_that("model_parameters.BFBayesFactor", {
skip_if_not_installed("BayesFactor")
df <- mtcars
df$gear <- as.factor(df$gear)
df$am <- as.factor(df$am)
set.seed(123)
model <- suppressMessages(BayesFactor::anovaBF(mpg ~ gear * am, data = df, progress = FALSE))
expect_equal(
suppressMessages(model_parameters(model, centrality = "mean", verbose = FALSE))$Mean,
c(20.7099, -3.24884, 3.24884, 26.51413, 5.30506, NA, NA, NA),
tolerance = 1L
)
})
test_that("model_parameters.BFBayesFactor", {
skip_on_cran()
skip_if_not_installed("BayesFactor")
data(raceDolls, package = "BayesFactor")
bf <- BayesFactor::contingencyTableBF(raceDolls, sampleType = "indepMulti", fixedMargin = "cols")
mp <- suppressWarnings(model_parameters(bf,
centrality = "mean",
dispersion = TRUE,
verbose = FALSE,
es_type = "cramers_v",
adjust = TRUE,
include_proportions = TRUE
))
mp2 <- suppressWarnings(model_parameters(bf, verbose = FALSE))
expect_identical(
colnames(mp),
c(
"Parameter", "Mean", "CI", "CI_low", "CI_high", "SD", "Cramers_v_adjusted",
"pd", "Prior_Distribution", "Prior_Location",
"Prior_Scale", "BF", "Method"
)
)
expect_identical(dim(mp), c(6L, 13L))
expect_identical(
colnames(mp2),
c(
"Parameter", "Prior_Distribution", "Prior_Location", "Prior_Scale",
"BF", "Method", "CI"
)
)
expect_identical(dim(mp2), c(1L, 7L))
})
test_that("model_parameters.BFBayesFactor", {
skip_on_cran()
skip_if_not_installed("BayesFactor")
data(puzzles, package = "BayesFactor")
result <- BayesFactor::anovaBF(RT ~ shape * color + ID,
data = puzzles, whichRandom = "ID",
whichModels = "top", progress = FALSE
)
mp <- suppressMessages(model_parameters(
result,
centrality = "median",
dispersion = TRUE,
verbose = FALSE
))
expect_identical(colnames(mp), c(
"Parameter", "Median", "MAD", "CI", "CI_low", "CI_high", "pd",
"Prior_Distribution", "Prior_Location", "Prior_Scale", "Effects",
"Component", "BF", "Method"
))
expect_identical(mp$Effects, c(
"fixed", "fixed", "fixed", "fixed", "fixed", "random", "random",
"random", "random", "random", "random", "random", "random", "random",
"random", "random", "random", "fixed", "fixed", "fixed", "fixed"
))
})
# one-sample t-test
test_that("model_parameters.BFBayesFactor, without effectsize", {
skip_if_not_installed("BayesFactor")
set.seed(123)
df_t <- as.data.frame(parameters(BayesFactor::ttestBF(mtcars$wt, mu = 3)))
expect_identical(
colnames(df_t),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "pd",
"Prior_Distribution", "Prior_Location", "Prior_Scale", "BF",
"Method"
)
)
expect_identical(dim(df_t), c(1L, 11L))
})
test_that("model_parameters.BFBayesFactor, with effectsize", {
skip_if_not_installed("BayesFactor")
set.seed(123)
df_t_es <- as.data.frame(
parameters(BayesFactor::ttestBF(mtcars$wt, mu = 3), es_type = "cohens_d")
)
# TODO: fix column order
expect_identical(
colnames(df_t_es),
c(
"Parameter", "Median", "CI", "CI_low", "CI_high", "Cohens_d",
"d_CI_low", "d_CI_high", "pd", "Prior_Distribution", "Prior_Location",
"Prior_Scale", "BF", "Method"
)
)
expect_identical(dim(df_t_es), c(1L, 14L))
})
parameters/tests/testthat/test-model_parameters_mixed_coeforder.R 0000644 0001762 0000144 00000001026 14413515226 025262 0 ustar ligges users test_that("model_parameters.mixed.coeforder", {
skip_if_not_installed("lme4")
set.seed(1)
dat <- data.frame(
TST.diff = runif(100, 0, 100),
Exposition = as.factor(sample(0:2, 100, TRUE)),
Gruppe = as.factor(sample(0:1, 100, TRUE)),
Kennung = as.factor(sample(1:5, 100, TRUE))
)
m <- lme4::lmer(TST.diff ~ Exposition + Gruppe + Gruppe:Exposition + (1 | Kennung), data = dat)
cs <- coef(summary(m))
mp <- model_parameters(m, effects = "fixed")
expect_equal(mp$Parameter, rownames(cs))
})
parameters/tests/testthat/test-model_parameters.aov_es_ci.R 0000644 0001762 0000144 00000032554 14716604201 024002 0 ustar ligges users iris$Cat1 <- rep_len(c("X", "X", "Y"), nrow(iris))
iris$Cat2 <- rep_len(c("A", "B"), nrow(iris))
# aov ----------------------------------
test_that("model_parameters.aov", {
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
model <- aov(Sepal.Width ~ Species, data = iris)
mp <- suppressMessages(model_parameters(
model,
es_type = c("omega", "eta", "epsilon"),
ci = 0.9,
alternative = "greater"
))
es <- suppressMessages(effectsize::omega_squared(model, partial = TRUE, ci = 0.9))
expect_equal(na.omit(mp$Omega2_CI_low), es$CI_low, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(mp$Omega2_CI_low, c(0.3122, NA), tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), es$CI_high, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), 1, tolerance = 1e-3, ignore_attr = TRUE)
expect_identical(colnames(mp), c(
"Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Omega2", "Omega2_CI_low", "Omega2_CI_high", "Eta2",
"Eta2_CI_low", "Eta2_CI_high", "Epsilon2", "Epsilon2_CI_low",
"Epsilon2_CI_high"
))
model <- aov(Sepal.Length ~ Species * Cat1 * Cat2, data = iris)
mp <- model_parameters(model, es_type = "eta", ci = 0.9, partial = FALSE, alternative = "greater")
es <- effectsize::eta_squared(model, partial = FALSE, ci = 0.9)
expect_equal(na.omit(mp$Eta2_CI_low), es$CI_low, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(mp$Eta2_CI_low, c(0.5572, 0, 0, 0, 0, 0, 0, NA), tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Eta2_CI_high), es$CI_high, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Eta2_CI_high), rep(1, 7), tolerance = 1e-3, ignore_attr = TRUE)
expect_identical(
colnames(mp),
c(
"Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Eta2", "Eta2_CI_low", "Eta2_CI_high"
)
)
})
# anova ---------------------
test_that("model_parameters.anova", {
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
model <- anova(lm(Sepal.Length ~ Species * Cat1 * Cat2, data = iris))
mp <- model_parameters(
model,
es_type = c("omega", "eta", "epsilon"),
partial = TRUE,
ci = 0.9,
alternative = "greater"
)
es <- effectsize::omega_squared(model, partial = TRUE, ci = 0.9)
expect_equal(na.omit(mp$Omega2_CI_low), es$CI_low, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), es$CI_high, tolerance = 1e-3, ignore_attr = TRUE)
expect_identical(colnames(mp), c(
"Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Omega2_partial", "Omega2_CI_low", "Omega2_CI_high", "Eta2_partial",
"Eta2_CI_low", "Eta2_CI_high", "Epsilon2_partial", "Epsilon2_CI_low",
"Epsilon2_CI_high"
))
})
test_that("model_parameters.anova", {
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
model <- aov(wt ~ cyl + Error(gear), data = mtcars)
suppressWarnings({
mp <- model_parameters(model, es_type = c("omega", "eta", "epsilon"), partial = TRUE, ci = 0.9)
es <- effectsize::omega_squared(model, partial = TRUE, ci = 0.9, verbose = FALSE)
})
expect_equal(na.omit(mp$Omega2_CI_low), es$CI_low[2], tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), es$CI_high, tolerance = 1e-3, ignore_attr = TRUE)
expect_identical(colnames(mp), c(
"Group", "Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Omega2_partial", "Omega2_CI_low", "Omega2_CI_high", "Eta2_partial",
"Eta2_CI_low", "Eta2_CI_high", "Epsilon2_partial", "Epsilon2_CI_low",
"Epsilon2_CI_high"
))
})
# car anova ---------------------------------
test_that("model_parameters.car-anova", {
skip_if_not_installed("car")
skip_if_not_installed("carData")
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
data(Moore, package = "carData")
set.seed(123)
model <-
car::Anova(stats::lm(
formula = conformity ~ fcategory * partner.status,
data = Moore,
contrasts = list(fcategory = contr.sum, partner.status = contr.sum)
))
mp <- model_parameters(model, es_type = c("omega", "eta", "epsilon"), partial = TRUE, ci = 0.9)
es <- effectsize::omega_squared(model, partial = TRUE, ci = 0.9)
expect_equal(na.omit(mp$Omega2_CI_low), es$CI_low, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(mp$Omega2_CI_low, c(0, 0.05110, 0.00666, NA), tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), es$CI_high, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), rep(1, 3), tolerance = 1e-3, ignore_attr = TRUE)
expect_identical(colnames(mp), c(
"Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Omega2_partial", "Omega2_CI_low", "Omega2_CI_high", "Eta2_partial",
"Eta2_CI_low", "Eta2_CI_high", "Epsilon2_partial", "Epsilon2_CI_low",
"Epsilon2_CI_high"
))
})
# maov ----------------------------------
test_that("model_parameters.maov", {
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
set.seed(123)
fit <- lm(cbind(mpg, disp, hp) ~ factor(cyl), data = mtcars)
model <- aov(fit)
mp <- suppressMessages(model_parameters(
model,
es_type = c("omega", "eta", "epsilon"),
partial = TRUE,
ci = 0.9
))
es <- suppressMessages(effectsize::omega_squared(model, partial = TRUE, ci = 0.9))
expect_equal(na.omit(mp$Omega2_CI_low), es$CI_low, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(mp$Omega2_CI_low, c(0.58067, NA, 0.74092, NA, 0.55331, NA), tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), es$CI_high, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(na.omit(mp$Omega2_CI_high), rep(1, 3), tolerance = 1e-3, ignore_attr = TRUE)
expect_identical(colnames(mp), c(
"Response", "Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p",
"Omega2", "Omega2_CI_low", "Omega2_CI_high", "Eta2",
"Eta2_CI_low", "Eta2_CI_high", "Epsilon2", "Epsilon2_CI_low",
"Epsilon2_CI_high"
))
})
# stricter tests ---------------------------------------------------------
test_that("works with aov", {
skip_on_cran()
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
set.seed(123)
npk.aov <- aov(yield ~ block + N * P, npk)
set.seed(123)
df_aov <-
as.data.frame(parameters::model_parameters(npk.aov,
ci = 0.95,
es_type = c("eta", "omega"),
partial = FALSE
))
expect_equal(
df_aov,
structure(
list(
Parameter = c("block", "N", "P", "N:P", "Residuals"),
Sum_Squares = c(343.295, 189.28167, 8.40167, 21.28167, 314.105),
df = c(5, 1, 1, 1, 15),
Mean_Square = c(68.659, 189.28167, 8.40167, 21.28167, 20.94033),
F = c(3.27879, 9.0391, 0.40122, 1.0163, NA),
p = c(0.03371, 0.00885, 0.536, 0.32938, NA),
Eta2 = c(0.39173, 0.21598, 0.00959, 0.02428, NA),
Eta2_CI_low = c(0, 0, 0, 0, NA),
Eta2_CI_high = c(1, 1, 1, 1, NA),
Omega2 = c(0.2659, 0.18761, -0.01397, 0.00038, NA),
Omega2_CI_low = c(0, 0, 0, 0, NA),
Omega2_CI_high = c(1, 1, 1, 1, NA)
),
row.names = c(NA, 5L), ci = 0.95, model_class = c("aov", "lm"),
anova_type = 1, title = "", digits = 2, ci_digits = 2, p_digits = 3,
object_name = "npk.aov", class = "data.frame"
),
tolerance = 0.1,
ignore_attr = TRUE
)
})
# aovlist ------------------------------------------------
# test_that("works with aovlist", {
# skip_on_cran()
#
# set.seed(123)
# npk.aovE <- aov(yield ~ N * P * K + Error(block), npk)
#
# set.seed(123)
# df_aovE <-
# as.data.frame(model_parameters(npk.aovE,
# ci = 0.90,
# eta_squared = "raw",
# omega_squared = "partial"
# ))
#
# expect_equal(
# df_aovE,
# structure(
# list(
# Group = c(
# "block",
# "block",
# "Within",
# "Within",
# "Within",
# "Within",
# "Within",
# "Within",
# "Within"
# ),
# Parameter = c(
# "N:P:K",
# "Residuals",
# "N",
# "P",
# "K",
# "N:P",
# "N:K",
# "P:K",
# "Residuals"
# ),
# Sum_Squares = c(37, 306.29, 189.28, 8.4, 95.2, 21.28, 33.14, 0.48, 185.29),
# df = c(1, 4, 1, 1, 1, 1, 1, 1, 12),
# Mean_Square = c(37, 76.57, 189.28, 8.4, 95.2, 21.28, 33.14, 0.48, 15.44),
# `F` = c(0.48, NA, 12.26, 0.54, 6.17, 1.38, 2.15, 0.03, NA),
# p = c(0.53, NA, 0, 0.47, 0.03, 0.26, 0.17, 0.86, NA),
# Omega2_partial = c(-0.09, NA, 0.23, -0.01, 0.12, 0.01, 0.03, -0.03, NA),
# Omega2_CI_low = c(0, NA, 0, 0, 0, 0, 0, 0, NA),
# Omega2_CI_high = c(0, NA, 0.52, 0, 0.42, 0.22, 0.29, 0, NA),
# Eta2 = c(0.04, NA, 0.22, 0.01, 0.11, 0.02, 0.04, 0, NA),
# Eta2_CI_low = c(0, NA, 0, 0, 0, 0, 0, 0, NA),
# Eta2_CI_high = c(0.49, NA, 0.51, 0.23, 0.41, 0.28, 0.31, 0.04, NA)
# ),
# row.names = c(NA, 9L),
# class = "data.frame",
# ci = 0.9,
# model_class = c("aovlist", "listof"),
# digits = 2,
# ci_digits = 2,
# p_digits = 3
# ),
# tolerance = 0.1,
# ignore_attr = TRUE
# )
# })
# manova ------------------------------------------------
test_that("works with manova", {
skip_on_cran()
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
set.seed(123)
# fake a 2nd response variable
foo <- rnorm(24)
npk2 <- within(npk, foo)
# model
m <- manova(cbind(yield, foo) ~ block + N * P * K, npk2)
set.seed(123)
df_manova <-
as.data.frame(model_parameters(m,
ci = 0.99,
es_type = c("epsilon", "omega"),
partial = TRUE
))
expect_identical(
df_manova$Parameter, c("block", "N", "P", "K", "N:P", "N:K", "P:K", "Residuals")
)
expect_identical(
colnames(df_manova),
c(
"Parameter", "Statistic", "df", "df_num", "df_error", "F", "p",
"Epsilon2_partial", "Epsilon2_CI_low", "Epsilon2_CI_high",
"Omega2_partial", "Omega2_CI_low", "Omega2_CI_high"
)
)
expect_equal(
df_manova$Statistic,
c(0.88, 0.61, 0.07, 0.39, 0.11, 0.17, 0, NA),
tolerance = 0.1
)
expect_equal(
df_manova$Omega2_CI_low,
c(0, 0, 0, 0, 0, 0, 0, NA),
tolerance = 0.1
)
expect_equal(
df_manova$Omega2_partial,
c(0.204, 0.518, 0, 0.262, 0, 0.022, 0, NA),
tolerance = 0.1
)
})
# Gam ------------------------------------------------
test_that("works with Gam", {
skip_on_cran()
skip_if_not_installed("gam")
skip_if_not_installed("effectsize", minimum_version = "0.5.1")
# setup
set.seed(123)
# model
set.seed(123)
g <- gam::gam(
formula = mpg ~ gam::s(hp, 4) + am + qsec,
data = mtcars
)
set.seed(123)
df_Gam <-
as.data.frame(model_parameters(g,
ci = 0.50,
es_type = "omega",
partial = TRUE
))
expect_equal(
df_Gam,
structure(
list(
Parameter = c("gam::s(hp, 4)", "am", "qsec", "Residuals"),
Sum_Squares = c(678.37287, 202.23503, 6.87905, 238.56023),
df = c(1, 1, 1, 28),
Mean_Square = c(678.37287, 202.23503, 6.87905, 8.52001),
`F` = c(79.62115, 23.73648, 0.8074, NA), # nolint
p = c(0, 4e-05, 0.37655, NA),
Omega2_partial = c(0.71072, 0.41538, -0.00606, NA),
Omega2_CI_low = c(0.70634, 0.41067, 0, NA),
Omega2_CI_high = c(1, 1, 1, NA)
),
row.names = c(NA, 4L),
class = "data.frame",
ci = 0.5,
model_class = c("anova", "data.frame"),
digits = 2,
ci_digits = 2,
p_digits = 3
),
tolerance = 0.1,
ignore_attr = TRUE
)
})
# anova ------------------------------------------------
test_that("works with anova", {
skip_on_cran()
skip_if_not_installed("car")
skip_if_not_installed("effectsize", minimum_version = "0.7.1")
set.seed(123)
mod <-
car::Anova(stats::lm(
formula = conformity ~ fcategory * partner.status,
data = Moore,
contrasts = list(fcategory = contr.sum, partner.status = contr.sum)
))
set.seed(123)
df_car <-
as.data.frame(model_parameters(mod,
ci = 0.89,
es_type = c("eta", "epsilon"),
partial = FALSE
))
expect_equal(
df_car,
structure(
list(
Parameter = c(
"fcategory",
"partner.status",
"fcategory:partner.status",
"Residuals"
),
Sum_Squares = c(11.61, 212.21, 175.49, 817.76),
df = c(2, 1, 2, 39),
Mean_Square = c(5.81, 212.21, 87.74, 20.97),
F = c(0.28, 10.12, 4.18, NA),
p = c(0.76, 0, 0.02, NA),
Eta2 = c(0.01, 0.17, 0.14, NA),
Eta2_CI_low = c(0, 0.03, 0, NA),
Eta2_CI_high = c(1, 1, 1, NA),
Epsilon2 = c(-0.02, 0.16, 0.11, NA),
Epsilon2_CI_low = c(0, 0.03, 0, NA),
Epsilon2_CI_high = c(1, 1, 1, NA)
),
row.names = c(NA, 4L),
class = "data.frame",
ci = 0.89,
model_class = c("anova", "data.frame"),
digits = 2,
ci_digits = 2,
p_digits = 3
),
tolerance = 0.1,
ignore_attr = TRUE
)
})
parameters/tests/testthat/test-efa.R 0000644 0001762 0000144 00000000746 14413515226 017264 0 ustar ligges users skip_on_cran()
test_that("predict.parameters_efa works with verbose", {
skip_if_not_installed("psych")
d <- psych::bfi[, 1:25]
d <- na.omit(d)
efa <- psych::fa(d, nfactors = 5)
out <- model_parameters(efa, sort = TRUE, threshold = "max")
predictions <- predict(
out,
names = c("Neuroticism", "Conscientiousness", "Extraversion", "Agreeableness", "Opennness"),
verbose = FALSE
)
expect_identical(dim(predictions), as.integer(c(2436, 5)))
})
parameters/tests/testthat/test-quantreg.R 0000644 0001762 0000144 00000005157 14736731407 020371 0 ustar ligges users skip_on_cran()
skip_if(getRversion() < "4.2.0")
# rqss ---------
# data("CobarOre")
# set.seed(123)
# CobarOre$w <- rnorm(nrow(CobarOre))
# m1 <- rqss(z ~ w + qss(cbind(x, y), lambda = .08), data = CobarOre)
# mp <- suppressWarnings(model_parameters(m1))
# test_that("mp_rqss", {
# expect_identical(mp$Parameter, c("(Intercept)", "w", "cbind(x, y)"))
# expect_equal(mp$Coefficient, c(17.63057, 1.12506, NA), tolerance = 1e-3)
# expect_equal(mp$df_error, c(15, 15, NA), tolerance = 1e-3)
# expect_equal(mp[["df"]], c(NA, NA, 70), tolerance = 1e-3)
# })
# rq ---------
test_that("mp_rq", {
skip_if_not_installed("quantreg")
data(stackloss)
m1 <- quantreg::rq(stack.loss ~ Air.Flow + Water.Temp, data = stackloss, tau = 0.25)
mp <- suppressWarnings(model_parameters(m1))
expect_identical(mp$Parameter, c("(Intercept)", "Air.Flow", "Water.Temp"))
expect_equal(mp$Coefficient, c(-36, 0.5, 1), tolerance = 1e-3)
})
# rqs ---------
test_that("mp_rqs", {
skip_if_not_installed("quantreg")
set.seed(123)
data("engel", package = "quantreg")
m1 <- quantreg::rq(foodexp ~ income, data = engel, tau = 1:9 / 10)
mp <- suppressWarnings(model_parameters(m1))
expect_identical(mp$Parameter, c(
"(Intercept)", "income", "(Intercept)", "income", "(Intercept)",
"income", "(Intercept)", "income", "(Intercept)", "income", "(Intercept)",
"income", "(Intercept)", "income", "(Intercept)", "income", "(Intercept)",
"income"
))
expect_equal(mp$Coefficient, c(
110.14157, 0.40177, 102.31388, 0.4469, 99.11058, 0.48124, 101.95988,
0.5099, 81.48225, 0.56018, 79.70227, 0.58585, 79.28362, 0.60885,
58.00666, 0.65951, 67.35087, 0.6863
), tolerance = 1e-3)
expect_equal(mp$SE, c(
29.39768, 0.04024, 21.42836, 0.02997, 22.18115, 0.02987, 22.06032,
0.02936, 19.25066, 0.02828, 17.61762, 0.02506, 14.25039, 0.02176,
19.21719, 0.02635, 22.39538, 0.02849
), tolerance = 1e-3)
})
# crq ---------
test_that("mp_rq", {
skip_if_not_installed("quantreg")
skip_if_not_installed("survival")
set.seed(123)
n <- 200
x <- rnorm(n)
y <- 5 + x + rnorm(n)
c <- 4 + x + rnorm(n)
d <- (y > c)
dat <- data.frame(y, x, c, d)
m1 <- quantreg::crq(survival::Surv(pmax(y, c), d, type = "left") ~ x, method = "Portnoy", data = dat)
mp <- model_parameters(m1)
expect_identical(
mp$Parameter,
c("(Intercept)", "x", "(Intercept)", "x", "(Intercept)", "x", "(Intercept)", "x")
)
expect_equal(
mp$Coefficient,
c(4.26724, 0.97534, 4.84961, 0.92638, 5.21843, 0.98038, 5.91301, 0.97382),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-include_reference.R 0000644 0001762 0000144 00000006072 14716604201 022166 0 ustar ligges users skip_if_not_installed("tinytable")
test_that("include_reference, on-the-fly factors", {
data(mtcars)
d <- as.data.frame(mtcars)
d$gear <- as.factor(d$gear)
d$am <- as.factor(d$am)
m1 <- lm(mpg ~ as.factor(gear) + factor(am) + hp, data = mtcars)
m2 <- lm(mpg ~ gear + am + hp, data = d)
out1 <- model_parameters(m1, include_reference = TRUE)
out2 <- model_parameters(m2, include_reference = TRUE)
expect_snapshot(print(out1))
expect_snapshot(print(out2))
expect_equal(attributes(out1)$pretty_names, attributes(out2)$pretty_names, ignore_attr = TRUE)
expect_equal(out1$Coefficient, out2$Coefficient, tolerance = 1e-4)
out <- compare_parameters(m1, m2, include_reference = TRUE)
expect_snapshot(print_md(out, engine = "tt"))
})
skip_if(getRversion() < "4.3.3")
skip_if_not_installed("datawizard")
test_that("include_reference, on-the-fly factors", {
data(mtcars)
d <- as.data.frame(mtcars)
d$gear <- as.factor(d$gear)
d$am <- as.factor(d$am)
m1 <- lm(mpg ~ as.factor(gear) + factor(am) + hp, data = mtcars)
m2 <- lm(mpg ~ gear + am + hp, data = d)
out1 <- model_parameters(m1, include_reference = TRUE)
out3 <- mtcars |>
datawizard::data_modify(gear = factor(gear), am = as.factor(am)) |>
lm(formula = mpg ~ gear + am + hp) |>
model_parameters(include_reference = TRUE)
expect_equal(attributes(out1)$pretty_names, attributes(out3)$pretty_names, ignore_attr = TRUE)
})
test_that("include_reference, with pretty formatted cut", {
data(mtcars)
mtcars$mpg_cut <- cut(mtcars$mpg, breaks = c(0, 20, 30, 100))
m <- lm(wt ~ mpg_cut, data = mtcars)
out <- parameters(m, include_reference = TRUE)
expect_identical(
attributes(out)$pretty_names,
c(
`(Intercept)` = "(Intercept)", `mpg_cut(0,20]` = "mpg cut [>0-20]",
`mpg_cut(20,30]` = "mpg cut [>20-30]", `mpg_cut(30,100]` = "mpg cut [>30-100]"
)
)
})
test_that("include_reference, different contrasts", {
data("mtcars")
mtcars$cyl <- factor(mtcars$cyl)
mtcars$gear <- factor(mtcars$gear)
m <- lm(mpg ~ cyl + gear, data = mtcars, contrasts = list(cyl = datawizard::contr.deviation))
out <- model_parameters(m, include_reference = TRUE)
expect_snapshot(print(out))
m <- lm(mpg ~ cyl + gear, data = mtcars)
out <- model_parameters(m, include_reference = TRUE)
expect_snapshot(print(out))
m <- lm(
mpg ~ cyl + gear,
data = mtcars,
contrasts = list(
cyl = datawizard::contr.deviation,
gear = contr.sum
)
)
out <- model_parameters(m, include_reference = TRUE)
expect_snapshot(print(out))
m <- lm(
mpg ~ cyl + gear,
data = mtcars,
contrasts = list(
cyl = contr.SAS,
gear = contr.sum
)
)
out <- model_parameters(m, include_reference = TRUE)
expect_snapshot(print(out))
m <- lm(
mpg ~ cyl + gear,
data = mtcars,
contrasts = list(
cyl = contr.SAS,
gear = contr.treatment
)
)
out <- model_parameters(m, include_reference = TRUE)
expect_snapshot(print(out))
})
parameters/tests/testthat/test-betareg.R 0000644 0001762 0000144 00000003533 14413515226 020137 0 ustar ligges users skip_if_not_installed("betareg")
data("GasolineYield", package = "betareg")
data("FoodExpenditure", package = "betareg")
m1 <- betareg::betareg(yield ~ batch + temp, data = GasolineYield)
m2 <- betareg::betareg(I(food / income) ~ income + persons, data = FoodExpenditure)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
as.vector(confint(m1)[, 1]),
tolerance = 1e-4
)
expect_equal(
ci(m2)$CI_low,
as.vector(confint(m2)[, 1]),
tolerance = 1e-4
)
})
test_that("se", {
s <- summary(m1)
expect_equal(
standard_error(m1)$SE,
as.vector(c(s$coefficients$mean[, 2], s$coefficients$precision[, 2])),
tolerance = 1e-4
)
s <- summary(m2)
expect_equal(
standard_error(m2)$SE,
as.vector(c(s$coefficients$mean[, 2], s$coefficients$precision[, 2])),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 0, 0, 0, 0, 0, 0, 0, 1e-05, 0.00114, 0, 6e-05),
tolerance = 1e-3
)
expect_equal(
p_value(m2)$p,
c(0.00542, 5e-05, 8e-04, 1e-05),
tolerance = 1e-3
)
})
# check vcov args
test_that("model_parameters", {
expect_message({
out <- model_parameters(m1, vcov = "vcovHAC")
})
expect_equal(out$SE, unname(coef(summary(m1))[[1]][, 2]), tolerance = 1e-3)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
as.vector(coef(m1))[1:11],
tolerance = 1e-4
)
expect_equal(
model_parameters(m1, component = "all")$Coefficient,
as.vector(coef(m1)),
tolerance = 1e-4
)
expect_equal(
model_parameters(m2)$Coefficient,
c(-0.62255, -0.0123, 0.11846),
tolerance = 1e-4
)
expect_equal(
model_parameters(m2, component = "all")$Coefficient,
c(-0.62255, -0.0123, 0.11846, 35.60975033),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-group_level_total.R 0000644 0001762 0000144 00000004366 14761570351 022267 0 ustar ligges users skip_on_os("mac")
skip_on_cran()
skip_if_not_installed("glmmTMB")
skip_if_not_installed("lme4")
test_that("group_level_total", {
data("fish", package = "insight")
m1 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 | ID),
data = fish,
family = poisson()
))
m2 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 + xb | persons) + (1 + zg | ID),
ziformula = ~ child + livebait + (1 + zg + nofish | ID),
dispformula = ~xb,
data = fish,
family = glmmTMB::truncated_poisson()
))
m3 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper,
ziformula = ~ child + livebait + (1 | ID),
data = fish,
family = glmmTMB::truncated_poisson()
))
m4 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 + xb | persons),
ziformula = ~ child + livebait,
dispformula = ~xb,
data = fish,
family = glmmTMB::truncated_poisson()
))
m5 <- suppressWarnings(lme4::glmer(
count ~ child + camper + (1 | ID),
data = fish,
family = poisson()
))
m6 <- suppressWarnings(lme4::lmer(
Reaction ~ Days + (1 + Days | Subject),
data = lme4::sleepstudy
))
out <- model_parameters(m1, effects = "total")
expect_identical(dim(out), c(4L, 6L))
out <- model_parameters(m2, effects = "total")
expect_identical(dim(out), c(28L, 6L))
out <- model_parameters(m3, effects = "total")
expect_identical(dim(out), c(4L, 6L))
out <- model_parameters(m4, effects = "total")
expect_identical(dim(out), c(8L, 6L))
out <- model_parameters(m5, effects = "total")
expect_identical(dim(out), c(4L, 5L))
out <- model_parameters(m6, effects = "total")
expect_identical(dim(out), c(36L, 5L))
})
test_that("group_level_total, brms", {
skip_if_not_installed("curl")
skip_if_offline()
skip_if_not_installed("httr2")
skip_if_not_installed("brms")
m1 <- insight::download_model("brms_zi_4")
m2 <- insight::download_model("brms_sigma_3")
skip_if(is.null(m1) || is.null(m2))
out <- model_parameters(m1, effects = "total")
expect_identical(dim(out), c(28L, 10L))
out <- model_parameters(m2, effects = "total")
expect_identical(dim(out), c(12L, 10L))
})
parameters/tests/testthat/test-ci.R 0000644 0001762 0000144 00000003727 14413515226 017126 0 ustar ligges users test_that("ci", {
skip_if_not_installed("lme4")
model <- lm(mpg ~ wt, data = mtcars)
expect_equal(suppressMessages(ci(model))[1, 3], 33.4505, tolerance = 0.01)
expect_equal(suppressMessages(ci(model, ci = c(0.7, 0.8)))[1, 3], 35.30486, tolerance = 0.01)
model <- glm(vs ~ wt, family = "binomial", data = mtcars)
expect_equal(suppressMessages(ci(model))[1, 3], 1.934013, tolerance = 0.01)
model <- lme4::lmer(wt ~ cyl + (1 | gear), data = mtcars)
expect_equal(suppressMessages(ci(model, method = "normal"))[1, 3], -0.335063, tolerance = 0.01)
model <- lme4::lmer(wt ~ cyl + (1 | gear), data = mtcars)
expect_equal(ci(model)[1, 3], -0.3795646, tolerance = 0.01)
set.seed(1)
val <- ci(model, method = "boot")[1, 3]
expect_equal(val, -0.555424, tolerance = 0.01)
model <- lme4::glmer(vs ~ cyl + (1 | gear), data = mtcars, family = "binomial")
expect_equal(ci(model)[1, 3], -0.7876679, tolerance = 0.01)
model <- lme4::glmer(vs ~ drat + cyl + (1 | gear), data = mtcars, family = "binomial")
expect_equal(ci(model)[1, 3], -48.14195, tolerance = 0.01)
})
test_that("vs. sandwich & lmtest", {
skip_if_not_installed("sandwich")
skip_if_not_installed("lmtest")
model <- lm(mpg ~ wt, data = mtcars)
known <- lmtest::coefci(model, vcov = sandwich::vcovHC)
unknown <- ci(model, vcov = sandwich::vcovHC)
expect_equal(unknown[["CI_low"]], known[, "2.5 %"], ignore_attr = TRUE)
expect_equal(unknown[["CI_high"]], known[, "97.5 %"], ignore_attr = TRUE)
model <- glm(am ~ wt, data = mtcars, family = binomial)
known <- lmtest::coefci(model, vcov = sandwich::vcovHC)
unknown <- ci(model, vcov = sandwich::vcovHC, method = "wald")
expect_equal(unknown[["CI_low"]], known[, "2.5 %"], ignore_attr = TRUE)
expect_equal(unknown[["CI_high"]], known[, "97.5 %"], ignore_attr = TRUE)
suppressMessages(
expect_message(ci(model, vcov = sandwich::vcovHC), regexp = "vcov.*are not available with.*profile")
)
})
parameters/tests/testthat/test-model_parameters.lme.R 0000644 0001762 0000144 00000001717 14413515226 022627 0 ustar ligges users skip_if_not_installed("nlme")
skip_if_not_installed("lme4")
data("sleepstudy", package = "lme4")
model <- nlme::lme(Reaction ~ Days,
random = ~ 1 + Days | Subject,
data = sleepstudy
)
test_that("model_parameters.lme", {
params <- model_parameters(model, effects = "fixed")
expect_equal(params$SE, c(6.8245, 1.5458), tolerance = 1e-3)
expect_equal(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Effects")
)
})
test_that("model_parameters.lme", {
params <- model_parameters(model, effects = "all")
expect_equal(params$Coefficient, c(251.4051, 10.46729, 24.74024, 5.9221, 0.066, 25.59184), tolerance = 1e-3)
expect_equal(params$SE, c(6.82452, 1.54578, NA, NA, NA, NA), tolerance = 1e-3)
expect_equal(
colnames(params),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t",
"df_error", "p", "Effects", "Group"
)
)
})
parameters/tests/testthat/test-pretty_names.R 0000644 0001762 0000144 00000004137 14717111737 021247 0 ustar ligges users test_that("pretty_names", {
data(mtcars)
attr(mtcars$hp, "label") <- "Gross horsepower"
mod <- lm(mpg ~ hp + factor(cyl), mtcars)
p <- parameters::parameters(mod, pretty_names = "labels", include_reference = TRUE)
expect_identical(
attr(p, "pretty_labels"),
c(
`(Intercept)` = "(Intercept)", hp = "Gross horsepower", `factor(cyl)4` = "cyl [4]",
`factor(cyl)6` = "cyl [6]", `factor(cyl)8` = "cyl [8]"
)
)
p <- parameters::parameters(mod, pretty_names = "labels")
expect_identical(
attr(p, "pretty_labels"),
c(
`(Intercept)` = "(Intercept)", hp = "Gross horsepower", `factor(cyl)6` = "cyl [6]",
`factor(cyl)8` = "cyl [8]"
)
)
mtcars2 <- transform(mtcars, cyl = as.factor(cyl))
attr(mtcars2$cyl, "label") <- "Cylinders"
model <- lm(mpg ~ wt + cyl, data = mtcars2)
p <- model_parameters(model, pretty_names = "labels", include_reference = TRUE)
expect_identical(
attr(p, "pretty_labels"),
c(
`(Intercept)` = "(Intercept)", wt = "wt", cyl4 = "Cylinders [4]",
cyl6 = "Cylinders [6]", cyl8 = "Cylinders [8]"
)
)
})
skip_if_not_installed("withr")
# make sure we have the correct interaction mark for tests
withr::with_options(
list(parameters_interaction = "*", parameters_warning_exponentiate = TRUE),
test_that("pretty_labels", {
set.seed(1024)
N <- 5000
X <- rbinom(N, 1, 0.5)
M <- sample(c("a", "b", "c"), N, replace = TRUE)
b <- runif(8, -1, 1)
Y <- rbinom(N, 1, prob = plogis(
b[1] + b[2] * X +
b[3] * (M == "b") + b[4] * (M == "b") + b[5] * (M == "c") +
b[6] * X * (M == "a") + b[7] * X + (M == "b") +
b[8] * X * (M == "c")
))
dat <- data.frame(Y, X, M, stringsAsFactors = FALSE)
mod <- glm(Y ~ X * M, data = dat, family = binomial)
p <- parameters(mod)
expect_identical(
attr(p, "pretty_labels"),
c(
`(Intercept)` = "(Intercept)", X = "X", Mb = "M [b]", Mc = "M [c]",
`X:Mb` = "X * M [b]", `X:Mc` = "X * M [c]"
)
)
expect_snapshot(print(p))
})
)
parameters/tests/testthat/test-model_parameters.vgam.R 0000644 0001762 0000144 00000003331 14716604201 022774 0 ustar ligges users skip_if_not_installed("VGAM")
skip_on_cran()
data("pneumo", package = "VGAM")
data("hunua", package = "VGAM")
set.seed(123)
pneumo <- transform(pneumo, let = log(exposure.time))
m1 <- suppressWarnings(VGAM::vgam(
cbind(normal, mild, severe) ~ VGAM::s(let) + exposure.time,
VGAM::cumulative(parallel = TRUE),
data = pneumo,
trace = FALSE
))
set.seed(123)
hunua$x <- rnorm(nrow(hunua))
m2 <- VGAM::vgam(
agaaus ~ VGAM::s(altitude, df = 2) + VGAM::s(x) + beitaw + corlae, VGAM::binomialff,
data = hunua
)
test_that("model_parameters.vgam", {
skip("TODO: model_parameters doesn't work with 'VGAM::' in the formula")
params <- suppressWarnings(model_parameters(m1))
expect_equal(params$Coefficient, as.vector(m1@coefficients[params$Parameter]), tolerance = 1e-3)
expect_identical(params$Parameter, c("(Intercept):1", "(Intercept):2", "exposure.time", "s(let)"))
expect_equal(params$df, c(NA, NA, NA, 2.6501), tolerance = 1e-3)
expect_equal(as.vector(na.omit(params$df)), as.vector(m1@nl.df), tolerance = 1e-3)
})
test_that("model_parameters.vgam", {
skip("TODO: model_parameters doesn't work with 'VGAM::' in the formula")
params <- suppressWarnings(model_parameters(m2))
expect_equal(params$Coefficient, as.vector(m2@coefficients[params$Parameter]), tolerance = 1e-3)
expect_identical(params$Parameter, c("(Intercept)", "beitaw", "corlae", "s(altitude, df = 2)", "s(x)"))
expect_equal(params$df, c(NA, NA, NA, 0.82686, 2.8054), tolerance = 1e-3)
expect_equal(as.vector(na.omit(params$df)), as.vector(m2@nl.df), tolerance = 1e-3)
expect_named(params, c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Chi2",
"df_error", "p", "Component"
))
})
parameters/tests/testthat/test-mmrm.R 0000644 0001762 0000144 00000004103 14716604201 017466 0 ustar ligges users skip_on_cran()
skip_if_not_installed("mmrm")
skip_if_not(packageVersion("insight") > "0.18.8")
test_that("model_parameters", {
data(fev_data, package = "mmrm")
m1 <- mmrm::mmrm(
formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),
data = fev_data
)
out1 <- coef(summary(m1))
out2 <- model_parameters(m1)
expect_equal(
as.vector(out1[, "Estimate"]),
out2$Coefficient,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_identical(
rownames(out1),
out2$Parameter
)
expect_equal(
as.vector(out1[, "df"]),
out2$df_error,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_equal(
as.vector(out1[, "Pr(>|t|)"]),
out2$p,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_equal(
as.vector(out1[, "t value"]),
out2$t,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_equal(
as.vector(out1[, "Std. Error"]),
out2$SE,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_identical(attributes(out2)$ci_method, "Satterthwaite")
})
test_that("model_parameters", {
data(fev_data, package = "mmrm")
m1 <- mmrm::mmrm(
formula = FEV1 ~ RACE + SEX + ARMCD * AVISIT + us(AVISIT | USUBJID),
data = fev_data,
method = "Kenward-Roger"
)
out1 <- coef(summary(m1))
out2 <- model_parameters(m1)
expect_equal(
as.vector(out1[, "Estimate"]),
out2$Coefficient,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_identical(
rownames(out1),
out2$Parameter
)
expect_equal(
as.vector(out1[, "df"]),
out2$df_error,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_equal(
as.vector(out1[, "Pr(>|t|)"]),
out2$p,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_equal(
as.vector(out1[, "t value"]),
out2$t,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_equal(
as.vector(out1[, "Std. Error"]),
out2$SE,
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_identical(attributes(out2)$ci_method, "Kenward")
})
parameters/tests/testthat/test-bootstrap_emmeans.R 0000644 0001762 0000144 00000004761 14716604201 022252 0 ustar ligges users skip_on_cran()
test_that("emmeans | lm", {
skip_if_not_installed("emmeans")
skip_if_not_installed("boot")
skip_if_not_installed("coda")
model <- lm(mpg ~ log(wt) + factor(cyl), data = mtcars)
set.seed(7)
b <- bootstrap_model(model, iterations = 1000)
expect_equal(summary(emmeans::emmeans(b, ~cyl))$emmean,
summary(emmeans::emmeans(model, ~cyl))$emmean,
tolerance = 0.1
)
set.seed(7)
b <- bootstrap_parameters(model, iterations = 1000)
expect_equal(summary(emmeans::emmeans(b, ~cyl))$emmean,
summary(emmeans::emmeans(model, ~cyl))$emmean,
tolerance = 0.1
)
mp <- model_parameters(emmeans::emmeans(b, consec ~ cyl), verbose = FALSE)
expect_identical(
colnames(mp),
c("Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "Component")
)
expect_identical(nrow(mp), 5L)
})
test_that("emmeans | lmer", {
skip_if_not_installed("emmeans")
skip_if_not_installed("boot")
skip_if_not_installed("lme4")
skip_if_not_installed("coda")
model <- lme4::lmer(mpg ~ log(wt) + factor(cyl) + (1 | gear), data = mtcars)
set.seed(7)
b <- bootstrap_model(model, iterations = 1000)
expect_equal(summary(emmeans::emmeans(b, ~cyl))$emmean,
summary(emmeans::emmeans(model, ~cyl))$emmean,
tolerance = 0.1
)
set.seed(7)
b <- bootstrap_parameters(model, iterations = 1000)
expect_equal(summary(emmeans::emmeans(b, ~cyl))$emmean,
summary(emmeans::emmeans(model, ~cyl))$emmean,
tolerance = 0.1
)
mp <- suppressWarnings(model_parameters(emmeans::emmeans(b, consec ~ cyl)))
expect_identical(
colnames(mp),
c("Parameter", "Median", "CI", "CI_low", "CI_high", "pd", "Component")
)
expect_identical(nrow(mp), 5L)
})
test_that("emmeans | glmmTMB", {
skip_if_not_installed("coda")
skip_if_not_installed("emmeans")
skip_if_not_installed("boot")
skip_if_not_installed("lme4")
suppressWarnings(skip_if_not_installed("glmmTMB"))
data(Salamanders, package = "glmmTMB")
model <- glmmTMB::glmmTMB(count ~ spp + mined + (1 | site), family = glmmTMB::nbinom2, data = Salamanders)
set.seed(7)
b <- bootstrap_parameters(model, iterations = 10)
out <- summary(emmeans::emmeans(b, ~spp, type = "response"))
expect_equal(
out$response,
c(0.654, 0.1515, 0.8856, 0.261, 0.9775, 1.2909, 0.9031),
tolerance = 0.1
)
expect_identical(
colnames(out),
c("spp", "response", "lower.HPD", "upper.HPD")
)
expect_identical(nrow(out), 7L)
})
parameters/tests/testthat/test-posterior.R 0000644 0001762 0000144 00000004041 14716604201 020545 0 ustar ligges users skip_if_not_installed("curl")
skip_if_offline()
skip_if_not_installed("posterior")
skip_if_not_installed("brms")
skip_on_cran()
model <- insight::download_model("brms_1")
test_that("mp-posterior-draws", {
x <- posterior::as_draws(model)
mp <- model_parameters(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
expect_identical(colnames(mp), c("Parameter", "Median", "CI_low", "CI_high", "pd"))
})
test_that("mp-posterior-draws_list", {
x <- posterior::as_draws_list(model)
mp <- model_parameters(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
})
test_that("mp-posterior-draws_df", {
x <- posterior::as_draws_df(model)
mp <- model_parameters(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
})
test_that("mp-posterior-draws_matrix", {
x <- posterior::as_draws_matrix(model)
mp <- model_parameters(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
})
test_that("mp-posterior-draws_array", {
x <- posterior::as_draws_array(model)
mp <- model_parameters(x)
expect_equal(mp$Median, c(39.68234, -3.19505, -1.4936, 2.62881, -79.73344), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("b_Intercept", "b_wt", "b_cyl", "sigma", "lp__"))
})
test_that("mp-posterior-draws standard error", {
x <- posterior::as_draws(model)
se1 <- standard_error(x)
se2 <- standard_error(model)
expect_equal(se1$SE[1:4], se2$SE[1:4], tolerance = 1e-2, ignore_attr = TRUE)
})
parameters/tests/testthat/test-print_AER_labels.R 0000644 0001762 0000144 00000000613 14716604201 021665 0 ustar ligges users skip_if_not_installed("AER")
skip_if_not_installed("datawizard")
skip_if_not_installed("withr")
withr::with_options(
list(easystats_table_width = Inf),
test_that("templates", {
data(efc, package = "datawizard")
model <- AER::tobit(neg_c_7 ~ e42dep + c172code, data = efc)
mp <- model_parameters(model)
expect_snapshot(print(mp, pretty_names = "labels"))
})
)
parameters/tests/testthat/test-model_parameters.ggeffects.R 0000644 0001762 0000144 00000000666 14716604201 024007 0 ustar ligges users test_that("model_parameters.ggeffects", {
skip_if_not_installed("ggeffects")
data(iris)
mgg <- lm(Sepal.Length ~ Petal.Width + Petal.Length * Species, data = iris)
model <- ggeffects::ggpredict(mgg, terms = c("Petal.Length", "Species"))
params <- model_parameters(model)
expect_named(
params,
c("Petal.Length", "Predicted", "CI", "CI_low", "CI_high", "Component")
)
expect_snapshot(print(params))
})
parameters/tests/testthat/test-model_parameters.nnet.R 0000644 0001762 0000144 00000005344 14506526355 023026 0 ustar ligges users skip_if_not_installed("nnet")
skip_if_not_installed("faraway")
skip_if_not(packageVersion("insight") > "0.19.1")
skip_on_cran()
data("cns", package = "faraway")
cns2 <- reshape(cns,
direction = "long", timevar = "Type",
times = names(cns)[3:5], varying = 3:5, v.names = "Freq"
)[, 3:6]
cns2$Type <- factor(cns2$Type, levels = unique(cns2$Type))
mnnet1 <- nnet::multinom(Type ~ Water + Work, data = cns2, weights = Freq, trace = FALSE)
mnnet2 <- nnet::multinom(cbind(An, Sp, Other) ~ Water + Work, data = cns, trace = FALSE)
ci1 <- confint(mnnet1)
ci2 <- confint(mnnet2)
test_that("model_parameters.multinom - long and wide", {
mpnnet1 <- model_parameters(mnnet1)
mpnnet2 <- model_parameters(mnnet2)
expect_named(
mpnnet1,
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"z", "df_error", "p", "Response"
)
)
expect_identical(
mpnnet1$Parameter,
c("(Intercept)", "Water", "WorkNonManual", "(Intercept)", "Water", "WorkNonManual")
)
expect_identical(
mpnnet1$Response,
c("Sp", "Sp", "Sp", "Other", "Other", "Other")
)
expect_equal(
mpnnet1$Coefficient,
c(0.3752, -0.0013, 0.11576, -1.12255, 0.00218, -0.27028),
tolerance = 1e-4
)
expect_equal(
mpnnet1$CI_low,
as.vector(ci1[1:3, 1, 1:2]),
tolerance = 1e-4
)
expect_named(
mpnnet2,
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"z", "df_error", "p", "Response"
)
)
expect_identical(
mpnnet2$Parameter,
c("(Intercept)", "Water", "WorkNonManual", "(Intercept)", "Water", "WorkNonManual")
)
expect_identical(
mpnnet2$Response,
c("Sp", "Sp", "Sp", "Other", "Other", "Other")
)
expect_equal(
mpnnet2$Coefficient,
c(0.3752, -0.0013, 0.11576, -1.12255, 0.00218, -0.27028),
tolerance = 1e-4
)
expect_equal(
mpnnet2$CI_low,
as.vector(ci2[1:3, 1, 1:2]),
tolerance = 1e-4
)
})
test_that("ci.multinom - long and wide", {
cinnet1 <- ci(mnnet1)
cinnet2 <- ci(mnnet2)
expect_identical(
cinnet1$Parameter,
c("(Intercept)", "Water", "WorkNonManual", "(Intercept)", "Water", "WorkNonManual")
)
expect_identical(
cinnet1$Response,
c("Sp", "Sp", "Sp", "Other", "Other", "Other")
)
expect_equal(
cinnet1$CI_low,
as.vector(ci1[1:3, 1, 1:2]),
tolerance = 1e-4
)
expect_identical(
cinnet2$Parameter,
c("(Intercept)", "Water", "WorkNonManual", "(Intercept)", "Water", "WorkNonManual")
)
expect_identical(
cinnet2$Response,
c("Sp", "Sp", "Sp", "Other", "Other", "Other")
)
expect_equal(
cinnet2$CI_low,
as.vector(ci1[1:3, 1, 1:2]),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-coxph.R 0000644 0001762 0000144 00000004120 14716604211 017637 0 ustar ligges users skip_if_not_installed("survival")
lung <- subset(survival::lung, subset = ph.ecog %in% 0:2)
lung$sex <- factor(lung$sex, labels = c("male", "female"))
lung$ph.ecog <- factor(lung$ph.ecog, labels = c("good", "ok", "limited"))
m1 <- survival::coxph(survival::Surv(time, status) ~ sex + age + ph.ecog, data = lung)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(-0.87535, -0.00747, 0.01862, 0.45527),
tolerance = 1e-4
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.16823, 0.00931, 0.19961, 0.22809),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0.00118, 0.24713, 0.04005, 8e-05),
tolerance = 1e-4
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
c(-0.54563, 0.01078, 0.40984, 0.90232),
tolerance = 1e-4
)
})
test_that("model_parameters", {
suppressPackageStartupMessages(library(survival, quietly = TRUE))
# Create the simplest test data set
test1 <- list(
time = c(4, 3, 1, 1, 2, 2, 3),
status = c(1, 1, 1, 0, 1, 1, 0),
x = c(0, 2, 1, 1, 1, 0, 0),
sex = c(0, 0, 0, 0, 1, 1, 1)
)
# Fit a stratified model
m2 <- coxph(Surv(time, status) ~ x + strata(sex), test1)
expect_equal(model_parameters(m2)$Coefficient, 0.8023179, tolerance = 1e-4)
expect_equal(model_parameters(m2)$z, 0.9756088, tolerance = 1e-4)
expect_equal(model_parameters(m2)$p, 0.3292583, tolerance = 1e-4)
unloadNamespace("rms")
unloadNamespace("quantreg")
unloadNamespace("multcomp")
unloadNamespace("TH.data")
unloadNamespace("effects")
unloadNamespace("survey")
unloadNamespace("survival")
})
skip_if_not_installed("withr")
withr::with_package(
"survival",
test_that("model_parameters coxph-panel", {
set.seed(123)
# a time transform model
mod <- survival::coxph(
survival::Surv(time, status) ~ ph.ecog + tt(age),
data = lung,
tt = function(x, t, ...) pspline(x + t / 365.25)
)
expect_snapshot(print(model_parameters(mod)))
})
)
parameters/tests/testthat/test-mlm.R 0000644 0001762 0000144 00000005075 14413515226 017316 0 ustar ligges users test_that("model_parameters,mlm", {
set.seed(123)
mod <- lm(formula = cbind(mpg, disp) ~ wt, data = mtcars)
mp <- model_parameters(mod)
expect_equal(
mp$Coefficient,
c(37.28513, -5.34447, -131.14842, 112.47814),
tolerance = 1e-3
)
expect_equal(
colnames(mp),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t",
"df_error", "p", "Response"
)
)
expect_equal(mp$Response, c("mpg", "mpg", "disp", "disp"))
expect_equal(mp$Parameter, c("(Intercept)", "wt", "(Intercept)", "wt"))
})
test_that("model_parameters,mlm", {
model <- lm(cbind(mpg, hp) ~ cyl * disp, mtcars)
mp <- model_parameters(model)
expect_equal(
mp$Coefficient,
c(49.03721, -3.40524, -0.14553, 0.01585, 23.55, 17.43527, -0.36762, 0.06174),
tolerance = 1e-3
)
expect_equal(
colnames(mp),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t",
"df_error", "p", "Response"
)
)
expect_equal(mp$Response, c("mpg", "mpg", "mpg", "mpg", "hp", "hp", "hp", "hp"))
expect_equal(mp$Parameter, c("(Intercept)", "cyl", "disp", "cyl:disp", "(Intercept)", "cyl", "disp", "cyl:disp"))
})
test_that("sandwich standard errors", {
skip_if_not_installed("sandwich")
skip_if_not_installed("lmtest")
mod <- lm(formula = cbind(mpg, disp) ~ wt + factor(cyl) + am, data = mtcars)
se1 <- standard_error(mod)
se2 <- standard_error(mod, vcov = "HC3")
se3 <- standard_error(mod, vcov = sandwich::vcovHC)
se4 <- sqrt(diag(sandwich::vcovHC(mod)))
expect_true(all(se1$SE != se2$SE))
expect_true(all(se2$SE == se3$SE))
expect_true(all(se2$SE == se4))
lab <- strsplit(names(se4), ":")
expect_equal(se2$Parameter, sapply(lab, function(x) x[2]))
expect_equal(se2$Response, sapply(lab, function(x) x[1]))
p1 <- parameters(mod)
p2 <- parameters(mod, vcov = "HC3")
expect_true(all(p1$Coefficient == p2$Coefficient))
expect_true(all(p1$SE != p2$SE))
expect_true(all(p1$t != p2$t))
expect_true(all(p1$p != p2$p))
expect_true(all(p1$CI_low != p2$CI_low))
expect_true(all(p1$CI_high != p2$CI_high))
lt <- lmtest::coeftest(mod, vcov = sandwich::vcovHC)
ci <- stats::confint(lt)
expect_equal(p2$Coefficient, lt[, "Estimate"], ignore_attr = TRUE)
expect_equal(p2$SE, lt[, "Std. Error"], ignore_attr = TRUE)
expect_equal(p2$t, lt[, "t value"], ignore_attr = TRUE)
expect_equal(p2$p, lt[, "Pr(>|t|)"], ignore_attr = TRUE)
expect_equal(p2$CI_low, ci[, 1], ignore_attr = TRUE)
expect_equal(p2$CI_high, ci[, 2], ignore_attr = TRUE)
})
parameters/tests/testthat/test-plm.R 0000644 0001762 0000144 00000007150 14716604201 017313 0 ustar ligges users skip_if_not_installed("stats")
skip_if_not_installed("plm")
data(Crime, package = "plm")
data("Produc", package = "plm")
set.seed(123)
Crime$year <- as.factor(Crime$year)
m1 <- suppressWarnings(plm::plm(lcrmrte ~ lprbarr + year | . - lprbarr + lmix, data = Crime, model = "random"))
m2 <- suppressWarnings(plm::plm(
formula = log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp,
data = Produc,
index = c("state", "year")
))
test3333 <- data.frame(
ID = c("TOM", "TOM", "TOM", "TOM", "MARY", "MARY", "MARY", "JOHN", "JOHN"),
Year = c(1992:1995, 1991:1993, 1993:1994),
ret = rnorm(9),
stringsAsFactors = FALSE
)
test3333 <- plm::pdata.frame(test3333)
test3333["lag"] <- lag(test3333$ret)
test3333 <- na.omit(test3333)
test3333model <- ret ~ lag
m3 <- suppressWarnings(plm::plm(
test3333model,
data = test3333,
model = "within",
effect = "individual",
index = c("ID", "Year")
))
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(-3.73825, -0.12292, -0.05971, -0.13356, -0.18381, -0.17782, -0.11688, -0.03962),
tolerance = 1e-3
)
expect_equal(
ci(m2)$CI_low,
c(-0.08308, 0.2427, 0.70909, -0.00724),
tolerance = 1e-3
)
expect_equal(ci(m3)$CI_low, -2.60478, tolerance = 1e-3)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.13223, 0.09221, 0.02684, 0.02679, 0.02704, 0.02671, 0.02663, 0.02664),
tolerance = 1e-3
)
expect_equal(
standard_error(m2)$SE,
c(0.029, 0.02512, 0.03009, 0.00099),
tolerance = 1e-3
)
expect_equal(standard_error(m3)$SE, 0.5166726, tolerance = 1e-3)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 0.5285, 0.79456, 0.00262, 0, 0, 0.01558, 0.63395),
tolerance = 1e-3
)
expect_equal(
p_value(m2)$p,
c(0.36752, 0, 0, 0),
tolerance = 1e-3
)
expect_equal(p_value(m3)$p, 0.53696, tolerance = 1e-3)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
c(-3.47857, 0.05815, -0.00699, -0.08095, -0.13071, -0.12537, -0.06458, 0.01269),
tolerance = 1e-3
)
expect_equal(
model_parameters(m2)$Coefficient,
c(-0.02615, 0.29201, 0.76816, -0.0053),
tolerance = 1e-3
)
expect_equal(model_parameters(m3)$Coefficient, -0.381721, tolerance = 1e-3)
})
test_that("vcov standard errors", {
skip_if_not_installed("sandwich")
data("Grunfeld", package = "plm")
ran <- suppressWarnings(
plm::plm(value ~ capital + inv, data = Grunfeld, model = "random", effect = "twoways")
)
out1 <- standard_error(ran)
out2 <- standard_error(ran, vcov = "HC1")
validate1 <- coef(summary(ran))[, 2]
validate2 <- sqrt(diag(sandwich::vcovHC(ran, type = "HC1")))
expect_equal(out1$SE, validate1, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(out2$SE, validate2, tolerance = 1e-3, ignore_attr = TRUE)
expect_snapshot(print(model_parameters(ran)))
expect_snapshot(print(model_parameters(ran, vcov = "HC1")))
})
test_that("vcov standard errors, methods", {
data("Produc", package = "plm")
zz <- plm::plm(log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp,
data = Produc, model = "random"
)
out1 <- standard_error(zz, vcov = "HC1")
out2 <- standard_error(zz, vcov = "HC1", vcov_args = list(method = "white1"))
validate1 <- sqrt(diag(plm::vcovHC(zz, method = "arellano", type = "HC1")))
validate2 <- sqrt(diag(plm::vcovHC(zz, method = "white1", type = "HC1")))
expect_equal(out1$SE, validate1, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(out2$SE, validate2, tolerance = 1e-3, ignore_attr = TRUE)
})
parameters/tests/testthat/test-model_parameters.metafor.R 0000644 0001762 0000144 00000002121 14716604201 023473 0 ustar ligges users test_that("model_parameters.metafor", {
skip_if_not_installed("metafor")
test <- data.frame(
estimate = c(0.111, 0.245, 0.8, 1.1, 0.03),
std.error = c(0.05, 0.111, 0.001, 0.2, 0.01)
)
mydat <<- test
model <- metafor::rma(yi = estimate, sei = std.error, data = mydat)
params <- model_parameters(model)
expect_identical(
params$Parameter,
c("Study 1", "Study 2", "Study 3", "Study 4", "Study 5", "Overall")
)
expect_identical(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "z", "p", "Weight", "Method")
)
expect_equal(params$Coefficient, c(0.111, 0.245, 0.8, 1.1, 0.03, 0.43769), tolerance = 1e-3)
expect_equal(params$Weight, c(400, 81.16224, 1e+06, 25, 10000, NA), tolerance = 1e-3)
# test message on unsupported arguments
expect_message(model_parameters(model, vcov = "vcovHC"), regex = "Following arguments")
# test standardize
params <- model_parameters(model, standardize = "refit")
expect_equal(params$Coefficient, c(0.111, 0.245, 0.8, 1.1, 0.03, -0.5613041), tolerance = 1e-3)
})
parameters/tests/testthat/test-geeglm.R 0000644 0001762 0000144 00000001305 14736731407 017772 0 ustar ligges users skip_if_not_installed("geepack")
data(warpbreaks)
m1 <- geepack::geeglm(
breaks ~ tension,
id = wool,
data = warpbreaks,
family = poisson,
corstr = "ar1"
)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(3.28294, -0.76741, -0.64708),
tolerance = 1e-4
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.15931, 0.22554, 0.06598),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 0.14913, 0),
tolerance = 1e-4
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
c(3.59517, -0.32536, -0.51776),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-model_parameters.efa_cfa.R 0000644 0001762 0000144 00000004571 14413515226 023417 0 ustar ligges users test_that("principal_components", {
skip_if_not_installed("psych")
set.seed(333)
x <- principal_components(mtcars[, 1:7], n = "all", threshold = 0.2)
expect_identical(c(ncol(x), nrow(x)), c(8L, 7L))
x <- suppressMessages(principal_components(
mtcars[, 1:7],
n = 2,
rotation = "oblimin",
threshold = "max",
sort = TRUE
))
expect_identical(c(ncol(x), nrow(x)), c(6L, 7L))
pca <- principal_components(mtcars[, 1:5], n = 2)
expect_identical(c(ncol(pca), nrow(pca)), c(4L, 5L))
x <- summary(pca)
expect_identical(c(ncol(x), nrow(x)), c(3L, 4L))
x <- model_parameters(pca)
expect_identical(c(ncol(x), nrow(x)), c(5L, 2L))
x <- predict(pca)
expect_identical(c(ncol(x), nrow(x)), c(2L, 32L))
})
test_that("efa-cfa", {
skip_if_not_installed("psych")
skip_if_not_installed("lavaan")
efa <- psych::fa(attitude, nfactors = 3)
params <- parameters::model_parameters(efa)
expect_identical(c(nrow(params), ncol(params)), c(7L, 6L))
model1 <- efa_to_cfa(efa)
model2 <- efa_to_cfa(efa, threshold = 0.3)
expect_identical(nchar(model1), 109L)
m1 <- suppressWarnings(lavaan::cfa(model1, data = attitude))
params <- parameters::model_parameters(m1)
expect_identical(c(nrow(params), ncol(params)), c(10L, 10L))
expect_message(parameters::model_parameters(m1, ci = c(0.8, 0.9)))
params <- parameters::model_parameters(m1, standardize = TRUE, component = "all")
expect_identical(c(nrow(params), ncol(params)), c(20L, 10L))
x <- lavaan::anova(m1, lavaan::cfa(model2, data = attitude))
params <- parameters::model_parameters(x)
expect_identical(c(nrow(params), ncol(params)), c(2L, 6L))
})
test_that("FactoMineR", {
skip_if_not_installed("FactoMineR")
x <- suppressWarnings(model_parameters(
FactoMineR::PCA(mtcars, ncp = 3, graph = FALSE),
threshold = 0.2,
sort = TRUE
))
expect_identical(c(ncol(x), nrow(x)), c(5L, 11L))
# x <- suppressWarnings(model_parameters(FactoMineR::FAMD(iris, ncp = 3, graph = FALSE), threshold = 0.2, sort = TRUE))
# expect_identical(c(ncol(x), nrow(x)), c(5L, 5L))
})
test_that("BayesFM", {
skip_if_not_installed("BayesFM")
set.seed(333)
befa <- BayesFM::befa(mtcars, iter = 1000, verbose = FALSE)
params <- suppressWarnings(parameters::model_parameters(befa, sort = TRUE))
expect_identical(nrow(params), 11L)
})
parameters/tests/testthat/test-averaging.R 0000644 0001762 0000144 00000003557 14721362233 020477 0 ustar ligges users skip_on_cran()
skip_if_not_installed("MuMIn")
skip_if_not_installed("withr")
skip_if_not_installed("glmmTMB")
skip_if_not_installed("betareg")
withr::with_options(
list(na.action = "na.fail"),
test_that("MuMIn link functions", {
library(MuMIn) # nolint
set.seed(1234)
dat <- data.frame(
outcome = rbinom(n = 100, size = 1, prob = 0.35),
var_binom = as.factor(rbinom(n = 100, size = 1, prob = 0.2)),
var_cont = rnorm(n = 100, mean = 10, sd = 7),
group = sample(letters[1:4], size = 100, replace = TRUE),
stringsAsFactors = FALSE
)
dat$var_cont <- as.vector(scale(dat$var_cont))
m1 <- glm(
outcome ~ var_binom + var_cont,
data = dat,
family = binomial(link = "logit")
)
out <- MuMIn::model.avg(MuMIn::dredge(m1), fit = TRUE)
mp <- model_parameters(out)
expect_snapshot(print(mp))
})
)
test_that("ggpredict, glmmTMB averaging", {
library(MuMIn) # nolint
data(FoodExpenditure, package = "betareg")
m <- glmmTMB::glmmTMB(
I(food / income) ~ income + (1 | persons),
ziformula = ~1,
data = FoodExpenditure,
na.action = "na.fail",
family = glmmTMB::beta_family()
)
set.seed(123)
dr <- MuMIn::dredge(m)
avg <- MuMIn::model.avg(object = dr, fit = TRUE)
mp <- model_parameters(avg)
expect_snapshot(print(mp))
})
withr::with_options(
list(na.action = "na.fail"),
test_that("ggpredict, poly averaging", {
library(MuMIn)
data(mtcars)
mtcars$am <- factor(mtcars$am)
set.seed(123)
m <- lm(disp ~ mpg + I(mpg^2) + am + gear, mtcars)
dr <- MuMIn::dredge(m, subset = dc(mpg, I(mpg^2)))
dr <- subset(dr, !(has(mpg) & !has(I(mpg^2))))
mod.avg.i <- MuMIn::model.avg(dr, fit = TRUE)
mp <- model_parameters(mod.avg.i)
expect_snapshot(print(mp))
})
)
unloadNamespace("MuMIn")
parameters/tests/testthat/test-printing.R 0000644 0001762 0000144 00000010372 14726272305 020364 0 ustar ligges users skip_on_cran()
skip_if_not_installed("withr")
skip_if(getRversion() < "4.0.0")
withr::with_options(
list(parameters_interaction = "*", easystats_table_width = Inf),
{
# Splitting model components ----
test_that("print model with multiple components", {
skip_if_not_installed("glmmTMB")
data("Salamanders", package = "glmmTMB")
model <- glmmTMB::glmmTMB(count ~ spp + mined + (1 | site),
ziformula = ~ spp + mined,
family = glmmTMB::nbinom2(),
data = Salamanders
)
out <- model_parameters(model, exponentiate = TRUE)
expect_snapshot(print(out))
expect_snapshot(print(out, split_component = FALSE))
})
# Adding model summaries -----
test_that("adding model summaries", {
# summary doesn't show the R2 if performance is not installed so the
# snapshot breaks between R CMD check "classic" and "strict"
skip_if_not_installed("performance")
model <- lm(Sepal.Length ~ Species * Petal.Length, data = iris)
out <- model_parameters(model, include_info = TRUE)
expect_snapshot(print(out))
})
# Group parameters ------
test_that("grouped parameters", {
mtcars$cyl <- as.factor(mtcars$cyl)
mtcars$gear <- as.factor(mtcars$gear)
model <- lm(mpg ~ hp + gear * vs + cyl + drat, data = mtcars)
# don't select "Intercept" parameter
out <- model_parameters(model, drop = "^\\(Intercept")
expect_snapshot(
print(out, groups = list(
Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"),
Controls = c(2, 3, 7)
))
)
expect_snapshot(
print(out,
sep = " ",
groups = list(
Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"),
Controls = c(2, 3, 7)
)
)
)
})
# Digits ------
test_that("digits and ci_digits", {
mtcars$cyl <- as.factor(mtcars$cyl)
mtcars$gear <- as.factor(mtcars$gear)
model <- lm(mpg ~ hp + gear + vs + cyl + drat, data = mtcars)
expect_snapshot(model_parameters(model, digits = 4))
expect_snapshot(model_parameters(model, digits = 4, ci_digits = 1))
out <- model_parameters(model)
expect_snapshot(print(out, digits = 4))
expect_snapshot(print(out, digits = 4, ci_digits = 1))
})
# Table templates ------
test_that("select pattern", {
mtcars$cyl <- as.factor(mtcars$cyl)
mtcars$gear <- as.factor(mtcars$gear)
model <- lm(mpg ~ hp + gear * vs + cyl + drat, data = mtcars)
# don't select "Intercept" parameter
out <- model_parameters(model, drop = "^\\(Intercept")
expect_snapshot(
print(out, groups = list(
Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"),
Controls = c(2, 3, 7)
))
)
expect_snapshot(print(out, select = "{coef} ({se})"))
expect_snapshot(print(out, select = "{coef}{stars}|[{ci}]"))
expect_snapshot(
print(out, groups = list(
Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"),
Controls = c(2, 3, 7)
), select = "{coef}{stars}|[{ci}]")
)
expect_snapshot(
print(out,
sep = " ",
groups = list(
Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"),
Controls = c(2, 3, 7)
),
select = "{coef}{stars}|[{ci}]"
)
)
})
}
)
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("no more message about interpretation of log-resoponse", {
data(mtcars)
m <- lm(log(mpg) ~ gear, data = mtcars)
out <- model_parameters(m, exponentiate = TRUE)
expect_snapshot(print(out))
})
)
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("no fail for mgcv-binomial", {
skip_if_not_installed("mgcv")
m <- mgcv::gam(vs ~ s(mpg), data = mtcars, family = "binomial")
out <- model_parameters(m)
expect_snapshot(print(out))
})
)
parameters/tests/testthat/test-lme.R 0000644 0001762 0000144 00000005562 14415527674 017323 0 ustar ligges users skip_if_not_installed("nlme")
skip_if_not_installed("lme4")
data("sleepstudy", package = "lme4")
m1_lme <- nlme::lme(Reaction ~ Days, random = ~ 1 + Days | Subject, data = sleepstudy)
data("Orthodont", package = "nlme")
m2_lme <- nlme::lme(distance ~ age + Sex, random = ~ 1 | Subject, data = Orthodont, method = "ML")
data(iris)
set.seed(1234)
iris$grp <- as.factor(sample(1:3, nrow(iris), replace = TRUE))
m3_lme <- nlme::lme(
fixed = Sepal.Length ~ Species * Sepal.Width + Petal.Length,
random = ~ 1 | grp,
data = iris
)
test_that("ci", {
expect_equal(
ci(m1_lme)$CI_low,
c(237.927995380985, 7.4146616764556),
tolerance = 1e-4
)
})
test_that("ci(vcov)", {
# vcov changes results
ci1 <- ci(m3_lme)
ci2 <- suppressMessages(ci(m3_lme, vcov = "CR3"))
expect_true(all(ci1$CI_low != ci2$CI_low))
# manual computation
b <- lme4::fixef(m3_lme)
se <- standard_error(m3_lme, vcov = "CR3")$SE
tstat <- b / se
critical_t <- abs(qt(0.025, df = dof(m3_lme)))
ci_lo <- b - critical_t * se
ci_hi <- b + critical_t * se
expect_equal(ci2$CI_low, ci_lo, tolerance = 1e-3, ignore_attr = TRUE)
expect_equal(ci2$CI_high, ci_hi, tolerance = 1e-3, ignore_attr = TRUE)
})
test_that("se", {
expect_equal(
standard_error(m1_lme)$SE,
c(6.82451602451407, 1.54578275017725),
tolerance = 1e-4
)
})
test_that("se: vcov", {
skip_if_not_installed("clubSandwich")
se1 <- standard_error(m1_lme, vcov = "CR3")$SE
se2 <- sqrt(diag(as.matrix(clubSandwich::vcovCR(m1_lme, type = "CR3"))))
expect_equal(se1, se2, ignore_attr = TRUE)
})
test_that("p_value", {
expect_equal(
p_value(m1_lme)$p,
c(2.38350215912719e-80, 2.26328050057813e-10),
tolerance = 1e-4
)
})
test_that("p: vcov", {
skip_if_not_installed("clubSandwich")
skip_if_not_installed("lmtest")
# default
p1 <- stats::coef(summary(m3_lme))[, 5]
p2 <- p_value(m3_lme)$p
expect_equal(p1, p2, ignore_attr = TRUE)
# manual computation
p1 <- p_value(m3_lme, vcov = "CR3")$p
b2 <- lme4::fixef(m3_lme)
se2 <- sqrt(diag(as.matrix(clubSandwich::vcovCR(m3_lme, type = "CR3"))))
t2 <- b2 / se2
# same DF used in `nlme:::summary.lme`
p2 <- 2 * pt(-abs(t2), df = m3_lme$fixDF[["X"]])
expect_equal(p1, p2, ignore_attr = TRUE)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1_lme, effects = "fixed")$Coefficient,
c(251.405104848485, 10.467285959596),
tolerance = 1e-4
)
})
test_that("model_parameters", {
params <- model_parameters(m2_lme, effects = "fixed")
expect_equal(params$Coefficient, c(17.70671, 0.66019, -2.32102), tolerance = 1e-4)
expect_equal(params$SE, c(0.83155, 0.06209, 0.74307), tolerance = 1e-4)
# expect_equal(params$df, c(80, 80, 25), tolerance = 1e-4)
expect_equal(params$CI_low, c(16.07503, 0.53834, -3.82999), tolerance = 1e-4)
})
parameters/tests/testthat/test-car.R 0000644 0001762 0000144 00000001507 14413515226 017272 0 ustar ligges users skip_if_not_installed("car")
mod <- lm(mpg ~ disp + hp, mtcars)
x <- car::deltaMethod(mod, "disp + hp", rhs = 0)
test_that("ci", {
expect_equal(ci(x)$CI_low, x$`2.5 %`, tolerance = 1e-3)
})
test_that("se", {
expect_equal(standard_error(x)$SE, x$SE, tolerance = 1e-3)
})
test_that("p", {
expect_equal(p_value(x)$p, x$`Pr(>|z|)`, tolerance = 1e-3)
})
mp <- model_parameters(x)
test_that("model_parameters", {
expect_equal(mp$Coefficient, x$Estimate, tolerance = 1e-3)
expect_equal(mp$Parameter, row.names(x), tolerance = 1e-3)
})
x <- car::deltaMethod(mod, "disp + hp", rhs = 0, level = 0.8)
test_that("ci", {
expect_equal(ci(x)$CI_low, x$`10 %`, tolerance = 1e-3)
})
mp <- model_parameters(x)
test_that("model_parameters", {
expect_equal(attributes(mp)$ci, 0.8, tolerance = 1e-3)
})
parameters/tests/testthat/test-wrs2.R 0000644 0001762 0000144 00000003362 14413515226 017423 0 ustar ligges users skip_if_not_installed("WRS2")
data(viagra, package = "WRS2")
data(WineTasting, package = "WRS2")
data(spider, package = "WRS2")
# model_parameters.t1way ---------------------------------------------------
test_that("model_parameters.t1way", {
set.seed(123)
df_b <- model_parameters(WRS2::t1way(libido ~ dose, data = viagra))
set.seed(123)
df_w <- model_parameters(WRS2::rmanova(WineTasting$Taste, WineTasting$Wine, WineTasting$Taster))
})
# model_parameters.yuen ---------------------------------------------------
test_that("model_parameters.yuen", {
set.seed(123)
df_b <- model_parameters(WRS2::yuen(Anxiety ~ Group, data = spider))
before <- c(190, 210, 300, 240, 280, 170, 280, 250, 240, 220)
after <- c(210, 210, 340, 190, 260, 180, 200, 220, 230, 200)
set.seed(123)
df_w <- model_parameters(WRS2::yuend(before, after))
})
# model_parameters.mcp and robtab ---------------------------------------
test_that("model_parameters.mcp and robtab", {
set.seed(123)
df_b <- model_parameters(WRS2::lincon(libido ~ dose, data = viagra))
set.seed(123)
df_w <- model_parameters(WRS2::rmmcp(WineTasting$Taste, WineTasting$Wine, WineTasting$Taster))
set.seed(123)
df <- model_parameters(WRS2::discmcp(libido ~ dose, viagra, nboot = 100))
})
# model_parameters.akp.effect -----------------------------------------------
test_that("model_parameters.AKP", {
set.seed(123)
mod <- WRS2::akp.effect(
formula = wt ~ am,
data = mtcars,
EQVAR = FALSE
)
})
# model_parameters.onesampb ---------------------------------------------------
test_that("model_parameters.onesampb", {
set.seed(123)
x <- rnorm(30)
set.seed(123)
mod <- WRS2::onesampb(x, nboot = 100)
})
parameters/tests/testthat/test-serp.R 0000644 0001762 0000144 00000002221 14721362233 017470 0 ustar ligges users skip_if_not_installed("serp")
skip_if_not_installed("withr")
# make sure we have the correct interaction mark for tests
withr::with_options(
list(parameters_interaction = "*"),
test_that("model_parameters.serp", {
data(wine, package = "serp")
m1 <- serp::serp(
rating ~ temp * contact,
slope = "penalize",
link = "logit", reverse = TRUE, tuneMethod = "user",
lambda = 5, data = ordinal::wine
)
mp <- model_parameters(m1, verbose = FALSE)
expect_snapshot(suppressMessages(print(mp)))
# validate against coef
out <- coef(summary(m1))
expect_equal(mp$Coefficient, out[, 1], tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(mp$SE, out[, 2], tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(mp$z, out[, 3], tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(mp$p, out[, 4], tolerance = 1e-4, ignore_attr = TRUE)
out <- confint(m1)
expect_equal(mp$CI_low, out[, 1], tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(degrees_of_freedom(m1), Inf, tolerance = 1e-3)
expect_equal(degrees_of_freedom(m1, "residual"), 279.5938, tolerance = 1e-3)
})
)
parameters/tests/testthat/test-model_parameters.cgam.R 0000644 0001762 0000144 00000004534 14716604201 022757 0 ustar ligges users skip_on_cran()
test_that("model_parameters - cgam", {
skip_if_not(getRversion() >= "4.0.0")
skip_if_not_installed("cgam")
# cgam -----------------------
data(cubic, package = "cgam")
# model
m_cgam <- cgam::cgam(formula = y ~ cgam::incr.conv(x), data = cubic)
df_cgam <- model_parameters(m_cgam)
expect_equal(
df_cgam,
data.frame(
Parameter = "(Intercept)",
Coefficient = 1.187,
SE = 0.3054,
CI = 0.95,
CI_low = 0.569520101908619,
CI_high = 1.80447989809138,
t = 3.8868,
df_error = 39.5,
p = 4e-04,
stringsAsFactors = FALSE
),
tolerance = 0.01,
ignore_attr = TRUE
)
})
# cgamm -----------------------
test_that("model_parameters - cgamm", {
skip_if_not(getRversion() >= "4.0.0")
skip_if_not_installed("cgam")
# setup
set.seed(123)
# simulate a balanced data set with 30 clusters
# each cluster has 30 data points
n <- 30
m <- 30
# the standard deviation of between cluster error terms is 1
# the standard deviation of within cluster error terms is 2
sige <- 1
siga <- 2
# generate a continuous predictor
x <- 1:(m * n)
for (i in 1:m) {
x[(n * (i - 1) + 1):(n * i)] <- round(runif(n), 3)
}
# generate a group factor
group <- trunc(0:((m * n) - 1) / n) + 1
# generate the fixed-effect term
mu <- 10 * exp(10 * x - 5) / (1 + exp(10 * x - 5))
# generate the random-intercept term asscosiated with each group
avals <- rnorm(m, 0, siga)
# generate the response
y <- 1:(m * n)
for (i in 1:m) {
y[group == i] <- mu[group == i] + avals[i] + rnorm(n, 0, sige)
}
# use REML method to fit the model
ans <- cgam::cgamm(formula = y ~ cgam::s.incr(x) + (1 | group), reml = TRUE)
df <- suppressWarnings(model_parameters(ans))
expect_equal(
df,
data.frame(
Parameter = c("(Intercept)", "cgam::s.incr(x)"),
Coefficient = c(5.5174, NA),
SE = c(0.3631, NA),
CI = c(0.95, NA),
CI_low = c(4.80476838465533, NA),
CI_high = c(6.23003161534467, NA),
`t / F` = c(15.1954, NA),
df = c(NA, 8.4),
df_error = c(890.4, NA),
p = c(0, 0),
Component = c("conditional", "smooth_terms"),
stringsAsFactors = FALSE
),
tolerance = 0.01,
ignore_attr = TRUE
)
})
parameters/tests/testthat/test-visualisation_recipe.R 0000644 0001762 0000144 00000000420 14716604201 022735 0 ustar ligges users test_that("vis_recipe.cluster_analysis", {
data(iris)
result <- cluster_analysis(iris[, 1:4], n = 4)
out <- visualisation_recipe(result)
expect_named(out, c("l1", "l2", "l3"))
expect_s3_class(out, "visualisation_recipe")
expect_snapshot(print(out))
})
parameters/tests/testthat/test-model_parameters.mclogit.R 0000644 0001762 0000144 00000002016 14716604201 023477 0 ustar ligges users skip_if_not_installed("mclogit")
skip_if_not_installed("withr")
skip_if_not(packageVersion("insight") > "0.19.1")
skip_on_cran()
withr::with_options(
list(parameters_exponentiate = FALSE),
{
data(Transport, package = "mclogit")
invisible(capture.output({
m1 <- mclogit::mclogit(
cbind(resp, suburb) ~ distance + cost,
data = Transport
)
}))
data(housing, package = "MASS")
invisible(capture.output({
m2 <- mclogit::mblogit(Sat ~ Infl + Type + Cont,
weights = Freq,
data = housing
)
}))
test_that("model_parameters.mclogit", {
params <- model_parameters(m1)
expect_snapshot(params)
})
test_that("model_parameters.mblogit", {
params <- model_parameters(m2)
expect_snapshot(params)
})
skip_on_os(c("mac", "linux"))
test_that("simulate_parameters.mblogit", {
set.seed(1234)
params <- simulate_parameters(m2)
expect_snapshot(params)
})
}
)
parameters/tests/testthat/test-glmmTMB.R 0000644 0001762 0000144 00000060653 14736731407 020044 0 ustar ligges users skip_if_not_installed("withr")
skip_if_not_installed("glmmTMB")
skip_if_not(getRversion() >= "4.0.0")
data("fish")
data("Salamanders", package = "glmmTMB")
skip_on_cran()
withr::with_options(
list(parameters_exponentiate = FALSE),
{
m1 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 | persons),
ziformula = ~ child + camper + (1 | persons),
data = fish,
family = glmmTMB::truncated_poisson()
))
m2 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 | persons),
data = fish,
family = poisson()
))
m3 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ spp + mined + (1 | site),
ziformula = ~ spp + mined,
family = glmmTMB::nbinom2,
data = Salamanders
))
test_that("unsupported args", {
expect_message(model_parameters(m1, vcov = "HC3", effects = "fixed", component = "conditional"))
expect_message(model_parameters(m1, vcov = "HC3"))
})
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(0.33067, -1.32402, 0.55037, -1.66786, 1.44667, -1.64177),
tolerance = 1e-3
)
expect_equal(
ci(m1, component = "cond")$CI_low,
c(0.33067, -1.32402, 0.55037),
tolerance = 1e-3
)
expect_equal(
ci(m1, component = "zi")$CI_low,
c(-1.66786, 1.44667, -1.64177),
tolerance = 1e-3
)
expect_equal(
ci(m2)$CI_low,
c(-0.47982, -1.85096, 0.76044),
tolerance = 1e-3
)
expect_equal(
ci(m2, component = "cond")$CI_low,
c(-0.47982, -1.85096, 0.76044),
tolerance = 1e-3
)
expect_message(
expect_null(ci(m2, component = "zi")),
"no zero-inflation component"
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.47559, 0.09305, 0.09346, 0.65229, 0.3099, 0.32324),
tolerance = 1e-3
)
expect_equal(
standard_error(m1, component = "cond")$SE,
c(0.47559, 0.09305, 0.09346),
tolerance = 1e-3
)
expect_equal(
standard_error(m1, component = "zi")$SE,
c(0.65229, 0.3099, 0.32324),
tolerance = 1e-3
)
expect_equal(
standard_error(m2)$SE,
c(0.62127, 0.08128, 0.08915),
tolerance = 1e-3
)
expect_equal(
standard_error(m2, component = "cond")$SE,
c(0.62127, 0.08128, 0.08915),
tolerance = 1e-3
)
expect_message(
expect_null(standard_error(m2, component = "zi")),
"no zero-inflation component"
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0.00792, 0, 0, 0.55054, 0, 0.00181),
tolerance = 1e-3
)
expect_equal(
p_value(m1, component = "cond")$p,
c(0.00792, 0, 0),
tolerance = 1e-3
)
expect_equal(
p_value(m1, component = "zi")$p,
c(0.55054, 0, 0.00181),
tolerance = 1e-3
)
expect_equal(
p_value(m2)$p,
c(0.23497, 0, 0),
tolerance = 1e-3
)
expect_equal(
p_value(m2, component = "cond")$p,
c(0.23497, 0, 0),
tolerance = 1e-3
)
expect_message(
expect_null(p_value(m2, component = "zi")),
"no zero-inflation component"
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1, effects = "fixed")$Coefficient,
c(1.2628, -1.14165, 0.73354, -0.38939, 2.05407, -1.00823),
tolerance = 1e-3
)
expect_equal(
model_parameters(m1, effects = "all")$Coefficient,
c(1.2628, -1.14165, 0.73354, -0.38939, 2.05407, -1.00823, 0.9312, 1.17399),
tolerance = 1e-3
)
expect_equal(
model_parameters(m2, effects = "fixed")$Coefficient,
c(0.73785, -1.69166, 0.93516),
tolerance = 1e-3
)
expect_equal(
model_parameters(m3, effects = "fixed")$Coefficient,
c(
-0.61038, -0.9637, 0.17068, -0.38706, 0.48795, 0.58949, -0.11327,
1.42935, 0.91004, 1.16141, -0.93932, 1.04243, -0.56231, -0.893,
-2.53981, -2.56303, 1.51165
),
tolerance = 1e-2
)
expect_identical(
model_parameters(m1)$Component,
c(
"conditional", "conditional", "conditional", "zero_inflated",
"zero_inflated", "zero_inflated", "conditional", "zero_inflated"
)
)
expect_null(model_parameters(m2, effects = "fixed")$Component)
expect_identical(
model_parameters(m2)$Component,
c("conditional", "conditional", "conditional", "conditional")
)
expect_identical(
model_parameters(m3, effects = "fixed")$Component,
c(
"conditional", "conditional", "conditional", "conditional",
"conditional", "conditional", "conditional", "conditional", "zero_inflated",
"zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated",
"zero_inflated", "zero_inflated", "zero_inflated", "dispersion"
)
)
expect_equal(
model_parameters(m3, effects = "fixed")$SE,
c(
0.4052, 0.6436, 0.2353, 0.3424, 0.2383, 0.2278, 0.2439, 0.3666,
0.6279, 1.3346, 0.8005, 0.714, 0.7263, 0.7535, 2.1817, 0.6045,
NA
),
tolerance = 1e-2
)
})
test_that("model_parameters.mixed-random", {
params <- model_parameters(m1, effects = "random", group_level = TRUE)
expect_identical(c(nrow(params), ncol(params)), c(8L, 10L))
expect_named(
params,
c(
"Parameter", "Level", "Coefficient", "SE", "CI", "CI_low",
"CI_high", "Component", "Effects", "Group"
)
)
expect_identical(
as.vector(params$Parameter),
c(
"(Intercept)", "(Intercept)", "(Intercept)", "(Intercept)",
"(Intercept)", "(Intercept)", "(Intercept)", "(Intercept)"
)
)
expect_identical(
params$Component,
c(
"conditional", "conditional", "conditional", "conditional",
"zero_inflated", "zero_inflated", "zero_inflated", "zero_inflated"
)
)
expect_equal(
params$Coefficient,
c(-1.24, -0.3456, 0.3617, 1.2553, 1.5719, 0.3013, -0.3176, -1.5665),
tolerance = 1e-2
)
})
test_that("model_parameters.mixed-ran_pars", {
params <- model_parameters(m1, effects = "random")
expect_identical(c(nrow(params), ncol(params)), c(2L, 9L))
expect_named(
params,
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Effects", "Group", "Component")
)
expect_identical(
params$Parameter,
c("SD (Intercept)", "SD (Intercept)")
)
expect_identical(
params$Component,
c("conditional", "zero_inflated")
)
expect_equal(
params$Coefficient,
c(0.9312, 1.17399),
tolerance = 1e-2
)
})
test_that("model_parameters.mixed-all_pars", {
params <- model_parameters(m1, effects = "all")
expect_identical(c(nrow(params), ncol(params)), c(8L, 12L))
expect_named(
params,
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low",
"CI_high", "z", "df_error", "p", "Effects", "Group", "Component"
)
)
expect_identical(
params$Parameter,
c(
"(Intercept)", "child", "camper1", "(Intercept)", "child",
"camper1", "SD (Intercept)", "SD (Intercept)"
)
)
expect_identical(
params$Component,
c(
"conditional", "conditional", "conditional", "zero_inflated",
"zero_inflated", "zero_inflated", "conditional", "zero_inflated"
)
)
expect_equal(
params$Coefficient,
c(1.2628, -1.14165, 0.73354, -0.38939, 2.05407, -1.00823, 0.9312, 1.17399),
tolerance = 1e-2
)
})
test_that("model_parameters.mixed-all", {
params <- model_parameters(m1, effects = "all", group_level = TRUE)
expect_identical(c(nrow(params), ncol(params)), c(14L, 13L))
expect_named(
params,
c(
"Parameter", "Level", "Coefficient", "SE", "CI", "CI_low",
"CI_high", "z", "df_error", "p", "Component", "Effects",
"Group"
)
)
expect_identical(
params$Parameter,
c(
"(Intercept)", "child", "camper1", "(Intercept)", "child",
"camper1", "(Intercept)", "(Intercept)", "(Intercept)", "(Intercept)",
"(Intercept)", "(Intercept)", "(Intercept)", "(Intercept)"
)
)
expect_identical(
params$Component,
c(
"conditional", "conditional", "conditional", "zero_inflated",
"zero_inflated", "zero_inflated", "conditional", "conditional",
"conditional", "conditional", "zero_inflated", "zero_inflated",
"zero_inflated", "zero_inflated"
)
)
expect_equal(
params$Coefficient,
c(
1.2628, -1.1417, 0.7335, -0.3894, 2.0541, -1.0082, -1.24, -0.3456,
0.3617, 1.2553, 1.5719, 0.3013, -0.3176, -1.5665
),
tolerance = 1e-2
)
})
data(mtcars)
mdisp <- glmmTMB::glmmTMB(hp ~ 0 + wt / mpg, mtcars)
test_that("model_parameters, dispersion", {
mp <- model_parameters(mdisp)
expect_equal(mp$Coefficient, c(59.50992, -0.80396, 48.97731), tolerance = 1e-2)
expect_identical(mp$Parameter, c("wt", "wt:mpg", "(Intercept)"))
expect_identical(mp$Component, c("conditional", "conditional", "dispersion"))
})
mdisp <- glmmTMB::glmmTMB(hp ~ 0 + wt / mpg + (1 | gear), mtcars)
test_that("model_parameters, dispersion", {
mp <- model_parameters(mdisp)
expect_equal(mp$Coefficient, c(58.25869, -0.87868, 47.01676, 36.99492), tolerance = 1e-2)
expect_identical(mp$Parameter, c("wt", "wt:mpg", "SD (Intercept)", "SD (Observations)"))
expect_identical(mp$Component, c("conditional", "conditional", "conditional", "conditional"))
})
m4 <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 + xb | persons),
ziformula = ~ child + camper + (1 + zg | persons),
data = fish,
family = glmmTMB::truncated_poisson()
))
test_that("model_parameters.mixed-ran_pars", {
expect_message(
{
params <- model_parameters(m4, effects = "random")
},
regex = "Your model may"
)
expect_identical(c(nrow(params), ncol(params)), c(6L, 9L))
expect_named(
params,
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Effects", "Group", "Component")
)
expect_identical(
params$Parameter,
c(
"SD (Intercept)", "SD (xb)", "Cor (Intercept~xb)",
"SD (Intercept)", "SD (zg)", "Cor (Intercept~zg)"
)
)
expect_identical(
params$Component,
c(
"conditional", "conditional", "conditional",
"zero_inflated", "zero_inflated", "zero_inflated"
)
)
expect_equal(
params$Coefficient,
c(3.40563, 1.21316, -1, 2.73583, 1.56833, 1),
tolerance = 1e-2
)
})
# exponentiate for dispersion = sigma parameters -----------------------
set.seed(101)
## rbeta() function parameterized by mean and shape
my_rbeta <- function(n, mu, shape0) {
rbeta(n, shape1 = mu * shape0, shape2 = (1 - mu) * shape0)
}
n <- 100
ng <- 10
dd <- data.frame(x = rnorm(n), f = factor(rep(1:(n / ng), ng)))
dd <- transform(dd, y = my_rbeta(n, mu = plogis(-1 + 2 * x + rnorm(ng)[f]), shape0 = 5))
m_exp <- glmmTMB::glmmTMB(y ~ x + (1 | f), family = glmmTMB::beta_family(), dd)
test_that("model_parameters, exp, glmmTMB", {
mp1 <- model_parameters(m_exp, exponentiate = TRUE)
mp2 <- model_parameters(m_exp, exponentiate = FALSE)
expect_equal(mp1$Coefficient, c(0.49271, 6.75824, 5.56294, 1.14541), tolerance = 1e-3)
expect_equal(mp1$Coefficient[3:4], mp2$Coefficient[3:4], tolerance = 1e-3)
})
test_that("model_parameters, no dispersion, glmmTMB", {
mp1 <- model_parameters(m_exp, effects = "fixed", component = "conditional", exponentiate = TRUE)
mp2 <- model_parameters(m_exp, effects = "fixed", component = "conditional", exponentiate = FALSE)
expect_equal(mp1$Coefficient, unname(exp(unlist(glmmTMB::fixef(m_exp)$cond))), tolerance = 1e-3)
expect_equal(mp2$Coefficient, unname(unlist(glmmTMB::fixef(m_exp)$cond)), tolerance = 1e-3)
})
# proper printing ---------------------
test_that("print-model_parameters glmmTMB", {
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.3.3")
mp <- model_parameters(m4, effects = "fixed", component = "conditional")
out <- utils::capture.output(print(mp))
expect_snapshot(out[-5])
mp <- model_parameters(m4, ci_random = TRUE, effects = "random", component = "conditional", verbose = FALSE)
out <- utils::capture.output(print(mp))
expect_identical(
attributes(mp)$pretty_labels,
c(
`SD (Intercept)` = "SD (Intercept)", `SD (xb)` = "SD (xb)",
`Cor (Intercept~xb)` = "Cor (Intercept~xb)"
)
)
expect_identical(
substr(out, 1, 30),
c(
"# Random Effects",
"",
"Parameter | ",
"------------------------------",
"SD (Intercept: persons) | ",
"SD (xb: persons) | ",
"Cor (Intercept~xb: persons) | "
)
)
expect_equal(mp$Coefficient, c(3.40563, 1.21316, -1), tolerance = 1e-3)
expect_equal(mp$CI_low, c(1.64567, 0.5919, -1), tolerance = 1e-3)
mp <- model_parameters(m4, ci_random = TRUE, effects = "fixed", component = "zero_inflated")
out <- utils::capture.output(print(mp))
expect_identical(
attributes(mp)$pretty_labels,
c(`(Intercept)` = "(Intercept)", child = "child", camper1 = "camper [1]")
)
expect_identical(
substr(out, 1, 12),
c(
"# Fixed Effe", "", "Parameter ", "------------", "(Intercept) ",
"child ", "camper [1] "
)
)
expect_equal(mp$Coefficient, c(1.88964, 0.15712, -0.17007), tolerance = 1e-3)
expect_equal(mp$CI_low, c(0.5878, -0.78781, -0.92836), tolerance = 1e-3)
mp <- model_parameters(m4, ci_random = TRUE, effects = "random", component = "zero_inflated", verbose = FALSE)
out <- utils::capture.output(print(mp))
expect_identical(
attributes(mp)$pretty_labels,
c(
`SD (Intercept)` = "SD (Intercept)", `SD (zg)` = "SD (zg)",
`Cor (Intercept~zg)` = "Cor (Intercept~zg)"
)
)
expect_identical(
substr(out, 1, 30),
c(
"# Random Effects (Zero-Inflati", "", "Parameter | ",
"------------------------------", "SD (Intercept: persons) | ",
"SD (zg: persons) | ", "Cor (Intercept~zg: persons) | "
)
)
expect_equal(mp$Coefficient, c(2.73583, 1.56833, 1), tolerance = 1e-3)
expect_equal(mp$CI_low, c(1.16329, 0.64246, -1), tolerance = 1e-3)
mp <- model_parameters(m4, ci_random = TRUE, effects = "all", component = "conditional", verbose = FALSE)
out <- utils::capture.output(print(mp))
expect_identical(
attributes(mp)$pretty_labels,
c(
`(Intercept)` = "(Intercept)", child = "child", camper1 = "camper [1]",
`SD (Intercept)` = "SD (Intercept)", `SD (xb)` = "SD (xb)",
`Cor (Intercept~xb)` = "Cor (Intercept~xb)"
)
)
expect_identical(
substr(out, 1, 30),
c(
"# Fixed Effects", "", "Parameter | Log-Mean | SE ",
"------------------------------",
"(Intercept) | 2.55 | 0.25 ", "child | -1.09 | 0.10 ",
"camper [1] | 0.27 | 0.10 ", "", "# Random Effects", "",
"Parameter | ", "------------------------------",
"SD (Intercept: persons) | ", "SD (xb: persons) | ",
"Cor (Intercept~xb: persons) | "
)
)
expect_equal(mp$Coefficient, c(2.54713, -1.08747, 0.2723, 3.40563, 1.21316, -1), tolerance = 1e-3)
expect_equal(mp$CI_low, c(2.06032, -1.27967, 0.07461, 1.64567, 0.5919, -1), tolerance = 1e-3)
mp <- model_parameters(m4, effects = "all", ci_random = TRUE, component = "zero_inflated", verbose = FALSE)
out <- utils::capture.output(print(mp))
expect_identical(
attributes(mp)$pretty_labels,
c(
`(Intercept)` = "(Intercept)", child = "child", camper1 = "camper [1]",
`SD (Intercept)` = "SD (Intercept)", `SD (zg)` = "SD (zg)",
`Cor (Intercept~zg)` = "Cor (Intercept~zg)"
)
)
expect_identical(
substr(out, 1, 30),
c(
"# Fixed Effects (Zero-Inflatio", "", "Parameter | Log-Mean | SE ",
"------------------------------", "(Intercept) | 1.89 | 0.66 ",
"child | 0.16 | 0.48 ", "camper [1] | -0.17 | 0.39 ",
"", "# Random Effects (Zero-Inflati", "", "Parameter | ",
"------------------------------", "SD (Intercept: persons) | ",
"SD (zg: persons) | ", "Cor (Intercept~zg: persons) | "
)
)
expect_equal(mp$Coefficient, c(1.88964, 0.15712, -0.17007, 2.73583, 1.56833, 1), tolerance = 1e-3)
expect_equal(mp$CI_low, c(0.5878, -0.78781, -0.92836, 1.16329, 0.64246, -1), tolerance = 1e-3)
mp <- model_parameters(m4, effects = "all", component = "all", ci_random = TRUE, verbose = FALSE)
out <- utils::capture.output(print(mp))
expect_identical(
attributes(mp)$pretty_labels,
c(
`(Intercept)` = "(Intercept)", child = "child", camper1 = "camper [1]",
`(Intercept)` = "(Intercept)", child = "child", camper1 = "camper1", # nolint
`SD (Intercept)` = "SD (Intercept)", `SD (xb)` = "SD (xb)",
`Cor (Intercept~xb)` = "Cor (Intercept~xb)",
`SD (Intercept)` = "SD (Intercept)", `SD (zg)` = "SD (zg)", # nolint
`Cor (Intercept~zg)` = "Cor (Intercept~zg)"
)
)
expect_identical(
substr(out, 1, 30),
c(
"# Fixed Effects (Count Model)", "", "Parameter | Log-Mean | SE ",
"------------------------------", "(Intercept) | 2.55 | 0.25 ",
"child | -1.09 | 0.10 ", "camper [1] | 0.27 | 0.10 ",
"", "# Fixed Effects (Zero-Inflatio", "", "Parameter | Log-Odds | SE ",
"------------------------------", "(Intercept) | 1.89 | 0.66 ",
"child | 0.16 | 0.48 ", "camper [1] | -0.17 | 0.39 ",
"", "# Random Effects Variances", "", "Parameter | ",
"------------------------------", "SD (Intercept: persons) | ",
"SD (xb: persons) | ", "Cor (Intercept~xb: persons) | ",
"", "# Random Effects (Zero-Inflati", "", "Parameter | ",
"------------------------------", "SD (Intercept: persons) | ",
"SD (zg: persons) | ", "Cor (Intercept~zg: persons) | "
)
)
expect_equal(
mp$Coefficient,
c(
2.54713, -1.08747, 0.2723, 1.88964, 0.15712, -0.17007, 3.40563,
1.21316, -1, 2.73583, 1.56833, 1
),
tolerance = 1e-3
)
expect_equal(
mp$CI_low,
c(
2.06032, -1.27967, 0.07461, 0.5878, -0.78781, -0.92836, 1.64567,
0.5919, -1, 1.16329, 0.64246, -1
),
tolerance = 1e-3
)
})
# proper printing of digits ---------------------
test_that("print-model_parameters glmmTMB digits", {
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.3.3")
mp <- model_parameters(m4, ci_random = TRUE, effects = "all", component = "all")
out <- utils::capture.output(print(mp, digits = 4, ci_digits = 5))
expect_snapshot(out[-c(5, 14)])
mp <- model_parameters(m4, effects = "all", component = "all", ci_random = TRUE, digits = 4, ci_digits = 5)
out <- utils::capture.output(print(mp))
expect_snapshot(out[-c(5, 14)])
})
# proper alignment of CIs ---------------------
test_that("print-model_parameters glmmTMB CI alignment", {
skip_if_not_installed("curl")
skip_if_offline()
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.3.3")
model_pr <- tryCatch(
{
load(url("https://github.com/d-morrison/parameters/raw/glmmTMB/data/pressure_durations.RData"))
glmmTMB::glmmTMB(
formula = n_samples ~ Surface + Side + Jaw + (1 | Participant / Session),
ziformula = ~ Surface + Side + Jaw + (1 | Participant / Session),
dispformula = ~1,
family = glmmTMB::nbinom2(),
data = pressure_durations
)
},
error = function(e) {
NULL
}
)
mp <- model_parameters(model_pr, effects = "random", component = "all", ci_random = TRUE)
expect_snapshot(print(mp))
mp <- model_parameters(model_pr, effects = "fixed", component = "all")
expect_snapshot(print(mp))
})
test_that("model_parameters.mixed-all", {
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.3.3")
params <- model_parameters(m4, effects = "all")
expect_identical(c(nrow(params), ncol(params)), c(12L, 12L))
expect_identical(
colnames(params),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"z", "df_error", "p", "Effects", "Group", "Component"
)
)
expect_identical(
params$Parameter,
c(
"(Intercept)", "child", "camper1", "(Intercept)", "child",
"camper1", "SD (Intercept)", "SD (xb)", "Cor (Intercept~xb)",
"SD (Intercept)", "SD (zg)", "Cor (Intercept~zg)"
)
)
expect_identical(
params$Component,
c(
"conditional", "conditional", "conditional", "zero_inflated",
"zero_inflated", "zero_inflated", "conditional", "conditional",
"conditional", "zero_inflated", "zero_inflated", "zero_inflated"
)
)
expect_equal(
params$Coefficient,
c(
2.54713, -1.08747, 0.2723, 1.88964, 0.15712, -0.17007, 3.40563,
1.21316, -1, 2.73583, 1.56833, 1
),
tolerance = 1e-2
)
})
test_that("print-model_parameters", {
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.3.3")
mp <- model_parameters(m1, effects = "fixed", verbose = FALSE)
expect_snapshot(mp)
mp <- model_parameters(m1, effects = "fixed", exponentiate = TRUE, verbose = FALSE)
expect_snapshot(mp)
mp <- model_parameters(m1, effects = "all", verbose = FALSE)
expect_snapshot(mp)
})
test_that("print-model_parameters, random dispersion", {
data(Salamanders, package = "glmmTMB")
m <- glmmTMB::glmmTMB(
count ~ spp + cover + mined + (1 | site),
ziformula = ~ spp + mined,
dispformula = ~ DOY + (1 | site),
data = Salamanders,
family = glmmTMB::nbinom1()
)
out <- as.data.frame(model_parameters(m, effects = "fixed", component = "all"))
expect_identical(nrow(out), 19L)
out <- as.data.frame(model_parameters(m, effects = "random", component = "all"))
expect_identical(nrow(out), 1L)
out <- as.data.frame(model_parameters(m, effects = "random", component = "all", group_level = TRUE))
expect_identical(nrow(out), 46L)
expect_equal(out$Coefficient, unlist(glmmTMB::ranef(m)), ignore_attr = TRUE, tolerance = 1e-4)
})
}
)
parameters/tests/testthat/test-ivreg.R 0000644 0001762 0000144 00000002322 14413515226 017635 0 ustar ligges users skip_if_not_installed("AER")
data(CigarettesSW, package = "AER")
CigarettesSW$rprice <- with(CigarettesSW, price / cpi)
CigarettesSW$rincome <- with(CigarettesSW, income / population / cpi)
CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax) / cpi)
m1 <- AER::ivreg(
log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax / cpi),
data = CigarettesSW,
subset = year == "1995"
)
test_that("ci", {
expect_equal(
ci(m1, method = "normal")$CI_low,
c(7.82022, -1.79328, -0.18717),
tolerance = 1e-4
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(1.05856, 0.2632, 0.23857),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 1e-05, 0.24602),
tolerance = 1e-4
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
c(9.89496, -1.27742, 0.2804),
tolerance = 1e-4
)
})
test_that("print-model_parameters", {
skip_if_not_installed("withr")
withr::local_options(
list(
parameters_exponentiate = TRUE,
parameters_warning_exponentiate = TRUE
)
)
tmp <- model_parameters(m1)
expect_snapshot(tmp)
})
parameters/tests/testthat/test-lavaan.R 0000644 0001762 0000144 00000003643 14413515226 017772 0 ustar ligges users skip_if_not_installed("lavaan")
data(PoliticalDemocracy, package = "lavaan")
model <- "
# measurement model
ind60 =~ x1 + x2 + x3
dem60 =~ y1 + y2 + y3 + y4
dem65 =~ y5 + y6 + y7 + y8
# regressions
dem60 ~ ind60
dem65 ~ ind60 + dem60
# residual correlations
y1 ~~ y5
y2 ~~ y4 + y6
y3 ~~ y7
y4 ~~ y8
y6 ~~ y8
"
m <- lavaan::sem(model, data = PoliticalDemocracy, test = "Satorra-Bentler")
test_that("unstandardized", {
mp <- model_parameters(m, eta_squared = "raw")
ml <- lavaan::parameterEstimates(m, se = TRUE)
ml <- ml[(ml$lhs != ml$rhs) & (ml$op != "~1"), ]
expect_equal(mp$Coefficient, ml$est, tolerance = 1e-3)
expect_equal(mp$SE, ml$se, tolerance = 1e-3)
})
test_that("standardized", {
mp <- model_parameters(m, standardize = TRUE)
ml <- lavaan::standardizedSolution(m, type = "std.all", se = TRUE)
ml <- ml[(ml$lhs != ml$rhs) & (ml$op != "~1"), ]
expect_equal(mp$Coefficient, ml$est, tolerance = 1e-3)
expect_equal(mp$SE, ml$se, tolerance = 1e-3)
})
test_that("standardized-lv", {
mp <- model_parameters(m, standardize = "latent")
ml <- lavaan::standardizedSolution(m, type = "std.lv", se = TRUE)
ml <- ml[(ml$lhs != ml$rhs) & (ml$op != "~1"), ]
expect_equal(mp$Coefficient, ml$est, tolerance = 1e-3)
expect_equal(mp$SE, ml$se, tolerance = 1e-3)
})
test_that("standardized-nox", {
mp <- model_parameters(m, standardize = "no_exogenous")
ml <- lavaan::standardizedSolution(m, type = "std.nox", se = TRUE)
ml <- ml[(ml$lhs != ml$rhs) & (ml$op != "~1"), ]
expect_equal(mp$Coefficient, ml$est, tolerance = 1e-3)
expect_equal(mp$SE, ml$se, tolerance = 1e-3)
})
test_that("standardized no CI", {
mod <- lavaan::cfa("ind60 =~ x1 + x2 + x3", data = PoliticalDemocracy)
p <- parameters(mod, standardize = "all", ci = NULL)
expect_s3_class(p, "parameters_sem")
})
parameters/tests/testthat/test-weightit.R 0000644 0001762 0000144 00000002435 14761357456 020371 0 ustar ligges users skip_on_os("mac")
skip_if_not_installed("WeightIt", minimum_version = "1.2.0")
skip_if_not_installed("cobalt")
skip_if_not_installed("insight", minimum_version = "0.20.4")
test_that("weightit, multinom", {
data("lalonde", package = "cobalt")
set.seed(1234)
# Logistic regression ATT weights
w.out <- WeightIt::weightit(
treat ~ age + educ + married + re74,
data = lalonde,
method = "glm",
estimand = "ATT"
)
lalonde$re78_3 <- factor(findInterval(lalonde$re78, c(0, 5e3, 1e4)))
fit4 <- WeightIt::multinom_weightit(
re78_3 ~ treat + age + educ,
data = lalonde,
weightit = w.out
)
expect_snapshot(print(model_parameters(fit4, exponentiate = TRUE), zap_small = TRUE))
})
test_that("weightit, ordinal", {
data("lalonde", package = "cobalt")
set.seed(1234)
# Logistic regression ATT weights
w.out <- WeightIt::weightit(
treat ~ age + educ + married + re74,
data = lalonde,
method = "glm",
estimand = "ATT"
)
lalonde$re78_3 <- factor(findInterval(lalonde$re78, c(0, 5e3, 1e4)))
fit5 <- WeightIt::ordinal_weightit(
ordered(re78_3) ~ treat + age + educ,
data = lalonde,
weightit = w.out
)
expect_snapshot(print(model_parameters(fit5, exponentiate = TRUE), zap_small = TRUE))
})
parameters/tests/testthat/test-format_parameters.R 0000644 0001762 0000144 00000046240 14716604201 022241 0 ustar ligges users skip_if_not_installed("splines")
# make sure we have the correct interaction mark for tests
withr::with_options(
list(parameters_interaction = "*", easystats_table_width = Inf),
{
# define here because messes up the expected output
bs <- splines::bs
ns <- splines::ns
set.seed(123)
iris$cat <- sample(LETTERS[1:4], nrow(iris), replace = TRUE)
test_that("format_parameters-1", {
model <- lm(Sepal.Length ~ Species * Sepal.Width, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", Sepal.Width = "Sepal Width",
`Speciesversicolor:Sepal.Width` = "Species [versicolor] * Sepal Width",
`Speciesvirginica:Sepal.Width` = "Species [virginica] * Sepal Width"
))
})
test_that("format_parameters-2", {
model <- lm(Sepal.Length ~ Sepal.Width * Species, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Sepal.Width = "Sepal Width",
Speciesversicolor = "Species [versicolor]", Speciesvirginica = "Species [virginica]",
`Sepal.Width:Speciesversicolor` = "Sepal Width * Species [versicolor]",
`Sepal.Width:Speciesvirginica` = "Sepal Width * Species [virginica]"
))
})
test_that("format_parameters-3", {
model <- lm(Sepal.Length ~ Species * Sepal.Width * Petal.Length, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", Sepal.Width = "Sepal Width",
Petal.Length = "Petal Length", `Speciesversicolor:Sepal.Width` = "Species [versicolor] * Sepal Width",
`Speciesvirginica:Sepal.Width` = "Species [virginica] * Sepal Width",
`Speciesversicolor:Petal.Length` = "Species [versicolor] * Petal Length",
`Speciesvirginica:Petal.Length` = "Species [virginica] * Petal Length",
`Sepal.Width:Petal.Length` = "Sepal Width * Petal Length",
`Speciesversicolor:Sepal.Width:Petal.Length` = "(Species [versicolor] * Sepal Width) * Petal Length",
`Speciesvirginica:Sepal.Width:Petal.Length` = "(Species [virginica] * Sepal Width) * Petal Length"
))
})
test_that("format_parameters-4", {
model <- lm(Sepal.Length ~ Species * cat * Petal.Length, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", catB = "cat [B]", catC = "cat [C]",
catD = "cat [D]", Petal.Length = "Petal Length", `Speciesversicolor:catB` = "Species [versicolor] * cat [B]",
`Speciesvirginica:catB` = "Species [virginica] * cat [B]",
`Speciesversicolor:catC` = "Species [versicolor] * cat [C]",
`Speciesvirginica:catC` = "Species [virginica] * cat [C]",
`Speciesversicolor:catD` = "Species [versicolor] * cat [D]",
`Speciesvirginica:catD` = "Species [virginica] * cat [D]",
`Speciesversicolor:Petal.Length` = "Species [versicolor] * Petal Length",
`Speciesvirginica:Petal.Length` = "Species [virginica] * Petal Length",
`catB:Petal.Length` = "cat [B] * Petal Length", `catC:Petal.Length` = "cat [C] * Petal Length",
`catD:Petal.Length` = "cat [D] * Petal Length",
`Speciesversicolor:catB:Petal.Length` = "(Species [versicolor] * cat [B]) * Petal Length",
`Speciesvirginica:catB:Petal.Length` = "(Species [virginica] * cat [B]) * Petal Length",
`Speciesversicolor:catC:Petal.Length` = "(Species [versicolor] * cat [C]) * Petal Length",
`Speciesvirginica:catC:Petal.Length` = "(Species [virginica] * cat [C]) * Petal Length",
`Speciesversicolor:catD:Petal.Length` = "(Species [versicolor] * cat [D]) * Petal Length",
`Speciesvirginica:catD:Petal.Length` = "(Species [virginica] * cat [D]) * Petal Length"
))
})
test_that("format_parameters-5", {
model <- lm(Sepal.Length ~ Species / Petal.Length, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", `Speciessetosa:Petal.Length` = "Species [setosa] * Petal Length",
`Speciesversicolor:Petal.Length` = "Species [versicolor] * Petal Length",
`Speciesvirginica:Petal.Length` = "Species [virginica] * Petal Length"
))
})
test_that("format_parameters-6", {
model <- lm(Sepal.Length ~ Petal.Length + (Species / Sepal.Width), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
Speciesversicolor = "Species [versicolor]", Speciesvirginica = "Species [virginica]",
`Speciessetosa:Sepal.Width` = "Species [setosa] * Sepal Width",
`Speciesversicolor:Sepal.Width` = "Species [versicolor] * Sepal Width",
`Speciesvirginica:Sepal.Width` = "Species [virginica] * Sepal Width"
))
})
test_that("format_parameters-7", {
model <- lm(Sepal.Length ~ Species / Petal.Length * Sepal.Width, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", Sepal.Width = "Sepal Width",
`Speciessetosa:Petal.Length` = "Species [setosa] * Petal Length",
`Speciesversicolor:Petal.Length` = "Species [versicolor] * Petal Length",
`Speciesvirginica:Petal.Length` = "Species [virginica] * Petal Length",
`Speciesversicolor:Sepal.Width` = "Species [versicolor] * Sepal Width",
`Speciesvirginica:Sepal.Width` = "Species [virginica] * Sepal Width",
`Speciessetosa:Petal.Length:Sepal.Width` = "Species [setosa] * Petal Length * Sepal Width",
`Speciesversicolor:Petal.Length:Sepal.Width` = "Species [versicolor] * Petal Length * Sepal Width",
`Speciesvirginica:Petal.Length:Sepal.Width` = "Species [virginica] * Petal Length * Sepal Width"
))
})
test_that("format_parameters-8", {
model <- lm(Sepal.Length ~ Species / (Petal.Length * Sepal.Width), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", `Speciessetosa:Petal.Length` = "Species [setosa] * Petal Length",
`Speciesversicolor:Petal.Length` = "Species [versicolor] * Petal Length",
`Speciesvirginica:Petal.Length` = "Species [virginica] * Petal Length",
`Speciessetosa:Sepal.Width` = "Species [setosa] * Sepal Width",
`Speciesversicolor:Sepal.Width` = "Species [versicolor] * Sepal Width",
`Speciesvirginica:Sepal.Width` = "Species [virginica] * Sepal Width",
`Speciessetosa:Petal.Length:Sepal.Width` = "Species [setosa] * Petal Length * Sepal Width",
`Speciesversicolor:Petal.Length:Sepal.Width` = "Species [versicolor] * Petal Length * Sepal Width",
`Speciesvirginica:Petal.Length:Sepal.Width` = "Species [virginica] * Petal Length * Sepal Width"
))
})
test_that("format_parameters-9", {
model <- lm(Sepal.Length ~ Petal.Length + (Species / (Sepal.Width * Petal.Width)), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
Speciesversicolor = "Species [versicolor]", Speciesvirginica = "Species [virginica]",
`Speciessetosa:Sepal.Width` = "Species [setosa] * Sepal Width",
`Speciesversicolor:Sepal.Width` = "Species [versicolor] * Sepal Width",
`Speciesvirginica:Sepal.Width` = "Species [virginica] * Sepal Width",
`Speciessetosa:Petal.Width` = "Species [setosa] * Petal Width",
`Speciesversicolor:Petal.Width` = "Species [versicolor] * Petal Width",
`Speciesvirginica:Petal.Width` = "Species [virginica] * Petal Width",
`Speciessetosa:Sepal.Width:Petal.Width` = "Species [setosa] * Sepal Width * Petal Width",
`Speciesversicolor:Sepal.Width:Petal.Width` = "Species [versicolor] * Sepal Width * Petal Width",
`Speciesvirginica:Sepal.Width:Petal.Width` = "Species [virginica] * Sepal Width * Petal Width"
))
})
test_that("format_parameters-10", {
model <- lm(Sepal.Length ~ Species + poly(Sepal.Width, 2), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", `poly(Sepal.Width, 2)1` = "Sepal Width [1st degree]",
`poly(Sepal.Width, 2)2` = "Sepal Width [2nd degree]"
))
})
test_that("format_parameters-11", {
model <- lm(Sepal.Length ~ Species + poly(Sepal.Width, 2, raw = TRUE), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Speciesversicolor = "Species [versicolor]",
Speciesvirginica = "Species [virginica]", `poly(Sepal.Width, 2, raw = TRUE)1` = "Sepal Width [1st degree]",
`poly(Sepal.Width, 2, raw = TRUE)2` = "Sepal Width [2nd degree]"
))
})
test_that("format_parameters-12", {
model <- lm(Sepal.Length ~ Petal.Length * bs(Petal.Width), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
`bs(Petal.Width)1` = "Petal Width [1st degree]",
`bs(Petal.Width)2` = "Petal Width [2nd degree]",
`bs(Petal.Width)3` = "Petal Width [3rd degree]",
`Petal.Length:bs(Petal.Width)1` = "Petal Length * Petal Width [1st degree]",
`Petal.Length:bs(Petal.Width)2` = "Petal Length * Petal Width [2nd degree]",
`Petal.Length:bs(Petal.Width)3` = "Petal Length * Petal Width [3rd degree]"
))
})
test_that("format_parameters-13", {
model <- lm(Sepal.Length ~ Petal.Length * bs(Petal.Width, degree = 4), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
`bs(Petal.Width, degree = 4)1` = "Petal Width [1st degree]",
`bs(Petal.Width, degree = 4)2` = "Petal Width [2nd degree]",
`bs(Petal.Width, degree = 4)3` = "Petal Width [3rd degree]",
`bs(Petal.Width, degree = 4)4` = "Petal Width [4th degree]",
`Petal.Length:bs(Petal.Width, degree = 4)1` = "Petal Length * Petal Width [1st degree]",
`Petal.Length:bs(Petal.Width, degree = 4)2` = "Petal Length * Petal Width [2nd degree]",
`Petal.Length:bs(Petal.Width, degree = 4)3` = "Petal Length * Petal Width [3rd degree]",
`Petal.Length:bs(Petal.Width, degree = 4)4` = "Petal Length * Petal Width [4th degree]"
))
})
test_that("format_parameters-14", {
model <- lm(Sepal.Length ~ Petal.Length * ns(Petal.Width, df = 3), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
`ns(Petal.Width, df = 3)1` = "Petal Width [1st degree]",
`ns(Petal.Width, df = 3)2` = "Petal Width [2nd degree]",
`ns(Petal.Width, df = 3)3` = "Petal Width [3rd degree]",
`Petal.Length:ns(Petal.Width, df = 3)1` = "Petal Length * Petal Width [1st degree]",
`Petal.Length:ns(Petal.Width, df = 3)2` = "Petal Length * Petal Width [2nd degree]",
`Petal.Length:ns(Petal.Width, df = 3)3` = "Petal Length * Petal Width [3rd degree]"
))
})
test_that("format_parameters-15", {
model <- lm(Sepal.Length ~ Petal.Length * I(Petal.Width^2), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
`I(Petal.Width^2)` = "Petal Width^2", `Petal.Length:I(Petal.Width^2)` = "Petal Length * Petal Width^2"
))
})
test_that("format_parameters-16", {
model <- lm(Sepal.Length ~ Petal.Length * as.factor(Species), data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", Petal.Length = "Petal Length",
`as.factor(Species)versicolor` = "Species [versicolor]", `as.factor(Species)virginica` = "Species [virginica]",
`Petal.Length:as.factor(Species)versicolor` = "Petal Length * Species [versicolor]",
`Petal.Length:as.factor(Species)virginica` = "Petal Length * Species [virginica]"
))
})
test_that("format_parameters-17", {
skip_if_not_installed("pscl")
data("bioChemists", package = "pscl")
model <- pscl::zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists)
fp <- format_parameters(model)
expect_identical(fp, c(
`count_(Intercept)` = "(Intercept)", count_femWomen = "fem [Women]",
count_marMarried = "mar [Married]", count_kid5 = "kid5", count_ment = "ment",
`zero_(Intercept)` = "(Intercept)", zero_kid5 = "kid5", zero_phd = "phd"
))
})
test_that("format_parameters-18", {
data(iris)
levels(iris$Species) <- c("Species verti", "No Specieses", "Yes (Species)")
model <- lm(Sepal.Length ~ Species * Petal.Width, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", `SpeciesNo Specieses` = "Species [No Specieses]",
`SpeciesYes (Species)` = "Species [Yes (Species)]", Petal.Width = "Petal Width",
`SpeciesNo Specieses:Petal.Width` = "Species [No Specieses] * Petal Width",
`SpeciesYes (Species):Petal.Width` = "Species [Yes (Species)] * Petal Width"
))
})
test_that("format_parameters-19", {
data(mtcars)
m1 <- lm(mpg ~ qsec:wt + wt:drat, data = mtcars)
m2 <- lm(mpg ~ qsec:wt + wt / drat, data = mtcars)
m3 <- lm(mpg ~ qsec:wt + wt:drat + wt, data = mtcars)
m4 <- lm(mpg ~ qsec:wt + wt / drat + wt, data = mtcars)
m5 <- lm(mpg ~ qsec * wt + wt:drat + wt, data = mtcars)
m6 <- lm(mpg ~ wt + qsec + wt:qsec, data = mtcars)
expect_identical(
format_parameters(m1),
c(`(Intercept)` = "(Intercept)", `qsec:wt` = "qsec * wt", `wt:drat` = "wt * drat")
)
expect_identical(
format_parameters(m2),
c(`(Intercept)` = "(Intercept)", wt = "wt", `qsec:wt` = "qsec * wt", `wt:drat` = "wt * drat")
)
expect_identical(
format_parameters(m3),
c(`(Intercept)` = "(Intercept)", wt = "wt", `qsec:wt` = "qsec * wt", `wt:drat` = "wt * drat")
)
expect_identical(
format_parameters(m4),
c(`(Intercept)` = "(Intercept)", wt = "wt", `qsec:wt` = "qsec * wt", `wt:drat` = "wt * drat")
)
expect_identical(
format_parameters(m5),
c(`(Intercept)` = "(Intercept)", qsec = "qsec", wt = "wt", `qsec:wt` = "qsec * wt", `wt:drat` = "wt * drat")
)
expect_identical(
format_parameters(m6),
c(`(Intercept)` = "(Intercept)", wt = "wt", qsec = "qsec", `wt:qsec` = "wt * qsec")
)
})
test_that("format_parameters-20", {
data(iris)
levels(iris$Species) <- c("Yes (Species)", "Species.verti", "No_Specieses")
model <- lm(Sepal.Length ~ Species + Petal.Width, data = iris)
fp <- format_parameters(model)
expect_identical(fp, c(
`(Intercept)` = "(Intercept)", SpeciesSpecies.verti = "Species [Species.verti]",
SpeciesNo_Specieses = "Species [No_Specieses]", Petal.Width = "Petal Width"
))
})
test_that("format_parameters-labelled data-1", {
data(efc, package = "datawizard", envir = globalenv())
m <- lm(neg_c_7 ~ e42dep + c172code, data = efc)
mp <- model_parameters(m, verbose = FALSE)
out <- utils::capture.output(print(mp, pretty_names = "labels"))
expect_identical(
insight::trim_ws(unlist(strsplit(out[4], "|", fixed = TRUE))[1]),
"elder's dependency [slightly dependent]"
)
expect_identical(
insight::trim_ws(unlist(strsplit(out[5], "|", fixed = TRUE))[1]),
"elder's dependency [moderately dependent]"
)
out <- utils::capture.output(print(mp))
expect_identical(
insight::trim_ws(unlist(strsplit(out[4], "|", fixed = TRUE))[1]),
"e42dep [2]"
)
expect_identical(
insight::trim_ws(unlist(strsplit(out[5], "|", fixed = TRUE))[1]),
"e42dep [3]"
)
})
test_that("format_parameters-labelled data-2", {
data(iris)
m <- lm(Sepal.Width ~ Species + Sepal.Length, data = iris)
mp <- model_parameters(m, verbose = FALSE)
out <- utils::capture.output(print(mp, pretty_names = "labels"))
expect_identical(
insight::trim_ws(unlist(strsplit(out[4], "|", fixed = TRUE))[1]),
"Species [versicolor]"
)
expect_identical(
insight::trim_ws(unlist(strsplit(out[5], "|", fixed = TRUE))[1]),
"Species [virginica]"
)
out <- utils::capture.output(print(mp))
expect_identical(
insight::trim_ws(unlist(strsplit(out[4], "|", fixed = TRUE))[1]),
"Species [versicolor]"
)
expect_identical(
insight::trim_ws(unlist(strsplit(out[5], "|", fixed = TRUE))[1]),
"Species [virginica]"
)
})
test_that("format_parameters-labelled data-3", {
data(efc, package = "datawizard", envir = globalenv())
m <- lm(neg_c_7 ~ e42dep * c12hour, data = efc)
mp <- model_parameters(m, verbose = FALSE)
out <- utils::capture.output(print(mp, pretty_names = "labels"))
expect_identical(
insight::trim_ws(unlist(strsplit(out[4], "|", fixed = TRUE))[1]),
"elder's dependency [slightly dependent]"
)
expect_identical(
insight::trim_ws(unlist(strsplit(out[8], "|", fixed = TRUE))[1]),
"elder's dependency [slightly dependent] * average number of hours of care per week"
)
out <- utils::capture.output(print(mp))
expect_identical(
insight::trim_ws(unlist(strsplit(out[4], "|", fixed = TRUE))[1]),
"e42dep [2]"
)
expect_identical(
insight::trim_ws(unlist(strsplit(out[8], "|", fixed = TRUE))[1]),
"e42dep [2] * c12hour"
)
})
test_that("format_parameters, cut", {
data(mtcars)
mtcars$grp <- cut(mtcars$mpg, breaks = c(0, 15, 20, 50))
out <- model_parameters(lm(wt ~ grp, data = mtcars))
expect_equal(
attributes(out)$pretty_names,
c(
`(Intercept)` = "(Intercept)", `grp(15,20]` = "grp [>15-20]",
`grp(20,50]` = "grp [>20-50]"
),
ignore_attr = TRUE
)
expect_identical(out$Parameter, c("(Intercept)", "grp(15,20]", "grp(20,50]"))
})
}
)
parameters/tests/testthat/test-GLMMadaptive.R 0000644 0001762 0000144 00000010164 14736731407 021007 0 ustar ligges users skip_on_cran()
skip_if_not_installed("lme4")
skip_if_not_installed("GLMMadaptive")
skip_if_not_installed("glmmTMB")
data("fish")
data("cbpp", package = "lme4")
m1 <- GLMMadaptive::mixed_model(
count ~ child + camper,
random = ~ 1 | persons,
zi_fixed = ~ child + livebait,
data = fish,
family = GLMMadaptive::zi.poisson()
)
m2 <- GLMMadaptive::mixed_model(
cbind(incidence, size - incidence) ~ period,
random = ~ 1 | herd,
data = cbpp,
family = binomial
)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(0.08708, -1.35715, 0.58599, -0.99993, 0.75543, -2.1166),
tolerance = 1e-3
)
expect_equal(
ci(m1, component = "cond")$CI_low,
c(0.08708, -1.35715, 0.58599),
tolerance = 1e-3
)
expect_equal(
ci(m1, component = "zi")$CI_low,
c(-0.99993, 0.75543, -2.1166),
tolerance = 1e-3
)
expect_equal(
ci(m2)$CI_low,
c(-1.8572, -1.59265, -1.76827, -2.41754),
tolerance = 1e-3
)
expect_equal(
ci(m2, component = "cond")$CI_low,
c(-1.8572, -1.59265, -1.76827, -2.41754),
tolerance = 1e-3
)
expect_null(suppressMessages(ci(m2, component = "zi")))
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.540016, 0.094847, 0.09356, 0.468122, 0.29416, 0.507634),
tolerance = 1e-3
)
expect_equal(
standard_error(m1, component = "cond")$SE,
c(0.540016, 0.094847, 0.09356),
tolerance = 1e-3
)
expect_equal(
standard_error(m1, component = "zi")$SE,
c(0.468122, 0.29416, 0.507634),
tolerance = 1e-3
)
expect_equal(
standard_error(m2)$SE,
c(0.233543, 0.306776, 0.326777, 0.427606),
tolerance = 1e-3
)
expect_equal(
standard_error(m2, component = "cond")$SE,
c(0.233543, 0.306776, 0.326777, 0.427606),
tolerance = 1e-3
)
expect_null(suppressMessages(standard_error(m2, component = "zi")))
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0.0339, 0, 0, 0.86023, 1e-05, 0.02713),
tolerance = 1e-3
)
expect_equal(
p_value(m1, component = "cond")$p,
c(0.0339, 0, 0),
tolerance = 1e-3
)
expect_equal(
p_value(m1, component = "zi")$p,
c(0.86023, 1e-05, 0.02713),
tolerance = 1e-3
)
expect_equal(
p_value(m2)$p,
c(0, 0.00123, 0.00056, 0.00022),
tolerance = 1e-3
)
expect_equal(
p_value(m2, component = "cond")$p,
c(0, 0.00123, 0.00056, 0.00022),
tolerance = 1e-3
)
expect_null(suppressMessages(p_value(m2, component = "zi")))
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1, effects = "fixed")$Coefficient,
c(1.14549, -1.17125, 0.76937, -0.08243, 1.33197, -1.12165),
tolerance = 1e-3
)
expect_equal(
model_parameters(m2, effects = "fixed")$Coefficient,
c(-1.39946, -0.99138, -1.1278, -1.57945),
tolerance = 1e-3
)
})
test_that("model_parameters.mixed-ran_pars", {
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not_installed("glmmTMB")
data("Salamanders", package = "glmmTMB")
model <- GLMMadaptive::mixed_model(
count ~ spp + mined,
random = ~ DOY | site,
zi_fixed = ~ spp + mined,
zi_random = ~ DOP | site,
family = GLMMadaptive::zi.negative.binomial(),
data = Salamanders,
control = list(nAGQ = 1)
)
params <- model_parameters(model, effects = "random")
expect_identical(c(nrow(params), ncol(params)), c(7L, 9L))
expect_identical(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Effects", "Group", "Component")
)
expect_identical(
params$Parameter,
c(
"SD (Intercept)", "SD (DOY)", "Cor (Intercept~DOY)", "SD (Observations)",
"SD (Intercept)", "SD (DOP)", "Cor (Intercept~DOP)"
)
)
expect_identical(
params$Component,
c(
"conditional", "conditional", "conditional", "conditional",
"zero_inflated", "zero_inflated", "zero_inflated"
)
)
expect_equal(
params$Coefficient,
c(0.56552, 0.29951, 0.06307, 1.61936, 1.02233, 0.38209, -0.17162),
tolerance = 1e-2
)
})
parameters/tests/testthat/test-tobit.R 0000644 0001762 0000144 00000001464 14413515226 017650 0 ustar ligges users skip_if_not_installed("AER")
data("Affairs", package = "AER")
m1 <- AER::tobit(
affairs ~ age + yearsmarried + religiousness + occupation + rating,
data = Affairs
)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(2.80106, -0.33435, 0.29049, -2.47756, -0.17261, -3.0843),
tolerance = 1e-4
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(2.74145, 0.07909, 0.13452, 0.40375, 0.25442, 0.40783),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0.00287, 0.02337, 4e-05, 3e-05, 0.20001, 0),
tolerance = 1e-4
)
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
c(8.1742, -0.17933, 0.55414, -1.68622, 0.32605, -2.28497),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-robust.R 0000644 0001762 0000144 00000033655 14736731407 020065 0 ustar ligges users skip_if_not_installed("sandwich")
skip_on_cran()
# standard errors -------------------------------------
test_that("robust-se glm warn with profile-CI", {
mglm <- glm(mpg ~ wt, data = mtcars)
expect_message(
ci(mglm, vcov = "HC3"),
regex = "available"
)
expect_message(
model_parameters(mglm, vcov = "HC3", ci_method = "profile"),
regex = "modifies"
)
})
# standard errors -------------------------------------
test_that("robust-se lm", {
m <- lm(Petal.Length ~ Sepal.Length * Species, data = iris)
se1 <- standard_error(m, vcov = "HC")
se2 <- sqrt(diag(sandwich::vcovHC(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-se polr", {
skip_if_not_installed("MASS")
data(housing, package = "MASS")
m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
se1 <- standard_error(m, vcov = "vcovCL")
se2 <- sqrt(diag(sandwich::vcovCL(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
se1 <- standard_error(m, vcov = "vcovOPG")
se2 <- sqrt(diag(sandwich::vcovOPG(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-se zeroinfl", {
skip_if_not_installed("pscl")
skip_if_not_installed("clubSandwich")
data("bioChemists", package = "pscl")
m <- pscl::zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists)
se1 <- standard_error(m, vcov = "vcovCL")
se2 <- sqrt(diag(sandwich::vcovCL(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
se1 <- standard_error(m, vcov = "vcovOPG")
se2 <- sqrt(diag(sandwich::vcovOPG(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-se ivreg", {
skip_if_not_installed("AER")
skip_if_not_installed("clubSandwich")
data(CigarettesSW, package = "AER")
CigarettesSW$rprice <- with(CigarettesSW, price / cpi)
CigarettesSW$rincome <- with(CigarettesSW, income / population / cpi)
CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax) / cpi)
m <- AER::ivreg(
log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax / cpi),
data = CigarettesSW,
subset = year == "1995"
)
se1 <- standard_error(m, vcov = "vcovCL")
se2 <- sqrt(diag(sandwich::vcovCL(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
se1 <- standard_error(m, vcov = "vcovOPG")
se2 <- sqrt(diag(sandwich::vcovOPG(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-se survival", {
skip_if_not_installed("survival")
set.seed(123)
m <- survival::survreg(
formula = survival::Surv(futime, fustat) ~ ecog.ps + rx,
data = survival::ovarian,
dist = "logistic"
)
se1 <- standard_error(m, vcov = "vcovOPG")
se2 <- sqrt(diag(sandwich::vcovOPG(m)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
})
# p-values -------------------------------------
test_that("robust-p lm", {
m <- lm(Petal.Length ~ Sepal.Length * Species, data = iris)
p1 <- p_value(m, vcov = "HC")
# robust p manually
se <- sqrt(diag(sandwich::vcovHC(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- coef(m) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-p polr", {
skip_if_not_installed("MASS")
data(housing, package = "MASS")
m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
p1 <- p_value(m, vcov = "vcovCL")
# robust p manually
se <- sqrt(diag(sandwich::vcovCL(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- c(m$coefficients, m$zeta) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
p1 <- p_value(m, vcov = "vcovOPG")
# robust p manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- c(m$coefficients, m$zeta) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-p ivreg", {
skip_if_not_installed("AER")
data(CigarettesSW, package = "AER")
CigarettesSW$rprice <- with(CigarettesSW, price / cpi)
CigarettesSW$rincome <- with(CigarettesSW, income / population / cpi)
CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax) / cpi)
m <- AER::ivreg(
log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax / cpi),
data = CigarettesSW,
subset = year == "1995"
)
p1 <- p_value(m, vcov = "vcovCL")
# robust p manually
se <- sqrt(diag(sandwich::vcovCL(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- coef(m) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
p1 <- p_value(m, vcov = "vcovOPG")
# robust p manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- coef(m) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-p zeroinfl", {
skip_if_not_installed("pscl")
data("bioChemists", package = "pscl")
m <- pscl::zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists)
p1 <- p_value(m, vcov = "vcovCL")
# robust p manually
se <- sqrt(diag(sandwich::vcovCL(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- coef(m) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
p1 <- p_value(m, vcov = "vcovOPG")
# robust p manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- coef(m) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-p survival", {
skip_if_not_installed("survival")
set.seed(123)
m <- survival::survreg(
formula = survival::Surv(futime, fustat) ~ ecog.ps + rx,
data = survival::ovarian,
dist = "logistic"
)
p1 <- p_value(m, vcov = "vcovOPG")
# robust p manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- insight::get_parameters(m)$Estimate / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
})
# CI -------------------------------------
test_that("robust-ci lm", {
data(iris)
m <- lm(Petal.Length ~ Sepal.Length * Species, data = iris)
ci1 <- ci(m, vcov = "HC")
# robust CI manually
params <- insight::get_parameters(m)
se <- sqrt(diag(sandwich::vcovHC(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = params$Estimate - se * fac,
CI_high = params$Estimate + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-ci polr", {
skip_if_not_installed("MASS")
data(housing, package = "MASS")
m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
ci1 <- ci(m, vcov = "vcovCL")
# robust CI manually
se <- sqrt(diag(sandwich::vcovCL(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = c(m$coefficients, m$zeta) - se * fac,
CI_high = c(m$coefficients, m$zeta) + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
ci1 <- ci(m, vcov = "vcovOPG")
# robust CI manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = c(m$coefficients, m$zeta) - se * fac,
CI_high = c(m$coefficients, m$zeta) + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-ci ivreg", {
skip_if_not_installed("AER")
data(CigarettesSW, package = "AER")
CigarettesSW$rprice <- with(CigarettesSW, price / cpi)
CigarettesSW$rincome <- with(CigarettesSW, income / population / cpi)
CigarettesSW$tdiff <- with(CigarettesSW, (taxs - tax) / cpi)
m <- AER::ivreg(
log(packs) ~ log(rprice) + log(rincome) | log(rincome) + tdiff + I(tax / cpi),
data = CigarettesSW,
subset = year == "1995"
)
ci1 <- ci(m, vcov = "vcovCL")
# robust CI manually
se <- sqrt(diag(sandwich::vcovCL(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = coef(m) - se * fac,
CI_high = coef(m) + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
ci1 <- ci(m, vcov = "vcovOPG")
# robust CI manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = coef(m) - se * fac,
CI_high = coef(m) + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-ci zeroinfl", {
skip_if_not_installed("pscl")
data("bioChemists", package = "pscl")
m <- pscl::zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists)
ci1 <- ci(m, vcov = "vcovCL")
# robust CI manually
se <- sqrt(diag(sandwich::vcovCL(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = coef(m) - se * fac,
CI_high = coef(m) + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
ci1 <- ci(m, vcov = "vcovOPG")
# robust CI manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = coef(m) - se * fac,
CI_high = coef(m) + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-ci survival", {
skip_if_not_installed("survival")
set.seed(123)
m <- survival::survreg(
formula = survival::Surv(futime, fustat) ~ ecog.ps + rx,
data = survival::ovarian,
dist = "logistic"
)
ci1 <- ci(m, vcov = "vcovOPG")
# robust CI manually
se <- sqrt(diag(sandwich::vcovOPG(m)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = insight::get_parameters(m)$Estimate - se * fac,
CI_high = insight::get_parameters(m)$Estimate + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
})
# mixed models ----------------------
skip_if_not_installed("clubSandwich")
skip_if_not_installed("lme4")
test_that("robust-se lmer", {
data(iris)
set.seed(1234)
iris$grp <- as.factor(sample.int(3, nrow(iris), replace = TRUE))
m <- lme4::lmer(
Sepal.Length ~ Species * Sepal.Width + Petal.Length + (1 | grp),
data = iris
)
se1 <- standard_error(m, vcov = "vcovCR", vcov_args = list(type = "CR1", cluster = iris$grp))
se2 <- sqrt(diag(clubSandwich::vcovCR(m, type = "CR1", cluster = iris$grp)))
expect_equal(se1$SE, se2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-p lmer", {
data(iris)
set.seed(1234)
iris$grp <- as.factor(sample.int(3, nrow(iris), replace = TRUE))
m <- lme4::lmer(
Sepal.Length ~ Species * Sepal.Width + Petal.Length + (1 | grp),
data = iris
)
p1 <- p_value(m, vcov = "vcovCR", vcov_args = list(type = "CR1", cluster = iris$grp))
se <- sqrt(diag(clubSandwich::vcovCR(m, type = "CR1", cluster = iris$grp)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
stat <- lme4::fixef(m) / se
p2 <- 2 * pt(abs(stat), df = dof, lower.tail = FALSE)
expect_equal(p1$p, p2, tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust-ci lmer", {
data(iris)
set.seed(1234)
iris$grp <- as.factor(sample.int(3, nrow(iris), replace = TRUE))
m <- lme4::lmer(
Sepal.Length ~ Species * Sepal.Width + Petal.Length + (1 | grp),
data = iris
)
ci1 <- ci(m, vcov = "vcovCR", vcov_args = list(type = "CR1", cluster = iris$grp))
# robust CI manually
params <- insight::get_parameters(m)
se <- sqrt(diag(clubSandwich::vcovCR(m, type = "CR1", cluster = iris$grp)))
dof <- degrees_of_freedom(m, method = "wald", verbose = FALSE)
fac <- suppressWarnings(stats::qt(0.975, df = dof))
ci2 <- as.data.frame(cbind(
CI_low = params$Estimate - se * fac,
CI_high = params$Estimate + se * fac
))
expect_equal(ci1$CI_low, ci2$CI_low, tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(ci1$CI_high, ci2$CI_high, tolerance = 1e-4, ignore_attr = TRUE)
})
parameters/tests/testthat/test-model_parameters.blmerMod.R 0000644 0001762 0000144 00000002231 14716604201 023601 0 ustar ligges users skip_if_not_installed("blme")
skip_if_not_installed("lme4")
data(sleepstudy, package = "lme4")
set.seed(123)
model <- blme::blmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy, cov.prior = NULL)
test_that("model_parameters.blmerMod", {
params <- model_parameters(model, effects = "fixed")
expect_equal(params$SE, c(6.8246, 1.54579), tolerance = 1e-3)
expect_named(
params,
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Effects")
)
})
test_that("model_parameters.blmerMod-all", {
skip_if_not_installed("merDeriv")
params <- model_parameters(model, effects = "all")
expect_equal(params$SE, c(6.8246, 1.54579, 5.83626, 1.24804, 0.31859, 1.50801), tolerance = 1e-3)
expect_equal(params$Coefficient, c(251.4051, 10.46729, 24.74066, 5.92214, 0.06555, 25.5918), tolerance = 1e-3)
expect_named(
params,
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Effects", "Group")
)
expect_identical(
params$Parameter,
c("(Intercept)", "Days", "SD (Intercept)", "SD (Days)", "Cor (Intercept~Days)", "SD (Observations)")
)
})
parameters/tests/testthat/test-random_effects_ci-glmmTMB.R 0000644 0001762 0000144 00000023577 14716604201 023465 0 ustar ligges users # Test Setup --------------------------------
skip_on_os(c("mac", "linux", "solaris"))
skip_if_not_installed("glmmTMB", minimum_version = "1.1.5")
skip_if_not_installed("lme4")
skip_on_cran()
# tests --------------------------------
## TODO also check messages for profiled CI
data(sleepstudy, package = "lme4")
data(cake, package = "lme4")
set.seed(123)
sleepstudy$Months <- sample.int(4, nrow(sleepstudy), TRUE)
set.seed(123)
m1 <- suppressWarnings(glmmTMB::glmmTMB(
angle ~ temperature + (temperature | recipe) + (temperature | replicate),
data = cake
))
m2 <- glmmTMB::glmmTMB(Reaction ~ Days + (Days | Subject), data = sleepstudy)
m3 <- suppressWarnings(glmmTMB::glmmTMB(angle ~ temperature + (temperature | recipe), data = cake))
m4 <- suppressWarnings(glmmTMB::glmmTMB(angle ~ temperature + (temperature | replicate), data = cake))
m5 <- suppressWarnings(glmmTMB::glmmTMB(Reaction ~ Days + (Days + Months | Subject), data = sleepstudy))
set.seed(123)
expect_message(
{
mp1 <- model_parameters(m1, ci_random = TRUE)
},
"singularity"
)
mp2 <- model_parameters(m2, ci_random = TRUE) # works
expect_message(
{
mp3 <- model_parameters(m3, ci_random = TRUE)
},
"singularity"
) # no SE/CI
mp4 <- model_parameters(m4, ci_random = TRUE)
expect_message(
{
mp5 <- model_parameters(m5, ci_random = TRUE)
},
"singularity"
) # no SE/CI
test_that("random effects CIs, two slopes, categorical", {
## FIXME: Results differ across R versions, no idea why...
# expect_equal(
# mp1$CI_low,
# c(
# 28.91277, 5.03129, -1.87302, -2.42033, -3.2702, -2.57721, 0.2157,
# 4.20738, NaN, NaN, 0.26244, 0.34083, 0.02479, 0.66487, 0.40589,
# 0.15295, 0.01405, 0.62939, -0.99996, -0.41209, NaN, NaN, NaN,
# -0.40223, NaN, NaN, NaN, NaN, NA, NA, NA, NA, NA, NA, NA, NA,
# NA, NaN, NA, NA, NA, NA, NA, NA, NA, NA, NA, NaN, 4.12596
# ),
# tolerance = 1e-2,
# ignore_attr = TRUE
# )
expect_identical(
mp1$Parameter,
c(
"(Intercept)", "temperature.L", "temperature.Q", "temperature.C",
"temperature^4", "temperature^5", "SD (Intercept)", "SD (Intercept)",
"SD (temperature.L)", "SD (temperature.Q)", "SD (temperature.C)",
"SD (temperature^4)", "SD (temperature^5)", "SD (temperature.L)",
"SD (temperature.Q)", "SD (temperature.C)", "SD (temperature^4)",
"SD (temperature^5)", "Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (Intercept~temperature.L)",
"Cor (Intercept~temperature.Q)", "Cor (Intercept~temperature.C)",
"Cor (Intercept~temperature^4)", "Cor (Intercept~temperature^5)",
"Cor (temperature.L~temperature.Q)", "Cor (temperature.L~temperature.C)",
"Cor (temperature.L~temperature^4)", "Cor (temperature.L~temperature^5)",
"Cor (temperature.Q~temperature.C)", "Cor (temperature.Q~temperature^4)",
"Cor (temperature.Q~temperature^5)", "Cor (temperature.C~temperature^4)",
"Cor (temperature.C~temperature^5)", "Cor (temperature^4~temperature^5)",
"Cor (temperature.L~temperature.Q)", "Cor (temperature.L~temperature.C)",
"Cor (temperature.L~temperature^4)", "Cor (temperature.L~temperature^5)",
"Cor (temperature.Q~temperature.C)", "Cor (temperature.Q~temperature^4)",
"Cor (temperature.Q~temperature^5)", "Cor (temperature.C~temperature^4)",
"Cor (temperature.C~temperature^5)", "Cor (temperature^4~temperature^5)",
"SD (Observations)"
)
)
expect_identical(
mp1$Group,
c(
"", "", "", "", "", "", "recipe", "replicate", "recipe", "recipe",
"recipe", "recipe", "recipe", "replicate", "replicate", "replicate",
"replicate", "replicate", "recipe", "recipe", "recipe", "recipe",
"recipe", "replicate", "replicate", "replicate", "replicate",
"replicate", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "recipe", "recipe", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "Residual"
)
)
})
test_that("random effects CIs, simple slope", {
expect_equal(
mp2$CI_low,
c(238.40611, 7.52295, 15.01709, 3.80546, -0.48781, 22.80047),
tolerance = 1e-2,
ignore_attr = TRUE
)
expect_identical(
mp2$Parameter,
c(
"(Intercept)", "Days", "SD (Intercept)", "SD (Days)", "Cor (Intercept~Days)",
"SD (Observations)"
)
)
})
test_that("random effects CIs, categorical slope-1", {
## FIXME: Results differ across R versions, no idea why...
# expect_equal(
# mp3$CI_low,
# c(
# 31.20278, 4.35879, -2.63767, -2.80041, -3.54983, -3.16627,
# 0, 0, NaN, NaN, 0, 0, -1, NaN, NaN, NaN, NaN, NA, NA, NA, NA,
# NA, NA, NA, NA, NA, NaN, 7.08478
# ),
# tolerance = 1e-2,
# ignore_attr = TRUE
# )
expect_identical(
mp3$Parameter,
c(
"(Intercept)", "temperature.L", "temperature.Q", "temperature.C",
"temperature^4", "temperature^5", "SD (Intercept)", "SD (temperature.L)",
"SD (temperature.Q)", "SD (temperature.C)", "SD (temperature^4)",
"SD (temperature^5)", "Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (temperature.L~temperature.Q)",
"Cor (temperature.L~temperature.C)", "Cor (temperature.L~temperature^4)",
"Cor (temperature.L~temperature^5)", "Cor (temperature.Q~temperature.C)",
"Cor (temperature.Q~temperature^4)", "Cor (temperature.Q~temperature^5)",
"Cor (temperature.C~temperature^4)", "Cor (temperature.C~temperature^5)",
"Cor (temperature^4~temperature^5)", "SD (Observations)"
)
)
expect_identical(
mp3$Group,
c(
"", "", "", "", "", "", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "recipe", "recipe", "recipe", "recipe",
"recipe", "recipe", "recipe", "Residual"
)
)
})
test_that("random effects CIs, categorical slope-2", {
## FIXME: Results differ across R versions, no idea why...
# expect_equal(
# mp4$CI_low,
# c(
# 29.01106, 5.01248, -1.89447, -1.96271, -2.66795, -2.50896,
# 4.23401, 0.62943, 0.36949, 0.13979, 0.01129, 0.6074, 0.50155,
# -0.30497, -0.94063, -0.13156, -0.32484, NA, NA, NA, NA, NA, NA,
# NA, NA, NA, 0.42465, 4.2358
# )
# ,
# tolerance = 1e-2,
# ignore_attr = TRUE
# )
expect_identical(
mp4$Parameter,
c(
"(Intercept)", "temperature.L", "temperature.Q", "temperature.C",
"temperature^4", "temperature^5", "SD (Intercept)", "SD (temperature.L)",
"SD (temperature.Q)", "SD (temperature.C)", "SD (temperature^4)",
"SD (temperature^5)", "Cor (Intercept~temperature.L)", "Cor (Intercept~temperature.Q)",
"Cor (Intercept~temperature.C)", "Cor (Intercept~temperature^4)",
"Cor (Intercept~temperature^5)", "Cor (temperature.L~temperature.Q)",
"Cor (temperature.L~temperature.C)", "Cor (temperature.L~temperature^4)",
"Cor (temperature.L~temperature^5)", "Cor (temperature.Q~temperature.C)",
"Cor (temperature.Q~temperature^4)", "Cor (temperature.Q~temperature^5)",
"Cor (temperature.C~temperature^4)", "Cor (temperature.C~temperature^5)",
"Cor (temperature^4~temperature^5)", "SD (Observations)"
)
)
expect_identical(
mp4$Group,
c(
"", "", "", "", "", "", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "replicate", "replicate",
"replicate", "replicate", "replicate", "Residual"
)
)
})
test_that("random effects CIs, double slope", {
expect_equal(
mp5$CI_low,
c(238.40606, 7.52296, 15.0171, 3.80547, 0, -0.48781, NaN, NaN, 22.80045),
tolerance = 1e-2,
ignore_attr = TRUE
)
expect_identical(
mp5$Parameter,
c(
"(Intercept)", "Days", "SD (Intercept)", "SD (Days)", "SD (Months)",
"Cor (Intercept~Days)", "Cor (Intercept~Months)",
"Cor (Days~Months)", "SD (Observations)"
)
)
})
test_that("random effects CIs, simple slope", {
data(sleepstudy, package = "lme4")
set.seed(123)
sleepstudy$Months <- sample.int(4, nrow(sleepstudy), TRUE)
set.seed(123)
m2 <- glmmTMB::glmmTMB(Reaction ~ Days + (0 + Days | Subject), data = sleepstudy)
m5 <- suppressWarnings(glmmTMB::glmmTMB(Reaction ~ Days + (0 + Days + Months | Subject), data = sleepstudy))
set.seed(123)
mp2 <- model_parameters(m2, ci_random = TRUE)
expect_message(
{
mp5 <- model_parameters(m5, ci_random = TRUE)
},
"singularity"
) # no SE/CI
expect_equal(
mp2$CI_low,
c(243.55046, 6.89554, 4.98429, 25.94359),
tolerance = 1e-2,
ignore_attr = TRUE
)
expect_identical(
mp2$Parameter,
c("(Intercept)", "Days", "SD (Days)", "SD (Observations)")
)
## FIXME: Results differ across R versions, no idea why...
# expect_equal(
# mp5$CI_low,
# c(237.03695, 9.04139, NaN, 8.95755, NaN, 30.67054),
# tolerance = 1e-2,
# ignore_attr = TRUE
# )
expect_identical(
mp5$Parameter,
c(
"(Intercept)", "Days", "SD (Days)", "SD (Months)", "Cor (Days~Months)",
"SD (Observations)"
)
)
})
# messages for profiled CI
test_that("profiled CI messages", {
mp2 <- model_parameters(m2, ci_method = "profile")
expect_message(utils::capture.output(print(mp2)), regexp = "(.*)profile-likelihood(.*)z-distribution(.*)")
})
parameters/tests/testthat/test-n_factors.R 0000644 0001762 0000144 00000005023 14716604201 020476 0 ustar ligges users test_that("n_factors, default", {
skip_if_not_installed("nFactors")
skip_if_not_installed("psych")
set.seed(333)
x <- n_factors(mtcars[, 1:4])
expect_identical(ncol(x), 3L)
})
test_that("n_factors, EGAnet", {
skip_on_cran()
skip_if_not_installed("EGAnet")
set.seed(333)
x <- n_factors(mtcars, package = "EGAnet")
expect_identical(ncol(x), 3L)
expect_identical(
print(capture.output(x)),
c(
"# Method Agreement Procedure:",
"",
"The choice of 3 dimensions is supported by 2 (100.00%) methods out of 2 (EGA (glasso), EGA (TMFG))."
)
)
})
test_that("n_factors, EGAnet does not fail", {
skip_on_cran()
skip_if_not_installed("EGAnet")
set.seed(333)
x <- n_factors(mtcars[, 1:4], package = "EGAnet")
expect_identical(ncol(x), 3L)
expect_identical(nrow(x), 1L)
expect_identical(
print(capture.output(x)),
c(
"# Method Agreement Procedure:",
"",
"The choice of 1 dimensions is supported by 1 (100.00%) methods out of 1 (EGA (glasso))."
)
)
})
test_that("n_factors, oblimin rotation", {
skip_if_not_installed("nFactors")
skip_if_not_installed("psych")
skip_if_not_installed("GPArotation")
set.seed(333)
x <- n_factors(mtcars[, 1:4], type = "PCA", rotation = "oblimin")
expect_identical(ncol(x), 3L)
expect_identical(
print(capture.output(x)),
c(
"# Method Agreement Procedure:",
"",
"The choice of 1 dimensions is supported by 11 (84.62%) methods out of 13 (Bartlett, Anderson, Lawley, Optimal coordinates, Acceleration factor, Parallel analysis, Kaiser criterion, Scree (SE), Scree (R2), VSS complexity 1, Velicer's MAP)." # nolint
)
)
})
test_that("n_factors, no rotation, psych only", {
skip_if_not_installed("nFactors")
skip_if_not_installed("psych")
set.seed(333)
x <- n_factors(mtcars[, 1:4], rotation = "none", package = "psych")
expect_identical(ncol(x), 3L)
expect_identical(
print(capture.output(x)),
c(
"# Method Agreement Procedure:",
"",
"The choice of 1 dimensions is supported by 3 (60.00%) methods out of 5 (Velicer's MAP, BIC, BIC (adjusted))."
)
)
})
test_that("n_factors, variance explained", {
skip_on_cran()
skip_if_not_installed("nFactors")
skip_if_not_installed("psych")
set.seed(333)
x <- n_factors(mtcars[, 1:4], type = "PCA")
expect_equal(
attributes(x)$Variance_Explained$Variance_Cumulative,
c(0.84126, 0.85088, 0.85859, 0.85859),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-standardize_parameters.R 0000644 0001762 0000144 00000041057 14736731407 023275 0 ustar ligges users data("iris")
dat <<- iris
# simple ------------------------------------------------------------------
test_that("standardize_parameters (simple)", {
r <- as.numeric(cor.test(dat$Sepal.Length, dat$Petal.Length)$estimate)
model <- lm(Sepal.Length ~ Petal.Length, data = dat)
es <- standardize_parameters(model)
expect_equal(es[2, 2], r, tolerance = 0.01)
expect_error(standardize_parameters(model, robust = TRUE), NA)
})
# Robust ------------------------------------------------------------------
test_that("Robust post hoc", {
model <- lm(mpg ~ hp, weights = gear, data = mtcars)
expect_error(standardize_parameters(model, method = "basic", robust = TRUE), NA)
expect_error(standardize_parameters(model, method = "basic", robust = TRUE, two_sd = TRUE), NA)
model <- lm(mpg ~ hp, data = mtcars)
expect_error(standardize_parameters(model, method = "basic", robust = TRUE), NA)
expect_error(standardize_parameters(model, method = "basic", robust = TRUE, two_sd = TRUE), NA)
})
# Labels ------------------------------------------------------------------
test_that("Preserve labels", {
fit <- lm(Sepal.Length ~ Species, data = iris)
out <- standardize_parameters(fit)
expect_snapshot(print(out))
})
# model_parameters -------------------------------
test_that("standardize_parameters (model_parameters)", {
skip_on_cran()
model <<- lm(mpg ~ cyl + am, data = mtcars)
mp <<- model_parameters(model, effects = "fixed")
s1 <- standardize_parameters(model, method = "basic")
s2 <- standardize_parameters(mp, method = "basic")
expect_equal(s1$Parameter, s2$Parameter, tolerance = 1e-4)
expect_equal(s1$Std_Coefficient, s2$Std_Coefficient, tolerance = 1e-4)
expect_equal(s1$CI_low, s2$CI_low, tolerance = 1e-4)
expect_equal(s1$CI_high, s2$CI_high, tolerance = 1e-4)
mp_exp <<- model_parameters(model, exponentiate = TRUE, effects = "fixed")
se1 <- standardize_parameters(model, method = "basic", exponentiate = TRUE)
se2 <- standardize_parameters(mp_exp, method = "basic", exponentiate = TRUE)
expect_equal(se1$Parameter, se2$Parameter, tolerance = 1e-4)
expect_equal(se1$Std_Coefficient, se2$Std_Coefficient, tolerance = 1e-4)
expect_equal(se1$CI_low, se2$CI_low, tolerance = 1e-4)
expect_equal(se1$CI_high, se2$CI_high, tolerance = 1e-4)
})
# bootstrap_model ---------------------------------------------------------
test_that("standardize_parameters (bootstrap_model)", {
skip_on_cran()
skip_if_not_installed("boot")
m <- lm(mpg ~ factor(cyl) + hp, mtcars)
set.seed(1)
bm_draws <- bootstrap_model(m, iterations = 599)
set.seed(1)
bm_tab <- bootstrap_parameters(m, iterations = 599)
out_true <- standardize_parameters(m, method = "basic")
out_boot1 <- standardize_parameters(bm_draws, method = "basic")
out_boot2 <- standardize_parameters(bm_tab, method = "basic")
expect_equal(out_boot1$Std_Coefficient, out_true$Std_Coefficient,
tolerance = 0.05
)
expect_equal(out_boot1, out_boot2, ignore_attr = TRUE)
expect_error(standardize_parameters(bm_draws, method = "refit"))
expect_error(standardize_parameters(bm_tab, method = "refit"))
})
# lm with ci -----------------------------------
test_that("standardize_parameters (lm with ci)", {
data("iris")
model <- lm(Sepal.Length ~ Species + Petal.Width, data = iris)
expect_equal(
standardize_parameters(model, method = "refit")$Std_Coefficient,
c(0.044, -0.072, -0.060, 0.844),
tolerance = 0.01
)
expect_equal(
standardize_parameters(model, method = "posthoc")$Std_Coefficient,
c(0, -0.072, -0.060, 0.844),
tolerance = 0.01
)
expect_equal(
standardize_parameters(model, method = "smart")$Std_Coefficient,
c(0, -0.170, -0.142, 0.844),
tolerance = 0.01
)
z_basic <- standardize_parameters(model, method = "basic")
expect_equal(
z_basic$Std_Coefficient,
c(0, -0.034, -0.028, 0.844),
tolerance = 0.01
)
## CI
expect_equal(
z_basic$CI_low,
c(0, -0.294, -0.433, 0.491),
tolerance = 0.01
)
expect_equal(
z_basic$CI_high,
c(0, 0.225, 0.375, 1.196),
tolerance = 0.01
)
z_basic.0.80 <- standardize_parameters(model, ci = 0.8, method = "basic")
expect_equal(
z_basic.0.80$CI_low,
c(0, -0.203, -0.292, 0.614),
tolerance = 0.01
)
expect_equal(
z_basic.0.80$CI_high,
c(0, 0.135, 0.234, 1.073),
tolerance = 0.01
)
data("mtcars")
m0 <- lm(mpg ~ cyl + factor(am), mtcars)
expect_equal(
standardize_parameters(m0, method = "refit")[[2]][-1],
standardize_parameters(m0, method = "smart")[[2]][-1],
tolerance = 0.01
)
expect_equal(
standardize_parameters(m0, method = "refit", two_sd = TRUE)[[2]][-1],
standardize_parameters(m0, method = "smart", two_sd = TRUE)[[2]][-1],
tolerance = 0.01
)
})
# aov ---------------------------------------------------------------------
test_that("standardize_parameters (aov)", {
dat2 <- iris
dat2$Cat1 <- rep_len(c("A", "B"), nrow(dat2))
dat3 <<- dat2
m_aov <- aov(Sepal.Length ~ Species * Cat1, data = dat3)
m_lm <- lm(Sepal.Length ~ Species * Cat1, data = dat3)
expect_equal(standardize_parameters(m_aov),
standardize_parameters(m_lm),
ignore_attr = TRUE
)
})
# with function interactions" -------------------
test_that("standardize_parameters (with functions / interactions)", {
skip_on_cran()
X <- scale(rnorm(100), TRUE, FALSE)
Z <- scale(rnorm(100), TRUE, FALSE)
Y <- scale(Z + X * Z + rnorm(100), TRUE, FALSE)
m1 <- lm(Y ~ X * Z)
m2 <- lm(Y ~ X * scale(Z))
m3 <- lm(Y ~ scale(X) * Z)
m4 <- lm(Y ~ scale(X) * scale(Z))
expect_equal(
standardize_parameters(m1, method = "basic")$Std_Coefficient,
standardize_parameters(m2, method = "basic")$Std_Coefficient,
ignore_attr = TRUE
)
expect_equal(
standardize_parameters(m1, method = "basic")$Std_Coefficient,
standardize_parameters(m3, method = "basic")$Std_Coefficient,
ignore_attr = TRUE
)
# expect_equal(
# standardize_parameters(m1, method = "basic")$Std_Coefficient,
# standardize_parameters(m4, method = "basic")$Std_Coefficient
# )
# transformed resp or pred should not affect
mtcars$cyl_exp <- exp(mtcars$cyl)
mtcars$mpg_sqrt <- sqrt(mtcars$mpg)
m1 <- lm(exp(cyl) ~ am + sqrt(mpg), mtcars)
m2 <- lm(cyl_exp ~ am + mpg_sqrt, mtcars)
expect_message({
stdX <- standardize_parameters(m1, method = "refit")
})
expect_false(isTRUE(all.equal(
stdX[[2]],
standardize_parameters(m2, method = "refit")[[2]]
)))
expect_equal(
standardize_parameters(m1, method = "basic")[[2]],
standardize_parameters(m2, method = "basic")[[2]],
ignore_attr = TRUE
)
# posthoc / smart don't support data transformation
expect_message(standardize_parameters(m1, method = "smart"))
expect_message(standardize_parameters(m1, method = "posthoc"))
})
# exponentiate ------------------------------------------------------------
test_that("standardize_parameters (exponentiate)", {
mod_b <- glm(am ~ mpg + cyl + hp,
data = mtcars,
family = poisson()
)
mod_refit <- standardize_parameters(mod_b, method = "refit", exponentiate = TRUE)
expect_equal(
mod_refit[[2]][-1],
standardize_parameters(mod_b, method = "basic", exponentiate = TRUE)[[2]][-1],
ignore_attr = TRUE
)
expect_equal(
mod_refit[[2]][-1],
standardize_parameters(mod_b, method = "posthoc", exponentiate = TRUE)[[2]][-1],
ignore_attr = TRUE
)
expect_equal(
mod_refit[[2]][-1],
exp(standardize_parameters(mod_b, method = "basic")[[2]])[-1],
ignore_attr = TRUE
)
mod_b <- glm(am ~ mpg + cyl,
data = mtcars,
family = binomial()
)
mod_refit <- standardize_parameters(mod_b, method = "refit", exponentiate = TRUE)
expect_equal(
mod_refit[[2]][-1],
standardize_parameters(mod_b, method = "basic", exponentiate = TRUE)[[2]][-1],
ignore_attr = TRUE
)
expect_equal(
mod_refit[[2]][-1],
standardize_parameters(mod_b, method = "posthoc", exponentiate = TRUE)[[2]][-1],
ignore_attr = TRUE
)
expect_equal(
mod_refit[[2]][-1],
exp(standardize_parameters(mod_b, method = "basic")[[2]])[-1],
tolerance = 1e-5
)
mod_b <- glm(am ~ mpg + cyl + hp,
data = mtcars,
family = stats::gaussian()
)
mod_refit <- standardize_parameters(mod_b, method = "refit", exponentiate = TRUE)
expect_equal(
mod_refit[[2]][-1],
standardize_parameters(mod_b, method = "basic", exponentiate = TRUE)[[2]][-1],
tolerance = 1e-5
)
expect_equal(
mod_refit[[2]][-1],
standardize_parameters(mod_b, method = "posthoc", exponentiate = TRUE)[[2]][-1],
tolerance = 1e-5
)
expect_equal(
mod_refit[[2]][-1],
exp(standardize_parameters(mod_b, method = "basic")[[2]])[-1],
tolerance = 1e-5
)
})
# Bayes ----------------------------------------
test_that("standardize_parameters (Bayes)", {
skip_on_cran()
skip_if_not_installed("rstanarm")
set.seed(1234)
suppressWarnings({
model <- rstanarm::stan_glm(Sepal.Length ~ Species + Petal.Width,
data = iris,
iter = 500, refresh = 0
)
})
set.seed(1234)
expect_equal(
suppressWarnings(standardize_parameters(model, method = "refit")$Std_Median[1:4]),
c(0.03787, -0.06088, -0.04807, 0.84067),
tolerance = 0.1
)
set.seed(1234)
expect_equal(
suppressWarnings(standardize_parameters(model, method = "posthoc")$Std_Median[1:4]),
c(0, -0.0586, -0.05258, 0.83883),
tolerance = 0.01
)
posts <- standardize_posteriors(model, method = "posthoc")
expect_identical(dim(posts), c(1000L, 4L))
expect_s3_class(posts, "data.frame")
})
# Pseudo - GLMM --------------------------------
test_that("standardize_parameters (Pseudo - GLMM)", {
skip_if_not_installed("datawizard", minimum_version = "0.12.0")
skip_on_cran()
skip_if_not_installed("lme4")
set.seed(1)
dat <- data.frame(
X = rnorm(1000),
Z = rnorm(1000),
C = sample(letters[1:3], size = 1000, replace = TRUE),
ID = sort(rep_len(letters, 1000))
)
dat <- transform(dat, Y = X + Z + rnorm(1000))
dat <- cbind(dat, datawizard::demean(dat, c("X", "Z"), "ID"))
m <- lme4::lmer(Y ~ scale(X_within) * X_between + C + (scale(X_within) | ID),
data = dat
)
## No robust methods... (yet)
expect_message(standardize_parameters(m, method = "pseudo", robust = TRUE, verbose = FALSE), regexp = "robust")
## Correctly identify within and between terms
dev_resp <- standardize_info(m, include_pseudo = TRUE)$Deviation_Response_Pseudo
expect_identical(insight::n_unique(dev_resp[c(2, 4, 5, 6)]), 1L)
expect_true(dev_resp[2] != dev_resp[3])
## Calc
b <- lme4::fixef(m)[-1]
mm <- model.matrix(m)[, -1]
SD_x <- numeric(ncol(mm))
SD_x[c(1, 3, 4, 5)] <- apply(mm[, c(1, 3, 4, 5)], 2, sd)
SD_x[2] <- sd(tapply(mm[, 2], dat$ID, mean))
m0 <- lme4::lmer(Y ~ 1 + (1 | ID), data = dat)
m0v <- insight::get_variance(m0)
SD_y <- sqrt(c(m0v$var.residual, m0v$var.intercept))
SD_y <- SD_y[c(1, 2, 1, 1, 1)]
expect_equal(
data.frame(Deviation_Response_Pseudo = c(SD_y[2], SD_y), Deviation_Pseudo = c(0, SD_x)),
standardize_info(m, include_pseudo = TRUE)[, c("Deviation_Response_Pseudo", "Deviation_Pseudo")],
tolerance = 1e-5
)
expect_equal(
standardize_parameters(m, method = "pseudo")$Std_Coefficient[-1],
unname(b * SD_x / SD_y),
tolerance = 1e-5
)
## scaling should not affect
m1 <- lme4::lmer(Y ~ X_within + X_between + C + (X_within | ID),
data = dat
)
m2 <- lme4::lmer(scale(Y) ~ X_within + X_between + C + (X_within | ID),
data = dat
)
m3 <- lme4::lmer(Y ~ scale(X_within) + X_between + C + (scale(X_within) | ID),
data = dat
)
m4 <- lme4::lmer(Y ~ X_within + scale(X_between) + C + (X_within | ID),
data = dat
)
std1 <- standardize_parameters(m1, method = "pseudo")
expect_equal(std1$Std_Coefficient,
standardize_parameters(m2, method = "pseudo")$Std_Coefficient,
tolerance = 0.001
)
expect_equal(std1$Std_Coefficient,
standardize_parameters(m3, method = "pseudo")$Std_Coefficient,
tolerance = 0.001
)
expect_equal(std1$Std_Coefficient,
standardize_parameters(m4, method = "pseudo")$Std_Coefficient,
tolerance = 0.001
)
## Give warning for within that is also between
mW <- lme4::lmer(Y ~ X_between + Z_within + C + (1 | ID), dat)
mM <- lme4::lmer(Y ~ X + Z + C + (1 | ID), dat)
expect_warning(standardize_parameters(mW, method = "pseudo"), regexp = NA)
expect_message(standardize_parameters(mM, method = "pseudo"), regexp = "within-group")
})
# ZI models ---------------------------------------------------------------
test_that("standardize_parameters (pscl)", {
skip_on_cran()
skip_if_not_installed("pscl")
data("bioChemists", package = "pscl")
m <- pscl::zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists)
mp <- model_parameters(m, effects = "fixed")
sm1 <- standardize_parameters(m, method = "refit")
expect_message({
sm2 <- standardize_parameters(m, method = "posthoc")
})
suppressMessages({
sm3 <- standardize_parameters(m, method = "basic")
sm4 <- standardize_parameters(m, method = "smart")
})
# post hoc does it right (bar intercept)
expect_equal(sm1$Std_Coefficient[-c(1, 6)],
sm2$Std_Coefficient[-c(1, 6)],
tolerance = 0.01
)
# basic / smart miss the ZI
expect_equal(mp$Coefficient[6:8],
sm3$Std_Coefficient[6:8],
tolerance = 0.01
)
expect_equal(mp$Coefficient[7:8],
sm4$Std_Coefficient[7:8],
tolerance = 0.1
)
# get count numerics al right
expect_equal(sm1$Std_Coefficient[4:5],
sm3$Std_Coefficient[4:5],
tolerance = 0.01
)
expect_equal(sm1$Std_Coefficient[4:5],
sm4$Std_Coefficient[4:5],
tolerance = 0.01
)
})
test_that("include_response | (g)lm", {
# lm ---
data(iris)
iris$Sepal.Length <- iris$Sepal.Length * 5
m <- lm(Sepal.Length ~ Petal.Length + Petal.Width, data = iris)
m_z <- datawizard::standardize(m, include_response = FALSE)
par_z0 <- standardize_parameters(m, method = "basic")
par_z1 <- standardize_parameters(m, include_response = FALSE)
par_z2 <- standardize_parameters(m, method = "basic", include_response = FALSE)
expect_equal(coef(m_z), par_z1$Std_Coefficient, ignore_attr = TRUE)
expect_equal(par_z1$Std_Coefficient[-1], par_z2$Std_Coefficient[-1], tolerance = 1e-5)
expect_equal(par_z0$Std_Coefficient * sd(iris$Sepal.Length), par_z2$Std_Coefficient, tolerance = 1e-5)
# glm ---
m <- glm(am ~ mpg, mtcars, family = binomial())
expect_equal(
standardize_parameters(m),
standardize_parameters(m, include_response = FALSE),
ignore_attr = TRUE
)
})
test_that("include_response | parameters", {
data(iris)
iris$Sepal.Length <- iris$Sepal.Length * 5
m <<- lm(Sepal.Length ~ Petal.Length + Petal.Width, data = iris)
# parameters ---
pars <- model_parameters(m, effects = "fixed")
pars_z0 <- standardize_parameters(pars, method = "basic")
pars_z1 <- standardize_parameters(pars, method = "basic", include_response = FALSE)
expect_equal(pars_z0$Std_Coefficient[-1] * sd(iris$Sepal.Length), pars_z1$Std_Coefficient[-1], tolerance = 1e-5)
# boot ---
skip_if_not_installed("boot")
pars <- bootstrap_parameters(m)
pars_z0 <- standardize_parameters(pars, method = "basic")
pars_z1 <- standardize_parameters(pars, method = "basic", include_response = FALSE)
expect_equal(pars_z0$Std_Coefficient[-1] * sd(iris$Sepal.Length), pars_z1$Std_Coefficient[-1], tolerance = 1e-5)
})
test_that("include_response | bayes", {
skip_if_not_installed("rstanarm")
skip_on_cran()
data(iris)
iris$Sepal.Length <- iris$Sepal.Length * 5
m <- rstanarm::stan_glm(Sepal.Length ~ Petal.Length + Petal.Width, data = iris, refresh = 0)
expect_warning({
m_z <- datawizard::standardize(m, include_response = FALSE)
})
expect_warning({
par_z1 <- standardize_posteriors(m, include_response = FALSE)
})
par_z0 <- standardize_posteriors(m, method = "basic")
par_z2 <- standardize_posteriors(m, method = "basic", include_response = FALSE)
expect_equal(sapply(insight::get_parameters(m_z), mean), sapply(par_z1, mean), tolerance = 0.1)
expect_equal(sapply(par_z1, mean)[-1], sapply(par_z2, mean)[-1], tolerance = 0.1)
expect_equal(sapply(par_z0, mean) * sd(iris$Sepal.Length), sapply(par_z2, mean), tolerance = 0.1)
})
parameters/tests/testthat/test-survey.R 0000644 0001762 0000144 00000002141 14716604201 020053 0 ustar ligges users skip_if_not_installed("withr")
skip_if_not_installed("survey")
withr::with_environment(
new.env(),
test_that("model_parameters svytable", {
# svychisq is called in model_parameters
svychisq <<- survey::svychisq
data(api, package = "survey")
dclus1 <<- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)
m <- survey::svytable(~ sch.wide + stype, dclus1)
mp <- model_parameters(m)
expect_named(mp, c("F", "df", "df_error", "p", "Method"))
expect_equal(mp$p, 0.02174746, tolerance = 1e-3)
})
)
withr::with_environment(
new.env(),
test_that("model_parameters, bootstrap svyglm", {
data(api, package = "survey")
dstrat <- survey::svydesign(
id = ~1,
strata = ~stype,
weights = ~pw,
data = apistrat,
fpc = ~fpc
)
model_svyglm <- suppressWarnings(survey::svyglm(sch.wide ~ ell + meals + mobility,
design = dstrat,
family = binomial(link = "logit")
))
expect_message(parameters(model_svyglm, bootstrap = TRUE), regex = "arguments are not supported")
})
)
parameters/tests/testthat/test-model_parameters.MASS.R 0000644 0001762 0000144 00000001156 14413515226 022612 0 ustar ligges users test_that("model_parameters.rlm", {
skip_if_not_installed("MASS")
model <- MASS::rlm(formula = mpg ~ am * cyl, data = mtcars)
s <- summary(model)
params <- model_parameters(model)
expect_equal(params$SE, as.vector(coef(s)[, 2]), tolerance = 1e-3)
expect_equal(params$Coefficient, as.vector(coef(s)[, 1]), tolerance = 1e-3)
expect_equal(params$t, as.vector(coef(s)[, 3]), tolerance = 1e-3)
expect_equal(params$df_error, c(28, 28, 28, 28), tolerance = 1e-3)
expect_equal(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t", "df_error", "p")
)
})
parameters/tests/testthat/test-parameters_type.R 0000644 0001762 0000144 00000001267 14355245205 021736 0 ustar ligges users test_that("parameters_type-1", {
m0 <- lm(mpg ~ am * cyl, mtcars)
m1 <- lm(mpg ~ am * scale(cyl), mtcars)
m2 <- lm(mpg ~ scale(am) * cyl, mtcars)
m3 <- lm(mpg ~ scale(am) * scale(cyl), mtcars)
expect_equal(parameters_type(m0)[4, "Type"], "interaction")
expect_equal(parameters_type(m1)[4, "Type"], "interaction")
expect_equal(parameters_type(m2)[4, "Type"], "interaction")
expect_equal(parameters_type(m3)[4, "Type"], "interaction")
})
test_that("parameters_type-2", {
model <- lm(Sepal.Length ~ Petal.Width * scale(Petal.Length, TRUE, FALSE), data = iris)
expect_equal(parameters_type(model)$Type, c("intercept", "numeric", "numeric", "interaction"))
})
parameters/tests/testthat/test-model_parameters.cpglmm.R 0000644 0001762 0000144 00000001113 14413515226 023317 0 ustar ligges users unloadNamespace("BayesFactor")
test_that("model_parameters.cpglmm", {
skip_if_not_installed("cplm")
loadNamespace("cplm")
data("FineRoot", package = "cplm")
cpglmm <- cplm::cpglmm
model <- cpglmm(RLD ~ Stock + Spacing + (1 | Plant), data = FineRoot)
params <- model_parameters(model, effects = "fixed")
expect_equal(params$SE, c(0.1308, 0.2514, 0.2, 0.1921), tolerance = 1e-3)
expect_equal(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Effects")
)
unloadNamespace("cplm")
})
parameters/tests/testthat/test-format_model_parameters2.R 0000644 0001762 0000144 00000022460 14413515226 023503 0 ustar ligges users test_that("format_model_parameters", {
skip_on_cran()
skip_if_not_installed("lme4")
withr::with_options(
list(parameters_interaction = "*"),
{
d <- structure(list(
Drought = structure(c(
1L, 1L, 1L, 1L, 1L, 1L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L,
2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L
), levels = c("no", "yes"), class = "factor"), Tree.ID = structure(c(
1L,
1L, 2L, 2L, 3L, 3L, 4L, 4L, 5L, 5L, 6L, 6L, 7L, 7L, 8L, 8L, 9L,
9L, 10L, 10L, 11L, 11L, 12L, 12L, 13L, 13L, 14L, 14L, 15L, 15L,
16L, 16L, 17L, 17L, 18L, 18L, 19L, 19L, 20L, 20L, 21L, 21L, 22L,
22L, 23L, 23L, 24L, 24L, 25L, 25L, 26L, 26L, 27L, 27L, 28L, 28L,
29L, 29L, 30L, 30L, 31L, 31L, 32L, 32L, 33L, 33L, 34L, 34L, 35L,
35L, 36L, 36L, 37L, 37L, 38L, 38L, 39L, 39L, 40L, 40L, 41L, 41L,
42L, 42L, 43L, 43L, 44L, 44L, 45L, 45L, 46L, 46L, 47L, 47L, 48L,
48L, 1L, 1L, 2L, 2L, 3L, 3L, 10L, 10L, 11L, 11L, 12L, 12L, 13L,
13L, 14L, 14L, 15L, 15L, 16L, 16L, 17L, 17L, 18L, 18L, 19L, 19L,
21L, 21L, 22L, 22L, 23L, 23L, 24L, 24L, 25L, 25L, 26L, 26L, 27L,
27L, 28L, 28L, 29L, 29L, 30L, 30L, 31L, 31L, 32L, 32L, 33L, 33L,
37L, 37L, 38L, 38L, 39L, 39L, 43L, 43L, 44L, 44L, 45L, 45L, 46L,
46L, 47L, 47L, 48L, 48L
), levels = c(
"102_6", "102_7", "102_8",
"105_1", "105_2", "105_4", "111_7", "111_8", "111_9", "113_2",
"113_4", "113_5", "114_7", "114_8", "114_9", "116_6", "116_7",
"116_9", "122_3", "122_4", "122_5", "132_3", "132_4", "132_5",
"242_2", "242_4", "242_5", "243_1", "243_2", "243_4", "245_1",
"245_2", "245_5", "246_1", "246_2", "246_3", "251_10", "251_8",
"251_9", "253_7", "253_8", "253_9", "254_6", "254_7", "254_8",
"267_10", "267_6", "267_8"
), class = "factor"), Stratum = structure(c(
1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L,
2L, 1L, 2L, 1L, 2L
), levels = c("lower", "upper"), class = "factor"),
Year = structure(c(
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L, 2L, 2L, 2L, 2L
), levels = c("1", "2"), class = "factor"),
Treatment = c(
"Control", "Control", "Control", "Control",
"Control", "Control", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Control", "Control", "Control", "Control",
"Control", "Control", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Drought", "Drought", "Drought", "Drought", "Drought", "Drought",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control",
"Control", "Control", "Control", "Control", "Control", "Control"
), branch_miner_No = c(
41L, 25L, 47L, 49L, 50L, 49L, 49L,
50L, 49L, 50L, 48L, 47L, 49L, 49L, 50L, 49L, 49L, 43L, 41L,
45L, 49L, 37L, 50L, 49L, 50L, 50L, 50L, 49L, 45L, 44L, 49L,
48L, 50L, 48L, 50L, 49L, 44L, 38L, 50L, 34L, 38L, 28L, 47L,
39L, 50L, 49L, 47L, 50L, 42L, 19L, 47L, 46L, 50L, 50L, 49L,
46L, 49L, 50L, 40L, 45L, 50L, 50L, 41L, 44L, 50L, 50L, 50L,
46L, 50L, 48L, 50L, 50L, 48L, 38L, 49L, 42L, 39L, 31L, 49L,
33L, 38L, 49L, 48L, 48L, 49L, 49L, 48L, 50L, 45L, 37L, 28L,
25L, 45L, 45L, 39L, 35L, 38L, 43L, 46L, 34L, 49L, 33L, 40L,
47L, 47L, 39L, 46L, 31L, 47L, 40L, 47L, 45L, 47L, 42L, 48L,
47L, 39L, 25L, 37L, 46L, 38L, 42L, 44L, 48L, 47L, 46L, 48L,
49L, 38L, 44L, 39L, 31L, 41L, 42L, 44L, 18L, 23L, 48L, 26L,
26L, 28L, 32L, 47L, 46L, 49L, 33L, 47L, 38L, 35L, 17L, 39L,
30L, 44L, 42L, 47L, 36L, 8L, 33L, 32L, 37L, 33L, 38L, 32L,
45L, 47L, 41L
), branch_miner_Yes = c(
9L, 25L, 3L, 1L, 0L,
1L, 1L, 0L, 1L, 0L, 2L, 3L, 1L, 1L, 0L, 1L, 1L, 7L, 9L, 5L,
1L, 13L, 0L, 1L, 0L, 0L, 0L, 1L, 5L, 6L, 1L, 2L, 0L, 2L,
0L, 1L, 6L, 12L, 0L, 16L, 12L, 22L, 3L, 11L, 0L, 1L, 3L,
0L, 8L, 31L, 3L, 4L, 0L, 0L, 1L, 4L, 1L, 0L, 10L, 5L, 0L,
0L, 9L, 6L, 0L, 0L, 0L, 4L, 0L, 2L, 0L, 0L, 2L, 12L, 1L,
8L, 11L, 19L, 1L, 17L, 12L, 1L, 2L, 2L, 1L, 1L, 2L, 0L, 5L,
13L, 22L, 25L, 5L, 5L, 11L, 15L, 12L, 7L, 4L, 16L, 1L, 17L,
10L, 3L, 3L, 11L, 4L, 19L, 3L, 10L, 3L, 5L, 3L, 8L, 2L, 3L,
11L, 25L, 13L, 4L, 12L, 8L, 6L, 2L, 3L, 4L, 2L, 1L, 12L,
6L, 11L, 19L, 9L, 8L, 6L, 32L, 27L, 2L, 24L, 24L, 22L, 18L,
3L, 4L, 1L, 17L, 3L, 12L, 15L, 33L, 11L, 20L, 6L, 8L, 3L,
14L, 42L, 17L, 18L, 13L, 17L, 12L, 18L, 5L, 3L, 9L
)
), row.names = c(
NA,
-166L
), class = "data.frame")
d$Year <- factor(d$Year)
d$Drought <- as.factor(d$Drought)
d$Stratum <- as.factor(d$Stratum)
levels(d$Stratum) <- list(lower = "shade", upper = "sun")
d$Tree.ID <- as.factor(d$Tree.ID)
mod <- lme4::glmer(
cbind(branch_miner_Yes, branch_miner_No) ~ Drought * Stratum + Drought * Year + Year * Stratum + (1 | Tree.ID),
data = d,
family = binomial(),
na.action = na.exclude
)
out <- model_parameters(mod, component = "conditional")
expect_identical(
attributes(out)$pretty_names,
c(
`(Intercept)` = "(Intercept)", Droughtyes = "Drought [yes]",
Stratumupper = "Stratum [upper]", Year2 = "Year [2]",
`Droughtyes:Stratumupper` = "Drought [yes] * Stratum [upper]",
`Droughtyes:Year2` = "Drought [yes] * Year [2]",
`Stratumupper:Year2` = "Stratum [upper] * Year [2]"
)
)
}
)
})
parameters/tests/testthat/test-ordered.R 0000644 0001762 0000144 00000001207 14420256646 020154 0 ustar ligges users test_that("ordered factors", {
data(PlantGrowth)
m_ord <- lm(weight ~ as.ordered(group), PlantGrowth)
pt <- parameters_type(m_ord)
mp <- model_parameters(m_ord)
expect_identical(pt$Type, c("intercept", "ordered", "ordered"))
expect_identical(pt$Parameter, c("(Intercept)", "as.ordered(group).L", "as.ordered(group).Q"))
expect_identical(mp$Parameter, c("(Intercept)", "as.ordered(group).L", "as.ordered(group).Q"))
expect_identical(
attributes(mp)$pretty_names,
c(
`(Intercept)` = "(Intercept)", `as.ordered(group).L` = "group [linear]",
`as.ordered(group).Q` = "group [quadratic]"
)
)
})
parameters/tests/testthat/test-model_parameters_df_method.R 0000644 0001762 0000144 00000014354 14413515226 024065 0 ustar ligges users skip_if_not_installed("lmerTest")
skip_if_not_installed("pbkrtest")
skip_if_not_installed("lme4")
mtcars$cyl <- as.factor(mtcars$cyl)
model <- suppressMessages(lme4::lmer(mpg ~ as.factor(gear) * hp + as.factor(am) + wt + (1 | cyl), data = mtcars))
model2 <- suppressMessages(lmerTest::lmer(mpg ~ as.factor(gear) * hp + as.factor(am) + wt + (1 | cyl), data = mtcars))
mp0 <- model_parameters(model, digits = 5, effects = "fixed")
mp1 <- model_parameters(model, digits = 5, ci_method = "normal", effects = "fixed")
mp2 <- model_parameters(model, digits = 5, ci_method = "s", effects = "fixed")
mp3 <- model_parameters(model, digits = 5, ci_method = "kr", effects = "fixed")
mp4 <- model_parameters(model, digits = 5, ci_method = "wald", effects = "fixed")
test_that("model_parameters, ci_method default (residual)", {
expect_equal(
mp0$SE,
c(
2.77457,
3.69574,
3.521,
0.01574,
1.58514,
0.86316,
0.02973,
0.01668
),
tolerance = 1e-3
)
expect_equal(mp0$df, c(22, 22, 22, 22, 22, 22, 22, 22), tolerance = 1e-3)
expect_equal(
mp0$p,
c(
0,
0.00258,
0.14297,
0.17095,
0.84778,
0.00578,
0.00151,
0.32653
),
tolerance = 1e-3
)
expect_equal(
mp0$CI_low,
c(
24.54722,
4.89698,
-1.95317,
-0.05493,
-2.97949,
-4.42848,
-0.16933,
-0.05133
),
tolerance = 1e-3
)
})
test_that("model_parameters, ci_method normal", {
expect_equal(
mp1$SE,
c(
2.77457,
3.69574,
3.521,
0.01574,
1.58514,
0.86316,
0.02973,
0.01668
),
tolerance = 1e-3
)
expect_equal(
mp1$df,
c(22, 22, 22, 22, 22, 22, 22, 22),
tolerance = 1e-3
)
expect_equal(
mp1$p,
c(0, 0.00068, 0.12872, 0.15695, 0.846, 0.00224, 0.00029, 0.31562),
tolerance = 1e-3
)
expect_equal(
mp1$CI_low,
c(
24.86326,
5.31796,
-1.5521,
-0.05313,
-2.79893,
-4.33015,
-0.16595,
-0.04943
),
tolerance = 1e-3
)
})
test_that("model_parameters, ci_method satterthwaite", {
expect_equal(
mp2$SE,
c(
2.77457,
3.69574,
3.521,
0.01574,
1.58514,
0.86316,
0.02973,
0.01668
),
tolerance = 1e-3
)
expect_equal(mp2$df, c(24, 24, 24, 24, 24, 24, 24, 24), tolerance = 1e-3)
expect_equal(
mp2$p,
c(
0,
0.00236,
0.14179,
0.16979,
0.84763,
0.00542,
0.00136,
0.32563
),
tolerance = 1e-3
)
expect_equal(
mp2$CI_low,
c(
24.57489,
4.93385,
-1.91805,
-0.05477,
-2.96368,
-4.41987,
-0.16904,
-0.05117
),
tolerance = 1e-3
)
})
test_that("model_parameters, ci_method kenward", {
expect_equal(
mp3$SE,
c(
2.97608,
6.10454,
3.98754,
0.02032,
1.60327,
0.91599,
0.05509,
0.01962
),
tolerance = 1e-3
)
expect_equal(
mp3$df,
c(
19.39553,
5.27602,
23.57086,
8.97297,
22.7421,
23.76299,
2.72622,
22.82714
),
tolerance = 1e-3
)
expect_equal(
mp3$p,
c(
0,
0.09176,
0.19257,
0.30147,
0.84942,
0.00828,
0.15478,
0.40248
),
tolerance = 1e-3
)
expect_equal(
mp3$CI_low,
c(
24.08091,
-2.887,
-2.88887,
-0.06828,
-3.01082,
-4.5299,
-0.29339,
-0.05735
),
tolerance = 1e-3
)
})
test_that("model_parameters, ci_method wald (t)", {
expect_equal(
mp4$SE,
c(
2.77457,
3.69574,
3.521,
0.01574,
1.58514,
0.86316,
0.02973,
0.01668
),
tolerance = 1e-3
)
expect_equal(mp4$df, c(22, 22, 22, 22, 22, 22, 22, 22), tolerance = 1e-3)
expect_equal(
mp4$p,
c(
0,
0.00258,
0.14297,
0.17095,
0.84778,
0.00578,
0.00151,
0.32653
),
tolerance = 1e-3
)
expect_equal(
mp4$CI_low,
c(
24.54722,
4.89698,
-1.95317,
-0.05493,
-2.97949,
-4.42848,
-0.16933,
-0.05133
),
tolerance = 1e-3
)
})
test_that("model_parameters, satterthwaite compare", {
s <- summary(model2)
expect_equal(mp2$df, as.vector(s$coefficients[, "df"]), tolerance = 1e-4)
expect_equal(mp2$t, as.vector(s$coefficients[, "t value"]), tolerance = 1e-4)
expect_equal(mp2$p, as.vector(s$coefficients[, "Pr(>|t|)"]), tolerance = 1e-4)
expect_equal(mp2$SE, as.vector(s$coefficients[, "Std. Error"]), tolerance = 1e-4)
})
test_that("model_parameters, satterthwaite Conf Int-1", {
ci1 <- ci_satterthwaite(model)
expect_equal(mp2$CI_low, ci1$CI_low, tolerance = 1e-4)
ci2 <- ci_satterthwaite(model2)
expect_equal(mp2$CI_low, ci2$CI_low, tolerance = 1e-4)
})
test_that("model_parameters, satterthwaite Conf Int-2", {
coef.table <- as.data.frame(summary(model2)$coefficients)
coef.table$CI_low <- coef.table$Estimate - (coef.table$"Std. Error" * qt(0.975, df = coef.table$df))
coef.table$CI_high <- coef.table$Estimate + (coef.table$"Std. Error" * qt(0.975, df = coef.table$df))
expect_equal(mp2$CI_low, coef.table$CI_low, tolerance = 1e-4)
expect_equal(mp2$CI_high, coef.table$CI_high, tolerance = 1e-4)
})
test_that("model_parameters, Kenward-Roger compare", {
s <- summary(model2, ddf = "Kenward-Roger")
expect_equal(mp3$df, as.vector(s$coefficients[, "df"]), tolerance = 1e-4)
expect_equal(mp3$t, as.vector(s$coefficients[, "t value"]), tolerance = 1e-4)
expect_equal(mp3$p, as.vector(s$coefficients[, "Pr(>|t|)"]), tolerance = 1e-4)
expect_equal(mp3$SE, as.vector(s$coefficients[, "Std. Error"]), tolerance = 1e-4)
})
model <- lm(mpg ~ as.factor(gear) * hp + as.factor(am) + wt, data = mtcars)
test_that("model_parameters, ci_method-lm", {
expect_s3_class(model_parameters(model), "parameters_model")
expect_message(model_parameters(model, ci_method = "kenward"))
})
parameters/tests/testthat/test-model_parameters_labels.R 0000644 0001762 0000144 00000011236 14413515226 023372 0 ustar ligges users skip_if_not_installed("withr")
withr::with_options(
list(parameters_interaction = "*"),
{
test_that("model_parameters_labels", {
skip_if_not_installed("lme4")
skip_if_not_installed("merDeriv")
data(mtcars)
mtcars$am <- as.factor(mtcars$am)
m1 <- lme4::lmer(mpg ~ hp * am + (1 | cyl), data = mtcars)
expect_equal(
attr(model_parameters(m1), "pretty_names"),
c(`(Intercept)` = "(Intercept)", hp = "hp", am1 = "am [1]", `hp:am1` = "hp * am [1]")
)
m2 <- lme4::lmer(mpg ~ hp * as.factor(am) + (1 | cyl), data = mtcars)
expect_equal(
attr(model_parameters(m2), "pretty_names"),
c(
`(Intercept)` = "(Intercept)", hp = "hp", `as.factor(am)1` = "am [1]",
`hp:as.factor(am)1` = "hp * am [1]"
)
)
m3 <- lme4::lmer(mpg ~ hp * log(gear) + (1 | cyl), data = mtcars)
expect_equal(
attr(model_parameters(m3), "pretty_names"),
c(
`(Intercept)` = "(Intercept)", hp = "hp", `log(gear)` = "gear [log]",
`hp:log(gear)` = "hp * gear [log]"
)
)
m4 <- lm(mpg ~ as.factor(cyl) + hp * log(gear), data = mtcars)
expect_equal(
attr(model_parameters(m4), "pretty_names"),
c(
`(Intercept)` = "(Intercept)", `as.factor(cyl)6` = "cyl [6]",
`as.factor(cyl)8` = "cyl [8]", hp = "hp", `log(gear)` = "gear [log]",
`hp:log(gear)` = "hp * gear [log]"
)
)
m5 <- lm(mpg ~ as.factor(cyl) * I(wt / 10) + hp * log(gear), data = mtcars)
expect_equal(
attr(model_parameters(m5), "pretty_names"),
c(
`(Intercept)` = "(Intercept)", `as.factor(cyl)6` = "cyl [6]",
`as.factor(cyl)8` = "cyl [8]", `I(wt/10)` = "wt/10", hp = "hp",
`log(gear)` = "gear [log]", `as.factor(cyl)6:I(wt/10)` = "cyl [6] * wt/10",
`as.factor(cyl)8:I(wt/10)` = "cyl [8] * wt/10", `hp:log(gear)` = "hp * gear [log]"
)
)
m6 <- lm(mpg ~ as.factor(cyl) * log(wt) + hp * log(gear), data = mtcars)
expect_equal(
attr(model_parameters(m6), "pretty_names"),
c(
`(Intercept)` = "(Intercept)", `as.factor(cyl)6` = "cyl [6]",
`as.factor(cyl)8` = "cyl [8]", `log(wt)` = "wt [log]", hp = "hp",
`log(gear)` = "gear [log]", `as.factor(cyl)6:log(wt)` = "cyl [6] * wt [log]",
`as.factor(cyl)8:log(wt)` = "cyl [8] * wt [log]", `hp:log(gear)` = "hp * gear [log]"
)
)
m7 <- lm(mpg ~ as.factor(cyl) * poly(wt, 2) + hp * log(gear), data = mtcars)
expect_equal(
attr(model_parameters(m7), "pretty_names"),
c(
`(Intercept)` = "(Intercept)",
`as.factor(cyl)6` = "cyl6",
`as.factor(cyl)8` = "cyl8",
`poly(wt, 2)1` = "wt [1st degree]",
`poly(wt, 2)2` = "wt [2nd degree]",
hp = "hp",
`log(gear)` = "gear [log]",
`as.factor(cyl)6:poly(wt, 2)1` = "cyl6 * wt [1st degree]",
`as.factor(cyl)8:poly(wt, 2)1` = "cyl8 * wt [1st degree]",
`as.factor(cyl)6:poly(wt, 2)2` = "cyl6 * wt [2nd degree]",
`as.factor(cyl)8:poly(wt, 2)2` = "cyl8 * wt [2nd degree]",
`hp:log(gear)` = "hp * gear [log]"
)
)
m8 <- lm(mpg ~ as.factor(cyl) * I(wt^2) + hp * log(gear), data = mtcars)
expect_equal(
attr(model_parameters(m8), "pretty_names"),
c(
`(Intercept)` = "(Intercept)",
`as.factor(cyl)6` = "cyl [6]",
`as.factor(cyl)8` = "cyl [8]",
`I(wt^2)` = "wt^2",
hp = "hp",
`log(gear)` = "gear [log]",
`as.factor(cyl)6:I(wt^2)` = "cyl [6] * wt^2",
`as.factor(cyl)8:I(wt^2)` = "cyl [8] * wt^2",
`hp:log(gear)` = "hp * gear [log]"
)
)
})
test_that("Issue #785: partial and factor labels", {
dat <- mtcars
dat$cyl <- factor(dat$cyl)
attr(dat$hp, "label") <- "Horsepower"
attr(dat$cyl, "label") <- "Cylinders"
m <- lm(mpg ~ hp + drat + cyl, data = dat)
mp <- model_parameters(m)
known <- c("(Intercept)", "Horsepower", "drat", "Cylinders [6]", "Cylinders [8]")
expect_equal(attr(mp, "pretty_labels"), known, ignore_attr = TRUE)
})
test_that("Issue #806: Missing label for variance component in lme4", {
skip_if_not_installed("lme4")
skip_if_not_installed("merDeriv")
mod <- lme4::lmer(mpg ~ hp + (1 | gear), data = mtcars)
p <- parameters::parameters(mod, pretty_names = "labels")
expect_true("SD (Intercept)" %in% attr(p, "pretty_labels"))
})
}
)
parameters/tests/testthat/test-bootstrap_parameters.R 0000644 0001762 0000144 00000000570 14716604201 022762 0 ustar ligges users skip_on_cran()
skip_if_not_installed("boot")
test_that("bootstrap_parameters.bootstrap_model", {
data(iris)
m_draws <- lm(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
set.seed(123)
draws <- bootstrap_model(m_draws)
draws$lin_comb <- draws$Sepal.Width - draws$Petal.Length
out <- bootstrap_parameters(draws)
expect_snapshot(print(out))
})
parameters/tests/testthat/test-brms.R 0000644 0001762 0000144 00000001124 14716604201 017461 0 ustar ligges users skip_on_cran()
skip_on_os("mac")
skip_if_not_installed("httr2")
skip_if_not_installed("curl")
skip_if_offline()
skip_if_not_installed("withr")
skip_if_not_installed("brms")
skip_if_not_installed("rstan")
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("mp, footer exp", {
m <- suppressWarnings(insight::download_model("brms_bernoulli_1"))
out <- parameters::model_parameters(m, exponentiate = FALSE)
expect_snapshot(print(out))
out <- parameters::model_parameters(m, exponentiate = TRUE)
expect_snapshot(print(out))
})
)
parameters/tests/testthat/test-model_parameters.glht.R 0000644 0001762 0000144 00000001316 14413515226 023003 0 ustar ligges users test_that("model_parameters.glht", {
skip_if_not_installed("multcomp")
set.seed(123)
lmod <- lm(Fertility ~ ., data = swiss)
model <- multcomp::glht(
model = lmod,
linfct = c(
"Agriculture = 0",
"Examination = 0",
"Education = 0",
"Catholic = 0",
"Infant.Mortality = 0"
)
)
params <- model_parameters(model)
expect_equal(params$Coefficient, c(-0.1721, -0.258, -0.8709, 0.1041, 1.077), tolerance = 1e-2)
expect_equal(params$SE, c(0.0703, 0.2539, 0.183, 0.0353, 0.3817), tolerance = 1e-2)
expect_equal(
params$Parameter,
c("Agriculture == 0", "Examination == 0", "Education == 0", "Catholic == 0", "Infant.Mortality == 0")
)
})
parameters/tests/testthat/test-printing-stan.R 0000644 0001762 0000144 00000004333 14737236746 021342 0 ustar ligges users skip_if_not_installed("curl")
skip_if_offline()
skip_on_cran()
skip_if_not_installed("brms")
skip_if_not_installed("insight")
skip_if_not_installed("withr")
withr::with_options(
list(parameters_exponentiate = FALSE),
{
test_that("print brms", {
m1 <- insight::download_model("brms_1")
mp1 <- model_parameters(m1, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp1)
m2 <- insight::download_model("brms_mixed_1")
mp2 <- model_parameters(m2, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp2)
m3 <- insight::download_model("brms_mixed_2")
mp3 <- model_parameters(m3, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp3)
m4 <- insight::download_model("brms_mixed_3")
mp4 <- model_parameters(m4, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp4)
m5 <- insight::download_model("brms_mixed_4")
mp5 <- model_parameters(m5, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp5)
m6 <- insight::download_model("brms_mixed_7")
mp6 <- model_parameters(m6, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp6)
m7 <- insight::download_model("brms_zi_1")
mp7 <- model_parameters(m7, effects = "all", component = "all", centrality = "mean", verbose = FALSE)
expect_snapshot(mp7)
m8 <- insight::download_model("brms_zi_3")
mp8 <- model_parameters(m8, effects = "all", component = "all", centrality = "mean", verbose = FALSE)
expect_snapshot(mp8)
m9 <- insight::download_model("brms_ordinal_1")
mp9 <- model_parameters(m9, effects = "all", component = "all", centrality = "mean")
expect_snapshot(mp9)
})
test_that("print-information", {
skip_if_offline()
skip_if_not_installed("httr2")
m <- insight::download_model("brms_1")
out <- model_parameters(m)
expect_snapshot(out)
out <- model_parameters(m, ci_method = "HDI")
expect_snapshot(out)
m <- insight::download_model("stanreg_glm_1")
out <- model_parameters(m)
})
}
)
parameters/tests/testthat/test-parameters_table.R 0000644 0001762 0000144 00000002355 14413515226 022041 0 ustar ligges users skip_if_not_installed("effectsize")
skip_if_not_installed("insight")
test_that("parameters_table 1", {
x <- model_parameters(lm(Sepal.Length ~ Species, data = iris), standardize = "refit")
tab <- insight::format_table(x)
expect_equal(colnames(tab), c("Parameter", "Coefficient", "SE", "95% CI", "t(147)", "p"))
})
test_that("parameters_table 2", {
skip_if_not_installed("lme4")
x <- model_parameters(lme4::lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris), effects = "fixed")
tab <- insight::format_table(x)
expect_true(all(names(tab) == c("Parameter", "Coefficient", "SE", "95% CI", "t(146)", "p", "Effects")))
})
test_that("parameters_table 3", {
x <- effectsize::effectsize(lm(Sepal.Length ~ Species, data = iris))
tab <- insight::format_table(x)
expect_equal(colnames(tab), c("Parameter", "Std. Coef.", "95% CI"))
})
test_that("parameters_table 4", {
x <- model_parameters(lm(Sepal.Length ~ Species, data = iris), standardize = "posthoc")
tab <- insight::format_table(x)
expect_equal(colnames(tab), c("Parameter", "Std. Coef.", "SE", "95% CI", "t(147)", "p"))
})
# x <- report::report_table(lm(Sepal.Length ~ Species, data=iris)) # Once on CRAN
# t <- insight::format_table(x)
# t
parameters/tests/testthat/test-p_significance.R 0000644 0001762 0000144 00000004002 14716604201 021455 0 ustar ligges users skip_on_cran()
skip_if_not_installed("bayestestR", minimum_version = "0.15.0")
skip_if_not_installed("distributional")
skip_if_not_installed("withr")
withr::with_environment(
new.env(),
test_that("p_significance", {
data(mtcars)
m <<- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
set.seed(123)
x <- p_significance(m)
expect_identical(c(nrow(x), ncol(x)), c(5L, 5L))
expect_named(x, c("Parameter", "CI", "CI_low", "CI_high", "ps"))
expect_snapshot(print(x))
mp <- model_parameters(m)
set.seed(123)
x2 <- p_significance(mp)
expect_equal(x$ps, x2$ps, tolerance = 1e-4)
set.seed(123)
x <- p_significance(m, ci = 0.8)
expect_equal(x$ps, c(1, 0.3983, 0.9959, 0.6188, 0), tolerance = 1e-3)
set.seed(123)
x <- p_significance(m, threshold = 0.5)
expect_equal(x$ps, c(1, 0.4393, 0.9969, 0.6803, 0), tolerance = 1e-4)
set.seed(123)
# Test p_significance with custom thresholds for specific parameters
x <- p_significance(m, threshold = list(cyl = 0.5, wt = 0.7))
expect_equal(x$ps, c(1, 0.5982, 0.9955, 0.6803, 1e-04), tolerance = 1e-4)
})
)
test_that("p_significance, glmmTMB", {
skip_if_not_installed("glmmTMB")
data(Salamanders, package = "glmmTMB")
m1 <- glmmTMB::glmmTMB(count ~ mined + cover + (1 | site),
zi = ~mined,
family = poisson,
data = Salamanders
)
out <- p_significance(m1)
expect_identical(c(nrow(out), ncol(out)), c(5L, 6L))
expect_named(out, c("Parameter", "CI", "CI_low", "CI_high", "ps", "Component"))
expect_equal(out$ps, c(0.6451, 1, 0.9015, 1, 1), tolerance = 1e-4)
expect_identical(
out$Parameter,
c(
"(Intercept)_cond", "minedno_cond", "cover_cond", "(Intercept)_zi",
"minedno_zi"
)
)
})
test_that("p_significance, robust", {
skip_if_not_installed("sandwich")
data(mtcars)
m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
set.seed(123)
x <- p_significance(m, vcov = "HC3")
expect_snapshot(print(x))
})
parameters/tests/testthat/test-model_parameters.glm.R 0000644 0001762 0000144 00000005660 14716604201 022630 0 ustar ligges users skip_if_not_installed("boot")
test_that("model_parameters.lm", {
model <- lm(mpg ~ wt, data = mtcars)
params <- model_parameters(model, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(2L, 9L))
expect_equal(params$CI_high, c(41.119752761418, -4.20263490802709), tolerance = 1e-3)
expect_equal(attributes(params)$sigma, 3.045882, tolerance = 1e-3)
params <- model_parameters(model, ci = c(0.8, 0.9), verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(2L, 10L))
params <- model_parameters(model, dispersion = TRUE, bootstrap = TRUE, iterations = 500, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(2L, 7L))
model <- lm(mpg ~ wt + cyl, data = mtcars)
params <- model_parameters(model, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(3L, 9L))
model <- lm(mpg ~ wt * cyl, data = mtcars)
params <- model_parameters(model, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(4L, 9L))
params <- model_parameters(model, component = "conditional", effects = "fixed", verbose = FALSE)
})
test_that("print digits model_parameters.lm", {
model <- lm(mpg ~ wt, data = mtcars)
params <- model_parameters(model, digits = 4, ci_digits = 5, verbose = FALSE)
out <- capture.output(print(params))
expect_identical(out[3], "(Intercept) | 37.2851 | 1.8776 | [33.45050, 41.11975] | 19.8576 | < .001")
})
test_that("print digits model_parameters.lm", {
skip_if_not_installed("performance")
model <- lm(mpg ~ wt, data = mtcars)
params <- model_parameters(model, include_info = TRUE, verbose = FALSE)
expect_snapshot(params)
params <- model_parameters(model, include_info = FALSE, verbose = FALSE)
expect_snapshot(params)
})
test_that("model_parameters.glm - binomial", {
set.seed(333)
model <- glm(vs ~ wt + cyl, data = mtcars, family = "binomial")
params <- model_parameters(model, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(3L, 9L))
params <- suppressWarnings(model_parameters(model, bootstrap = TRUE, iterations = 500, verbose = FALSE))
expect_identical(c(nrow(params), ncol(params)), c(3L, 6L))
params <- model_parameters(model, component = "conditional", effects = "fixed", verbose = FALSE)
})
test_that("model_parameters.glm - Gamma - print", {
# test printing for prevalence ratios
clotting <- data.frame(
u = c(5, 10, 15, 20, 30, 40, 60, 80, 100),
lot1 = c(118, 58, 42, 35, 27, 25, 21, 19, 18),
lot2 = c(69, 35, 26, 21, 18, 16, 13, 12, 12)
)
m <- glm(lot1 ~ log(u), data = clotting, family = Gamma("log"))
mp <- model_parameters(m, exponentiate = TRUE)
expect_snapshot(mp)
})
test_that("model_parameters.glm - glm, identity link", {
data(mtcars)
m <- glm(am ~ vs, data = mtcars, family = binomial(link = "identity"))
p <- model_parameters(m)
expect_identical(attributes(p)$coefficient_name, "Risk")
})
parameters/tests/testthat/test-format_p_adjust.R 0000644 0001762 0000144 00000000241 14412513617 021701 0 ustar ligges users test_that("format_p_adjust", {
expect_identical(format_p_adjust("holm"), "Holm (1979)")
expect_identical(format_p_adjust("bonferroni"), "Bonferroni")
})
parameters/tests/testthat/_snaps/ 0000755 0001762 0000144 00000000000 14761570351 016713 5 ustar ligges users parameters/tests/testthat/_snaps/model_parameters.anova.md 0000644 0001762 0000144 00000003546 14716604211 023664 0 ustar ligges users # model_parameters.anova
Code
mp
Output
Parameter | df | Deviance | df (error) | Deviance (error) | p
--------------------------------------------------------------------
NULL | | | 31 | 43.23 |
mpg | 1 | 13.55 | 30 | 29.68 | < .001
hp | 1 | 10.44 | 29 | 19.23 | 0.001
factor(cyl) | 2 | 8.75 | 27 | 10.49 | 0.013
Anova Table (Type 1 tests)
# print-model_parameters
Code
mp
Output
Parameter | Sum_Squares | df | Mean_Square | F | p
-------------------------------------------------------------
mpg | 16.72 | 1 | 16.72 | 53.40 | < .001
hp | 18.92 | 1 | 18.92 | 60.43 | < .001
factor(cyl) | 8.75 | 2 | 4.37 | 13.97 | < .001
Residuals | 8.45 | 27 | 0.31 | |
Anova Table (Type 3 tests)
# anova survey
Code
print(model_parameters(out))
Output
# Fixed Effects
Parameter | DEff | Chi2(1) | df (error) | p
-----------------------------------------------
ell | 0.77 | 1.13 | 38 | 0.236
meals | 1.24 | 4.82 | 37 | 0.058
ell:meals | 1.48 | 16.52 | 36 | 0.002
Anova Table (Type 1 tests)
---
Code
print(model_parameters(out))
Output
# Fixed Effects
Parameter | df | df (error) | F | p
------------------------------------------
ell | 1 | 38 | 1.47 | 0.234
meals | 1 | 37 | 3.54 | 0.068
ell:meals | 1 | 36 | 9.10 | 0.005
Anova Table (Type 1 tests)
parameters/tests/testthat/_snaps/marginaleffects.md 0000644 0001762 0000144 00000000546 14761570351 022374 0 ustar ligges users # digits and ci_digits for marginaleffects
Code
out
Output
# Fixed Effects
Parameter | Coefficient | SE | Statistic | p | S | 95% CI
--------------------------------------------------------------------------
10*wt=0 | -53.4 | 5.6 | -9.6 | < .001 | 69.5 | [-64.4, -42.5]
parameters/tests/testthat/_snaps/complete_separation.md 0000644 0001762 0000144 00000005023 14716604200 023261 0 ustar ligges users # print warning about complete separation
Code
print(out)
Output
Parameter | Log-Odds | SE | 95% CI | z | p
------------------------------------------------------------------------------
(Intercept) | -66.10 | 1.83e+05 | [-10644.72, 10512.52] | -3.60e-04 | > .999
x1 | 15.29 | 27362.84 | [ -3122.69, ] | 5.59e-04 | > .999
x2 | 6.24 | 81543.72 | [-12797.28, ] | 7.65e-05 | > .999
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
Some coefficients are very large, which may indicate issues with
complete separation.
---
Code
print(out)
Output
Parameter | Log-Odds | SE | 95% CI | z | p
-------------------------------------------------------------------------
(Intercept) | -83.33 | 15505.03 | [ , 816.56] | -5.37e-03 | 0.996
gear | 21.01 | 3876.26 | [-248.93, ] | 5.42e-03 | 0.996
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
Some coefficients are very large, which may indicate issues with
complete separation.
# print warning about quasi complete separation
Code
print(out)
Output
Parameter | Log-Odds | SE | 95% CI | z | p
------------------------------------------------------------------
(Intercept) | -51.19 | 19.62 | [-105.21, -22.47] | -2.61 | 0.009
qsec | 2.89 | 1.10 | [ 1.28, 5.93] | 2.63 | 0.009
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
Some coefficients seem to be rather large, which may indicate issues
with (quasi) complete separation. Consider using bias-corrected or
penalized regression models.
parameters/tests/testthat/_snaps/ivreg.md 0000644 0001762 0000144 00000001407 14716604200 020342 0 ustar ligges users # print-model_parameters
Code
tmp
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | t(45) | p
--------------------------------------------------------------------
(Intercept) | 9.89 | 1.06 | [ 7.76, 12.03] | 9.35 | < .001
rprice [log] | -1.28 | 0.26 | [-1.81, -0.75] | -4.85 | < .001
rincome [log] | 0.28 | 0.24 | [-0.20, 0.76] | 1.18 | 0.246
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
The model has a log-transformed response variable. Consider using
`exponentiate = TRUE` to interpret coefficients as ratios.
parameters/tests/testthat/_snaps/pretty_names.md 0000644 0001762 0000144 00000001577 14716604201 021751 0 ustar ligges users # pretty_labels
Code
print(p)
Output
Parameter | Log-Odds | SE | 95% CI | z | p
------------------------------------------------------------
(Intercept) | 0.44 | 0.07 | [0.30, 0.58] | 6.07 | < .001
X | 0.26 | 0.10 | [0.06, 0.46] | 2.52 | 0.012
M [b] | 0.57 | 0.11 | [0.36, 0.78] | 5.29 | < .001
M [c] | 0.97 | 0.11 | [0.75, 1.19] | 8.75 | < .001
X * M [b] | 0.89 | 0.17 | [0.56, 1.24] | 5.17 | < .001
X * M [c] | 1.41 | 0.21 | [1.00, 1.84] | 6.58 | < .001
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
parameters/tests/testthat/_snaps/model_parameters.fixest_multi.md 0000644 0001762 0000144 00000015173 14716604200 025271 0 ustar ligges users # model_parameters.fixest_multi
Code
print(model_parameters(mod))
Output
# Petal.Width ~ x
Parameter | Coefficient | SE | 95% CI | t(2) | p
-------------------------------------------------------------
x | 0.02 | 0.02 | [-0.06, 0.09] | 0.91 | 0.459
# Sepal.Width ~ x
Parameter | Coefficient | SE | 95% CI | t(2) | p
-------------------------------------------------------------
x | 0.05 | 0.06 | [-0.22, 0.31] | 0.74 | 0.534
# Petal.Width ~ x + Petal.Length
Parameter | Coefficient | SE | 95% CI | t(2) | p
----------------------------------------------------------------
x | 0.01 | 0.02 | [-0.07, 0.10] | 0.73 | 0.541
Petal.Length | 0.23 | 0.07 | [-0.07, 0.53] | 3.34 | 0.079
# Sepal.Width ~ x + Petal.Length
Parameter | Coefficient | SE | 95% CI | t(2) | p
----------------------------------------------------------------
x | 0.04 | 0.06 | [-0.22, 0.31] | 0.71 | 0.553
Petal.Length | 0.30 | 0.06 | [ 0.05, 0.54] | 5.15 | 0.036
# Petal.Width ~ x + Petal.Length + Sepal.Length
Parameter | Coefficient | SE | 95% CI | t(2) | p
-----------------------------------------------------------------
x | 0.01 | 0.02 | [-0.07, 0.10] | 0.74 | 0.539
Petal.Length | 0.23 | 0.08 | [-0.11, 0.58] | 2.93 | 0.099
Sepal.Length | -4.24e-03 | 0.03 | [-0.14, 0.13] | -0.13 | 0.906
# Sepal.Width ~ x + Petal.Length + Sepal.Length
Parameter | Coefficient | SE | 95% CI | t(2) | p
-----------------------------------------------------------------
x | 0.03 | 0.04 | [-0.15, 0.22] | 0.81 | 0.502
Petal.Length | -0.04 | 0.19 | [-0.85, 0.78] | -0.20 | 0.858
Sepal.Length | 0.37 | 0.20 | [-0.49, 1.23] | 1.86 | 0.205
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(ci(mod))
Output
Parameter CI CI_low CI_high Response
1 x 0.95 -0.06044147 0.09280643 Petal.Width
2 x 0.95 -0.06835071 0.09635073 Petal.Width
3 Petal.Length 0.95 -0.06642354 0.52593096 Petal.Width
4 x 0.95 -0.06835856 0.09655518 Petal.Width
5 Petal.Length 0.95 -0.10895767 0.57612928 Petal.Width
6 Sepal.Length 0.95 -0.14108092 0.13259825 Petal.Width
7 x 0.95 -0.22113283 0.31370225 Sepal.Width
8 x 0.95 -0.22124463 0.30818414 Sepal.Width
9 Petal.Length 0.95 0.04898068 0.54369328 Sepal.Width
10 x 0.95 -0.14997065 0.21974036 Sepal.Width
11 Petal.Length 0.95 -0.85203579 0.77537142 Sepal.Width
12 Sepal.Length 0.95 -0.48871075 1.22952907 Sepal.Width
Group
1 x
2 x + Petal.Length
3 x + Petal.Length
4 x + Petal.Length + Sepal.Length
5 x + Petal.Length + Sepal.Length
6 x + Petal.Length + Sepal.Length
7 x
8 x + Petal.Length
9 x + Petal.Length
10 x + Petal.Length + Sepal.Length
11 x + Petal.Length + Sepal.Length
12 x + Petal.Length + Sepal.Length
---
Code
print(model_parameters(mod))
Output
# Petal.Width response
Parameter | Coefficient | SE | 95% CI | t(2) | p
----------------------------------------------------------------
x | 0.01 | 0.02 | [-0.07, 0.10] | 0.73 | 0.541
Petal Length | 0.23 | 0.07 | [-0.07, 0.53] | 3.34 | 0.079
# Sepal.Width response
Parameter | Coefficient | SE | 95% CI | t(2) | p
----------------------------------------------------------------
x | 0.04 | 0.06 | [-0.22, 0.31] | 0.71 | 0.553
Petal Length | 0.30 | 0.06 | [ 0.05, 0.54] | 5.15 | 0.036
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(ci(mod))
Output
Parameter CI CI_low CI_high Response
1 x 0.95 -0.06835071 0.09635073 Petal.Width
2 Petal.Length 0.95 -0.06642354 0.52593096 Petal.Width
3 x 0.95 -0.22124463 0.30818414 Sepal.Width
4 Petal.Length 0.95 0.04898068 0.54369328 Sepal.Width
---
Code
print(model_parameters(mod))
Output
# x
Parameter | Coefficient | SE | 95% CI | t(2) | p
-------------------------------------------------------------
x | 0.02 | 0.02 | [-0.06, 0.09] | 0.91 | 0.459
# x + Petal.Length
Parameter | Coefficient | SE | 95% CI | t(2) | p
----------------------------------------------------------------
x | 0.01 | 0.02 | [-0.07, 0.10] | 0.73 | 0.541
Petal.Length | 0.23 | 0.07 | [-0.07, 0.53] | 3.34 | 0.079
# x + Petal.Length + Sepal.Length
Parameter | Coefficient | SE | 95% CI | t(2) | p
-----------------------------------------------------------------
x | 0.01 | 0.02 | [-0.07, 0.10] | 0.74 | 0.539
Petal.Length | 0.23 | 0.08 | [-0.11, 0.58] | 2.93 | 0.099
Sepal.Length | -4.24e-03 | 0.03 | [-0.14, 0.13] | -0.13 | 0.906
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(ci(mod))
Output
Parameter CI CI_low CI_high Group
1 x 0.95 -0.06044147 0.09280643 x
2 x 0.95 -0.06835071 0.09635073 x + Petal.Length
3 Petal.Length 0.95 -0.06642354 0.52593096 x + Petal.Length
4 x 0.95 -0.06835856 0.09655518 x + Petal.Length + Sepal.Length
5 Petal.Length 0.95 -0.10895767 0.57612928 x + Petal.Length + Sepal.Length
6 Sepal.Length 0.95 -0.14108092 0.13259825 x + Petal.Length + Sepal.Length
parameters/tests/testthat/_snaps/brms.md 0000644 0001762 0000144 00000003157 14737236746 020220 0 ustar ligges users # mp, footer exp
Code
print(out)
Output
# Fixed Effects
Parameter | Median | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------------
(Intercept) | -0.25 | [-1.28, 0.75] | 68.62% | 0.999 | 3459.00
var_binom1 | -0.64 | [-2.09, 0.64] | 83.20% | 1.000 | 2820.00
groupsb | -0.22 | [-1.35, 0.87] | 64.75% | 1.000 | 3332.00
var_cont | -0.06 | [-0.14, 0.00] | 96.65% | 1.000 | 3528.00
var_binom1:groupsb | 0.53 | [-1.70, 2.69] | 69.25% | 1.000 | 2699.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
---
Code
print(out)
Output
# Fixed Effects
Parameter | Median | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------------
(Intercept) | 0.78 | [0.28, 2.11] | 68.62% | 0.999 | 3459.00
var_binom1 | 0.53 | [0.12, 1.90] | 83.20% | 1.000 | 2820.00
groupsb | 0.80 | [0.26, 2.38] | 64.75% | 1.000 | 3332.00
var_cont | 0.94 | [0.87, 1.00] | 96.65% | 1.000 | 3528.00
var_binom1:groupsb | 1.69 | [0.18, 14.80] | 69.25% | 1.000 | 2699.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
parameters/tests/testthat/_snaps/gam.md 0000644 0001762 0000144 00000001155 14515741330 017775 0 ustar ligges users # model_parameters
Code
mp
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | t(383.05) | p
--------------------------------------------------------------------
(Intercept) | 7.97 | 0.10 | [7.77, 8.17] | 78.10 | < .001
# Smooth Terms
Parameter | F | df | p
----------------------------------------
Smooth term (x0) | 10.53 | 3.63 | < .001
Smooth term (x1) | 87.44 | 2.97 | < .001
Smooth term (x2) | 72.49 | 8.30 | < .001
Smooth term (x3) | 9.58 | 1.05 | 0.002
parameters/tests/testthat/_snaps/model_parameters_ordinal.md 0000644 0001762 0000144 00000005161 14736731407 024276 0 ustar ligges users # model_parameters.clm
Code
print(mp)
Output
# Intercept
Parameter | Coefficient | SE | 95% CI | z | p
-----------------------------------------------------------------------------
Confidence1|Confidence2 | 0.48 | 0.02 | [0.45, 0.52] | -20.13 | < .001
Confidence2|Confidence3 | 0.85 | 0.03 | [0.80, 0.91] | -5.02 | < .001
Confidence3|Confidence4 | 1.30 | 0.04 | [1.23, 1.39] | 8.52 | < .001
Confidence4|Confidence5 | 2.01 | 0.07 | [1.88, 2.14] | 20.39 | < .001
Confidence5|Confidence6 | 3.44 | 0.15 | [3.16, 3.74] | 29.03 | < .001
# Location Parameters
Parameter | Estimate | SE | 95% CI | z | p
------------------------------------------------------------
Stim [Old] | 0.55 | 0.04 | [0.47, 0.63] | 13.64 | < .001
# Scale Parameters
Parameter | Estimate | SE | 95% CI | z | p
------------------------------------------------------------
Stim [Old] | -0.04 | 0.04 | [0.47, 0.63] | 13.64 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# model_parameters.clm2
Code
print(mp)
Output
# Intercept
Parameter | Coefficient | SE | 95% CI | z | p
-----------------------------------------------------------------------------
Confidence1|Confidence2 | 0.48 | 0.02 | [0.45, 0.52] | -20.13 | < .001
Confidence2|Confidence3 | 0.85 | 0.03 | [0.80, 0.91] | -5.02 | < .001
Confidence3|Confidence4 | 1.30 | 0.04 | [1.23, 1.39] | 8.52 | < .001
Confidence4|Confidence5 | 2.01 | 0.07 | [1.88, 2.14] | 20.39 | < .001
Confidence5|Confidence6 | 3.44 | 0.15 | [3.16, 3.74] | 29.03 | < .001
# Location Parameters
Parameter | Estimate | SE | 95% CI | z | p
------------------------------------------------------------
Stim [Old] | 0.55 | 0.04 | [0.47, 0.63] | 13.64 | < .001
# Scale Parameters
Parameter | Estimate | SE | 95% CI | z | p
------------------------------------------------------------
Stim [Old] | -0.04 | 0.04 | [-0.12, 0.04] | -1.11 | 0.268
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/model_parameters.mclogit.md 0000644 0001762 0000144 00000006667 14716604201 024224 0 ustar ligges users # model_parameters.mclogit
Code
params
Output
Parameter | Log-Odds | SE | 95% CI | z | p
--------------------------------------------------------------
distance | -1.44 | 0.05 | [-1.54, -1.34] | -27.07 | < .001
cost | -0.98 | 0.04 | [-1.06, -0.90] | -24.52 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# model_parameters.mblogit
Code
params
Output
# Response level: medium
Parameter | Log-Odds | SE | 95% CI | z | p
-----------------------------------------------------------------
(Intercept) | -0.42 | 0.17 | [-0.76, -0.08] | -2.42 | 0.015
InflMedium | 0.45 | 0.14 | [ 0.17, 0.72] | 3.15 | 0.002
InflHigh | 0.66 | 0.19 | [ 0.30, 1.03] | 3.57 | < .001
TypeApartment | -0.44 | 0.17 | [-0.77, -0.10] | -2.53 | 0.012
TypeAtrium | 0.13 | 0.22 | [-0.31, 0.57] | 0.59 | 0.556
TypeTerrace | -0.67 | 0.21 | [-1.07, -0.26] | -3.23 | 0.001
ContHigh | 0.36 | 0.13 | [ 0.10, 0.62] | 2.73 | 0.006
# Response level: high
Parameter | Log-Odds | SE | 95% CI | z | p
-----------------------------------------------------------------
(Intercept) | -0.14 | 0.16 | [-0.45, 0.17] | -0.87 | 0.384
InflMedium | 0.73 | 0.14 | [ 0.47, 1.00] | 5.37 | < .001
InflHigh | 1.61 | 0.17 | [ 1.29, 1.94] | 9.65 | < .001
TypeApartment | -0.74 | 0.16 | [-1.04, -0.43] | -4.74 | < .001
TypeAtrium | -0.41 | 0.21 | [-0.82, 0.01] | -1.93 | 0.054
TypeTerrace | -1.41 | 0.20 | [-1.80, -1.02] | -7.06 | < .001
ContHigh | 0.48 | 0.12 | [ 0.24, 0.73] | 3.88 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# simulate_parameters.mblogit
Code
params
Output
# Medium response
Parameter | Coefficient | 95% CI | p
-----------------------------------------------------
(Intercept) | -0.42 | [-0.73, -0.09] | 0.020
InflMedium | 0.44 | [ 0.17, 0.71] | < .001
InflHigh | 0.66 | [ 0.31, 1.02] | < .001
TypeApartment | -0.43 | [-0.78, -0.11] | 0.012
TypeAtrium | 0.12 | [-0.28, 0.58] | 0.588
TypeTerrace | -0.66 | [-1.07, -0.27] | 0.002
ContHigh | 0.35 | [ 0.10, 0.60] | 0.002
# High response
Parameter | Coefficient | 95% CI | p
-----------------------------------------------------
(Intercept) | -0.13 | [-0.43, 0.18] | 0.390
InflMedium | 0.74 | [ 0.46, 0.99] | < .001
InflHigh | 1.61 | [ 1.31, 1.94] | < .001
TypeApartment | -0.74 | [-1.04, -0.42] | < .001
TypeAtrium | -0.41 | [-0.82, -0.01] | 0.048
TypeTerrace | -1.42 | [-1.83, -1.04] | < .001
ContHigh | 0.48 | [ 0.23, 0.72] | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a MCMC distribution approximation.
parameters/tests/testthat/_snaps/averaging.md 0000644 0001762 0000144 00000004153 14721362233 021175 0 ustar ligges users # MuMIn link functions
Code
print(mp)
Output
Parameter | Log-Odds | SE | 95% CI | z | p
----------------------------------------------------------------
(Intercept) | -1.01 | 0.26 | [-1.51, -0.50] | 3.91 | < .001
var cont | -0.42 | 0.25 | [-0.90, 0.07] | 1.70 | 0.090
var binom [1] | -0.71 | 0.62 | [-1.92, 0.50] | 1.15 | 0.250
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
# ggpredict, glmmTMB averaging
Code
print(mp)
Output
Parameter | Coefficient | SE | 95% CI | z | p
---------------------------------------------------------------------------------
cond((Int)) | -0.11 | 0.22 | [ -0.55, 0.32] | 0.52 | 0.605
cond(income) | -0.01 | 3.20e-03 | [ -0.02, -0.01] | 4.07 | < .001
zi((Int)) | -23.11 | 17557.33 | [-34434.85, 34388.63] | 1.32e-03 | 0.999
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# ggpredict, poly averaging
Code
print(mp)
Output
Parameter | Coefficient | SE | 95% CI | z | p
----------------------------------------------------------------------
(Intercept) | 954.50 | 123.60 | [712.26, 1196.75] | 7.72 | < .001
gear | -24.81 | 18.54 | [-61.14, 11.52] | 1.34 | 0.181
mpg | -51.21 | 11.60 | [-73.96, -28.47] | 4.41 | < .001
mpg^2 | 0.79 | 0.26 | [ 0.29, 1.30] | 3.07 | 0.002
am [1] | -30.80 | 32.30 | [-94.11, 32.52] | 0.95 | 0.340
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/printing-stan.md 0000644 0001762 0000144 00000025471 14737236746 022055 0 ustar ligges users # print brms
Code
mp1
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------
(Intercept) | 39.68 | [36.12, 43.27] | 100% | 1.000 | 5242.00
wt | -3.21 | [-4.79, -1.65] | 99.95% | 1.000 | 2071.00
cyl | -1.50 | [-2.36, -0.64] | 99.95% | 1.000 | 1951.00
# Sigma
Parameter | Mean | 95% CI | pd | Rhat | ESS
--------------------------------------------------------
sigma | 2.67 | [2.06, 3.51] | 100% | 1.000 | 2390.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
mp2
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
-----------------------------------------------------------
(Intercept) | 33.55 | [24.17, 40.87] | 100% | 1.091 | 24.00
wt | -4.49 | [-6.95, -1.68] | 100% | 1.192 | 10.00
# Sigma
Parameter | Mean | 95% CI | pd | Rhat | ESS
-------------------------------------------------------
sigma | 2.56 | [1.95, 3.48] | 100% | 1.015 | 454.00
# Random Effects Variances
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------------------
SD (Intercept: cyl) | 3.00 | [ 0.39, 9.19] | 100% | 1.080 | 32.00
SD (Intercept: gear) | 3.88 | [ 0.21, 10.30] | 100% | 1.010 | 424.00
SD (wt: gear) | 1.96 | [ 0.06, 5.06] | 100% | 1.385 | 9.00
Cor (Intercept~wt: gear) | -0.25 | [-0.99, 0.83] | 62.48% | 1.106 | 36.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
mp3
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------
(Intercept) | 251.32 | [237.00, 265.98] | 100% | 1.001 | 1621.00
Days | 10.44 | [ 6.84, 13.91] | 100% | 1.004 | 1161.00
# Sigma
Parameter | Mean | 95% CI | pd | Rhat | ESS
-----------------------------------------------------------
sigma | 25.94 | [23.05, 29.38] | 100% | 1.000 | 3672.00
# Random Effects Variances
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------------------------
SD (Intercept: Subject) | 26.63 | [15.46, 42.36] | 100% | 1.002 | 1823.00
SD (Days: Subject) | 6.58 | [ 4.12, 10.16] | 100% | 1.000 | 1228.00
Cor (Intercept~Days: Subject) | 0.09 | [-0.47, 0.67] | 60.42% | 1.003 | 899.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
mp4
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------
(Intercept) | 250.84 | [228.76, 272.54] | 100% | 1.003 | 786.00
Days | 10.37 | [ 8.77, 11.96] | 100% | 0.999 | 6026.00
# Sigma
Parameter | Mean | 95% CI | pd | Rhat | ESS
-----------------------------------------------------------
sigma | 30.03 | [26.27, 34.03] | 100% | 0.999 | 2102.00
# Random Effects Variances
Parameter | Mean | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------------------
SD (Intercept: grp) | 8.22 | [ 0.44, 25.69] | 100% | 1.000 | 1604.00
SD (Intercept: grp:subgrp) | 7.41 | [ 0.44, 16.87] | 100% | 1.003 | 770.00
SD (Intercept: Subject) | 38.51 | [26.89, 55.98] | 100% | 1.003 | 1254.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
mp5
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
------------------------------------------------------------
(Intercept) | 2.57 | [0.70, 4.84] | 99.42% | 1.012 | 292.00
Petal.Width | 1.05 | [0.73, 1.37] | 100% | 1.002 | 2150.00
# Sigma
Parameter | Mean | 95% CI | pd | Rhat | ESS
--------------------------------------------------------
sigma | 0.38 | [0.34, 0.43] | 100% | 1.001 | 2642.00
# Random Effects Variances
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------------
SD (Intercept: Species) | 1.68 | [0.64, 3.64] | 100% | 1.003 | 796.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
mp6
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
--------------------------------------------------------------
(Intercept) | 33.06 | [24.70, 40.47] | 100% | 1.006 | 744.00
wt | -4.39 | [-6.94, -1.76] | 99.72% | 1.025 | 83.00
# Sigma
Parameter | Mean | 95% CI | pd | Rhat | ESS
-------------------------------------------------------
sigma | 2.59 | [1.96, 3.48] | 100% | 1.010 | 608.00
# Random Effects Variances
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------------------
SD (Intercept: cyl) | 3.19 | [ 0.49, 9.00] | 100% | 1.001 | 651.00
SD (Intercept: gear) | 3.76 | [ 0.14, 10.13] | 100% | 1.015 | 643.00
SD (wt: gear) | 1.47 | [ 0.06, 3.96] | 100% | 1.039 | 94.00
Cor (Intercept~wt: gear) | -0.38 | [-0.99, 0.82] | 76.85% | 1.003 | 854.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
mp7
Output
# Fixed Effects
Parameter | Mean | 95% CI | pd | Rhat | ESS
-------------------------------------------------------------
(Intercept) | -1.07 | [-1.42, -0.73] | 100% | 1.000 | 3259.00
persons | 0.90 | [ 0.81, 0.99] | 100% | 1.000 | 3305.00
child | -1.17 | [-1.37, -0.99] | 100% | 1.000 | 3224.00
camper | 0.74 | [ 0.56, 0.94] | 100% | 1.000 | 4166.00
# Zero-Inflation
Parameter | Mean | 95% CI | pd | Rhat | ESS
--------------------------------------------------------------
(Intercept) | -0.58 | [-1.27, 0.08] | 95.97% | 1.000 | 4494.00
child | 1.24 | [ 0.71, 1.82] | 100% | 1.000 | 4195.00
camper | -0.62 | [-1.38, 0.11] | 94.73% | 1.000 | 4427.00
---
Code
mp8
Output
# Fixed Effects (Count Model)
Parameter | Mean | 95% CI | pd | Rhat | ESS
--------------------------------------------------------------
(Intercept) | 0.96 | [-0.81, 2.51] | 90.00% | 1.011 | 110.00
child | -1.16 | [-1.36, -0.94] | 100% | 0.996 | 278.00
camper | 0.72 | [ 0.54, 0.91] | 100% | 0.996 | 271.00
# Fixed Effects (Zero-Inflation Component)
Parameter | Mean | 95% CI | pd | Rhat | ESS
--------------------------------------------------------------
(Intercept) | -0.51 | [-2.03, 0.89] | 78.00% | 0.997 | 138.00
child | 1.86 | [ 1.19, 2.54] | 100% | 0.996 | 303.00
camper | -0.86 | [-1.61, -0.07] | 98.40% | 0.996 | 292.00
# Random Effects Variances
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------------
SD (Intercept: persons) | 1.58 | [0.71, 3.58] | 100% | 1.010 | 126.00
# Random Effects (Zero-Inflation Component)
Parameter | Mean | 95% CI | pd | Rhat | ESS
---------------------------------------------------------------------
SD (Intercept: persons) | 1.49 | [0.63, 3.41] | 100% | 0.996 | 129.00
---
Code
mp9
Output
Parameter | Mean | 95% CI | pd | Rhat | ESS
-----------------------------------------------------------------
Intercept[1] | -38.42 | [-67.76, -19.66] | 100% | 1.002 | 992.00
Intercept[2] | -33.26 | [-59.09, -16.53] | 100% | 1.001 | 1039.00
mpg | -1.80 | [ -3.20, -0.90] | 100% | 1.002 | 1021.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
# print-information
Code
out
Output
# Fixed Effects
Parameter | Median | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------
(Intercept) | 39.68 | [36.12, 43.27] | 100% | 1.000 | 5242.00
wt | -3.20 | [-4.79, -1.65] | 99.95% | 1.000 | 2071.00
cyl | -1.49 | [-2.36, -0.64] | 99.95% | 1.000 | 1951.00
# Sigma
Parameter | Median | 95% CI | pd | Rhat | ESS
----------------------------------------------------------
sigma | 2.63 | [2.06, 3.51] | 100% | 1.000 | 2390.00
Message
Uncertainty intervals (equal-tailed) computed using a MCMC distribution
approximation.
---
Code
out
Output
# Fixed Effects
Parameter | Median | 95% CI | pd | Rhat | ESS
----------------------------------------------------------------
(Intercept) | 39.68 | [36.27, 43.34] | 100% | 1.000 | 5242.00
wt | -3.20 | [-4.70, -1.57] | 99.95% | 1.000 | 2071.00
cyl | -1.49 | [-2.38, -0.68] | 99.95% | 1.000 | 1951.00
# Sigma
Parameter | Median | 95% CI | pd | Rhat | ESS
----------------------------------------------------------
sigma | 2.63 | [1.99, 3.39] | 100% | 1.000 | 2390.00
Message
Uncertainty intervals (highest-density) computed using a MCMC
distribution approximation.
parameters/tests/testthat/_snaps/pca.md 0000644 0001762 0000144 00000002232 14716604201 017767 0 ustar ligges users # print model_parameters pca
Code
print(principal_components(mtcars[, 1:4], n = "auto"))
Output
# Loadings from Principal Component Analysis (no rotation)
Variable | PC1 | Complexity
-----------------------------
mpg | -0.93 | 1.00
cyl | 0.96 | 1.00
disp | 0.95 | 1.00
hp | 0.91 | 1.00
The unique principal component accounted for 87.55% of the total variance of the original data.
---
Code
print(principal_components(mtcars[, 1:4], n = "auto"), labels = c(
"Miles/(US) gallon", "Number of cylinders", "Displacement (cu.in.)",
"Gross horsepower"))
Output
# Loadings from Principal Component Analysis (no rotation)
Variable | Label | PC1 | Complexity
-----------------------------------------------------
mpg | Miles/(US) gallon | -0.93 | 1.00
cyl | Number of cylinders | 0.96 | 1.00
disp | Displacement (cu.in.) | 0.95 | 1.00
hp | Gross horsepower | 0.91 | 1.00
parameters/tests/testthat/_snaps/glmmTMB.md 0000644 0001762 0000144 00000026256 14716604200 020536 0 ustar ligges users # print-model_parameters glmmTMB
Code
out[-5]
Output
[1] "# Fixed Effects"
[2] ""
[3] "Parameter | Log-Mean | SE | 95% CI | z | p"
[4] "----------------------------------------------------------------"
[5] "child | -1.09 | 0.10 | [-1.28, -0.90] | -11.09 | < .001"
[6] "camper [1] | 0.27 | 0.10 | [ 0.07, 0.47] | 2.70 | 0.007 "
# print-model_parameters glmmTMB digits
Code
out[-c(5, 14)]
Output
[1] "# Fixed Effects (Count Model)"
[2] ""
[3] "Parameter | Log-Mean | SE | 95% CI | z | p"
[4] "--------------------------------------------------------------------------"
[5] "child | -1.0875 | 0.0981 | [-1.27967, -0.89528] | -11.0901 | < .001"
[6] "camper [1] | 0.2723 | 0.1009 | [ 0.07461, 0.46999] | 2.6997 | 0.007 "
[7] ""
[8] "# Fixed Effects (Zero-Inflation Component)"
[9] ""
[10] "Parameter | Log-Odds | SE | 95% CI | z | p"
[11] "-----------------------------------------------------------------------"
[12] "(Intercept) | 1.8896 | 0.6642 | [ 0.58780, 3.19147] | 2.8449 | 0.004"
[13] "camper [1] | -0.1701 | 0.3869 | [-0.92836, 0.58822] | -0.4396 | 0.660"
[14] ""
[15] "# Random Effects Variances"
[16] ""
[17] "Parameter | Coefficient | 95% CI"
[18] "---------------------------------------------------------------"
[19] "SD (Intercept: persons) | 3.4056 | [ 1.64567, 7.04777]"
[20] "SD (xb: persons) | 1.2132 | [ 0.59190, 2.48650]"
[21] "Cor (Intercept~xb: persons) | -1.0000 | [-1.00000, 1.00000]"
[22] ""
[23] "# Random Effects (Zero-Inflation Component)"
[24] ""
[25] "Parameter | Coefficient | 95% CI"
[26] "---------------------------------------------------------------"
[27] "SD (Intercept: persons) | 2.7358 | [ 1.16329, 6.43414]"
[28] "SD (zg: persons) | 1.5683 | [ 0.64246, 3.82852]"
[29] "Cor (Intercept~zg: persons) | 1.0000 | [-1.00000, 1.00000]"
---
Code
out[-c(5, 14)]
Output
[1] "# Fixed Effects (Count Model)"
[2] ""
[3] "Parameter | Log-Mean | SE | 95% CI | z | p"
[4] "--------------------------------------------------------------------------"
[5] "child | -1.0875 | 0.0981 | [-1.27967, -0.89528] | -11.0901 | < .001"
[6] "camper [1] | 0.2723 | 0.1009 | [ 0.07461, 0.46999] | 2.6997 | 0.007 "
[7] ""
[8] "# Fixed Effects (Zero-Inflation Component)"
[9] ""
[10] "Parameter | Log-Odds | SE | 95% CI | z | p"
[11] "-----------------------------------------------------------------------"
[12] "(Intercept) | 1.8896 | 0.6642 | [ 0.58780, 3.19147] | 2.8449 | 0.004"
[13] "camper [1] | -0.1701 | 0.3869 | [-0.92836, 0.58822] | -0.4396 | 0.660"
[14] ""
[15] "# Random Effects Variances"
[16] ""
[17] "Parameter | Coefficient | 95% CI"
[18] "---------------------------------------------------------------"
[19] "SD (Intercept: persons) | 3.4056 | [ 1.64567, 7.04777]"
[20] "SD (xb: persons) | 1.2132 | [ 0.59190, 2.48650]"
[21] "Cor (Intercept~xb: persons) | -1.0000 | [-1.00000, 1.00000]"
[22] ""
[23] "# Random Effects (Zero-Inflation Component)"
[24] ""
[25] "Parameter | Coefficient | 95% CI"
[26] "---------------------------------------------------------------"
[27] "SD (Intercept: persons) | 2.7358 | [ 1.16329, 6.43414]"
[28] "SD (zg: persons) | 1.5683 | [ 0.64246, 3.82852]"
[29] "Cor (Intercept~zg: persons) | 1.0000 | [-1.00000, 1.00000]"
# print-model_parameters glmmTMB CI alignment
Code
print(mp)
Output
# Random Effects: conditional
Parameter | Coefficient | 95% CI
----------------------------------------------------------------
SD (Intercept: Session:Participant) | 0.27 | [0.08, 0.87]
SD (Intercept: Participant) | 0.38 | [0.16, 0.92]
# Random Effects: zero_inflated
Parameter | Coefficient | 95% CI
----------------------------------------------------------------
SD (Intercept: Session:Participant) | 0.69 | [0.40, 1.19]
SD (Intercept: Participant) | 2.39 | [1.25, 4.57]
Message
Uncertainty intervals for random effect variances computed using a
Wald z-distribution approximation.
---
Code
print(mp)
Output
# Fixed Effects
Parameter | Log-Mean | SE | 95% CI | z | p
---------------------------------------------------------------------
(Intercept) | 2.12 | 0.30 | [ 1.53, 2.71] | 7.05 | < .001
Surface [Lingual] | 0.01 | 0.29 | [-0.56, 0.58] | 0.04 | 0.971
Surface [Occlusal] | 0.54 | 0.22 | [ 0.10, 0.98] | 2.43 | 0.015
Side [Anterior] | 0.04 | 0.32 | [-0.58, 0.66] | 0.14 | 0.889
Side [Left] | -0.04 | 0.20 | [-0.44, 0.37] | -0.17 | 0.862
Jaw [Maxillar] | -0.10 | 0.21 | [-0.51, 0.30] | -0.51 | 0.612
# Zero-Inflation
Parameter | Log-Odds | SE | 95% CI | z | p
----------------------------------------------------------------------
(Intercept) | 4.87 | 0.93 | [ 3.04, 6.69] | 5.23 | < .001
Surface [Lingual] | 0.93 | 0.34 | [ 0.27, 1.60] | 2.75 | 0.006
Surface [Occlusal] | -1.01 | 0.29 | [-1.59, -0.44] | -3.45 | < .001
Side [Anterior] | -0.20 | 0.37 | [-0.93, 0.52] | -0.55 | 0.583
Side [Left] | -0.38 | 0.27 | [-0.91, 0.14] | -1.44 | 0.151
Jaw [Maxillar] | 0.59 | 0.24 | [ 0.11, 1.07] | 2.42 | 0.016
# Dispersion
Parameter | Coefficient | 95% CI
----------------------------------------
(Intercept) | 2.06 | [1.30, 3.27]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# print-model_parameters
Code
mp
Output
# Fixed Effects
Parameter | Log-Mean | SE | 95% CI | z | p
----------------------------------------------------------------
(Intercept) | 1.26 | 0.48 | [ 0.33, 2.19] | 2.66 | 0.008
child | -1.14 | 0.09 | [-1.32, -0.96] | -12.27 | < .001
camper [1] | 0.73 | 0.09 | [ 0.55, 0.92] | 7.85 | < .001
# Zero-Inflation
Parameter | Log-Odds | SE | 95% CI | z | p
---------------------------------------------------------------
(Intercept) | -0.39 | 0.65 | [-1.67, 0.89] | -0.60 | 0.551
child | 2.05 | 0.31 | [ 1.45, 2.66] | 6.63 | < .001
camper [1] | -1.01 | 0.32 | [-1.64, -0.37] | -3.12 | 0.002
---
Code
mp
Output
# Fixed Effects
Parameter | IRR | SE | 95% CI | z | p
----------------------------------------------------------
(Intercept) | 3.54 | 1.68 | [1.39, 8.98] | 2.66 | 0.008
child | 0.32 | 0.03 | [0.27, 0.38] | -12.27 | < .001
camper [1] | 2.08 | 0.19 | [1.73, 2.50] | 7.85 | < .001
# Zero-Inflation
Parameter | Odds Ratio | SE | 95% CI | z | p
----------------------------------------------------------------
(Intercept) | 0.68 | 0.44 | [0.19, 2.43] | -0.60 | 0.551
child | 7.80 | 2.42 | [4.25, 14.32] | 6.63 | < .001
camper [1] | 0.36 | 0.12 | [0.19, 0.69] | -3.12 | 0.002
---
Code
mp
Output
# Fixed Effects (Count Model)
Parameter | Log-Mean | SE | 95% CI | z | p
----------------------------------------------------------------
(Intercept) | 1.26 | 0.48 | [ 0.33, 2.19] | 2.66 | 0.008
child | -1.14 | 0.09 | [-1.32, -0.96] | -12.27 | < .001
camper [1] | 0.73 | 0.09 | [ 0.55, 0.92] | 7.85 | < .001
# Fixed Effects (Zero-Inflation Component)
Parameter | Log-Odds | SE | 95% CI | z | p
---------------------------------------------------------------
(Intercept) | -0.39 | 0.65 | [-1.67, 0.89] | -0.60 | 0.551
child | 2.05 | 0.31 | [ 1.45, 2.66] | 6.63 | < .001
camper [1] | -1.01 | 0.32 | [-1.64, -0.37] | -3.12 | 0.002
# Random Effects Variances
Parameter | Coefficient | 95% CI
----------------------------------------------------
SD (Intercept: persons) | 0.93 | [0.46, 1.89]
# Random Effects (Zero-Inflation Component)
Parameter | Coefficient | 95% CI
----------------------------------------------------
SD (Intercept: persons) | 1.17 | [0.54, 2.57]
parameters/tests/testthat/_snaps/equivalence_test/ 0000755 0001762 0000144 00000000000 14761611436 022253 5 ustar ligges users parameters/tests/testthat/_snaps/equivalence_test/equivalence-test-4.svg 0000644 0001762 0000144 00000022013 14716604200 026400 0 ustar ligges users
parameters/tests/testthat/_snaps/equivalence_test/equivalence-test-5.svg 0000644 0001762 0000144 00000022014 14716604200 026402 0 ustar ligges users
parameters/tests/testthat/_snaps/equivalence_test/equivalence-test-3.svg 0000644 0001762 0000144 00000022011 14716604200 026375 0 ustar ligges users
parameters/tests/testthat/_snaps/equivalence_test/equivalence-test-2.svg 0000644 0001762 0000144 00000015206 14716604200 026404 0 ustar ligges users
parameters/tests/testthat/_snaps/equivalence_test/equivalence-test-1.svg 0000644 0001762 0000144 00000014350 14716604200 026402 0 ustar ligges users
parameters/tests/testthat/_snaps/include_reference.md 0000644 0001762 0000144 00000016372 14716604200 022676 0 ustar ligges users # include_reference, on-the-fly factors
Code
print(out1)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
------------------------------------------------------------------
(Intercept) | 27.48 | 1.97 | [23.43, 31.53] | 13.92 | < .001
gear [3] | 0.00 | | | |
gear [4] | 0.08 | 1.83 | [-3.68, 3.83] | 0.04 | 0.967
gear [5] | 2.39 | 2.38 | [-2.50, 7.29] | 1.00 | 0.324
am [0] | 0.00 | | | |
am [1] | 4.14 | 1.81 | [ 0.42, 7.85] | 2.29 | 0.030
hp | -0.06 | 0.01 | [-0.09, -0.04] | -6.24 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out2)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
------------------------------------------------------------------
(Intercept) | 27.48 | 1.97 | [23.43, 31.53] | 13.92 | < .001
gear [3] | 0.00 | | | |
gear [4] | 0.08 | 1.83 | [-3.68, 3.83] | 0.04 | 0.967
gear [5] | 2.39 | 2.38 | [-2.50, 7.29] | 1.00 | 0.324
am [0] | 0.00 | | | |
am [1] | 4.14 | 1.81 | [ 0.42, 7.85] | 2.29 | 0.030
hp | -0.06 | 0.01 | [-0.09, -0.04] | -6.24 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print_md(out, engine = "tt")
Output
+--------------+----------------------+----------------------+
| Parameter | m1 | m2 |
+==============+======================+======================+
| (Intercept) | 27.48 (23.43, 31.53) | 27.48 (23.43, 31.53) |
+--------------+----------------------+----------------------+
| gear (3) | 0.00 | 0.00 |
+--------------+----------------------+----------------------+
| gear (4) | 0.08 (-3.68, 3.83) | 0.08 (-3.68, 3.83) |
+--------------+----------------------+----------------------+
| gear (5) | 2.39 (-2.50, 7.29) | 2.39 (-2.50, 7.29) |
+--------------+----------------------+----------------------+
| am (0) | 0.00 | 0.00 |
+--------------+----------------------+----------------------+
| am (1) | 4.14 (0.42, 7.85) | 4.14 (0.42, 7.85) |
+--------------+----------------------+----------------------+
| hp | -0.06 (-0.09, -0.04) | -0.06 (-0.09, -0.04) |
+--------------+----------------------+----------------------+
| | | |
+--------------+----------------------+----------------------+
| Observations | 32 | 32 |
+--------------+----------------------+----------------------+
# include_reference, different contrasts
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
-------------------------------------------------------------------
(Intercept) | 19.70 | 1.18 | [ 17.28, 22.11] | 16.71 | < .001
cyl [6] | -6.66 | 1.63 | [-10.00, -3.31] | -4.09 | < .001
cyl [8] | -10.54 | 1.96 | [-14.56, -6.52] | -5.38 | < .001
gear [3] | 0.00 | | | |
gear [4] | 1.32 | 1.93 | [ -2.63, 5.28] | 0.69 | 0.498
gear [5] | 1.50 | 1.85 | [ -2.31, 5.31] | 0.81 | 0.426
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
-------------------------------------------------------------------
(Intercept) | 25.43 | 1.88 | [ 21.57, 29.29] | 13.52 | < .001
cyl [4] | 0.00 | | | |
cyl [6] | -6.66 | 1.63 | [-10.00, -3.31] | -4.09 | < .001
cyl [8] | -10.54 | 1.96 | [-14.56, -6.52] | -5.38 | < .001
gear [3] | 0.00 | | | |
gear [4] | 1.32 | 1.93 | [ -2.63, 5.28] | 0.69 | 0.498
gear [5] | 1.50 | 1.85 | [ -2.31, 5.31] | 0.81 | 0.426
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
-------------------------------------------------------------------
(Intercept) | 20.64 | 0.67 | [ 19.26, 22.01] | 30.76 | < .001
cyl [6] | -6.66 | 1.63 | [-10.00, -3.31] | -4.09 | < .001
cyl [8] | -10.54 | 1.96 | [-14.56, -6.52] | -5.38 | < .001
gear [1] | -0.94 | 1.09 | [ -3.18, 1.30] | -0.86 | 0.396
gear [2] | 0.38 | 1.11 | [ -1.90, 2.67] | 0.34 | 0.734
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
------------------------------------------------------------------
(Intercept) | 15.83 | 1.24 | [13.28, 18.37] | 12.75 | < .001
cyl [8] | 0.00 | | | |
cyl [4] | 10.54 | 1.96 | [ 6.52, 14.56] | 5.38 | < .001
cyl [6] | 3.89 | 1.88 | [ 0.03, 7.75] | 2.07 | 0.049
gear [1] | -0.94 | 1.09 | [-3.18, 1.30] | -0.86 | 0.396
gear [2] | 0.38 | 1.11 | [-1.90, 2.67] | 0.34 | 0.734
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(27) | p
------------------------------------------------------------------
(Intercept) | 14.89 | 0.92 | [13.00, 16.77] | 16.19 | < .001
cyl [8] | 0.00 | | | |
cyl [4] | 10.54 | 1.96 | [ 6.52, 14.56] | 5.38 | < .001
cyl [6] | 3.89 | 1.88 | [ 0.03, 7.75] | 2.07 | 0.049
gear [3] | 0.00 | | | |
gear [4] | 1.32 | 1.93 | [-2.63, 5.28] | 0.69 | 0.498
gear [5] | 1.50 | 1.85 | [-2.31, 5.31] | 0.81 | 0.426
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
parameters/tests/testthat/_snaps/emmGrid-df_colname.md 0000644 0001762 0000144 00000001427 14515741323 022706 0 ustar ligges users # print model_parameters
Code
mp
Output
machine | Marginal Means | SE | 95% CI | t(11) | p
-----------------------------------------------------------------
A | 40.38 | 0.72 | [38.79, 41.98] | 55.81 | < .001
B | 41.42 | 0.74 | [39.78, 43.06] | 55.64 | < .001
C | 38.80 | 0.79 | [37.06, 40.53] | 49.24 | < .001
---
Code
mp
Output
contrast | Coefficient | SE | 95% CI | t(11) | p
-------------------------------------------------------------
A - B | -0.65 | 0.65 | [-2.08, 0.78] | -1.00 | 0.339
A - C | 0.99 | 0.73 | [-0.60, 2.59] | 1.37 | 0.198
B - C | 1.64 | 0.80 | [-0.12, 3.40] | 2.05 | 0.065
parameters/tests/testthat/_snaps/weightit.md 0000644 0001762 0000144 00000004155 14761570351 021066 0 ustar ligges users # weightit, multinom
Code
print(model_parameters(fit4, exponentiate = TRUE), zap_small = TRUE)
Output
# Response level: 2
Parameter | Odds Ratio | SE | 95% CI | z | p
--------------------------------------------------------------
(Intercept) | 1.00 | 0.62 | [0.30, 3.39] | 0.00 | 0.998
treat | 1.08 | 0.25 | [0.68, 1.71] | 0.31 | 0.755
age | 0.97 | 0.01 | [0.95, 0.99] | -2.38 | 0.018
educ | 0.98 | 0.05 | [0.89, 1.08] | -0.33 | 0.738
# Response level: 3
Parameter | Odds Ratio | SE | 95% CI | z | p
---------------------------------------------------------------
(Intercept) | 0.05 | 0.04 | [0.01, 0.20] | -4.23 | < .001
treat | 1.18 | 0.29 | [0.73, 1.91] | 0.67 | 0.502
age | 1.00 | 0.01 | [0.98, 1.02] | -0.01 | 0.989
educ | 1.20 | 0.06 | [1.08, 1.33] | 3.51 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# weightit, ordinal
Code
print(model_parameters(fit5, exponentiate = TRUE), zap_small = TRUE)
Output
# Fixed Effects
Parameter | Odds Ratio | SE | 95% CI | z | p
------------------------------------------------------------
treat | 1.12 | 0.21 | [0.78, 1.61] | 0.60 | 0.549
age | 0.99 | 0.01 | [0.97, 1.01] | -0.78 | 0.436
educ | 1.11 | 0.04 | [1.03, 1.20] | 2.70 | 0.007
# Intercept
Parameter | Odds Ratio | SE | 95% CI | z | p
-------------------------------------------------------------
1|2 | 3.28 | 1.70 | [1.19, 9.04] | 2.30 | 0.022
2|3 | 9.84 | 5.03 | [3.61, 26.82] | 4.47 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/model_parameters.glmgee.md 0000644 0001762 0000144 00000001706 14716604201 024013 0 ustar ligges users # model_parameters.glmgee
Code
print(out)
Output
# Fixed Effects
Parameter | Log-Prevalence | SE | 95% CI | z | p
---------------------------------------------------------------------------------
(Intercept) | 5.90 | 0.10 | [ 5.70, 6.11] | 56.30 | < .001
days [1st degree] | 19.20 | 0.52 | [18.18, 20.22] | 37.03 | < .001
days [2nd degree] | -2.86 | 0.21 | [-3.26, -2.45] | -13.88 | < .001
days [3rd degree] | 5.42 | 0.18 | [ 5.06, 5.77] | 29.69 | < .001
days [4th degree] | -3.57 | 0.12 | [-3.82, -3.33] | -28.64 | < .001
treat [ozone-enriched] | -0.26 | 0.13 | [-0.51, -0.01] | -2.01 | 0.044
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/coxph.md 0000644 0001762 0000144 00000001364 14716604211 020353 0 ustar ligges users # model_parameters coxph-panel
Code
print(model_parameters(mod))
Output
Parameter | Coefficient | SE | 95% CI | Chi2(1) | p
-----------------------------------------------------------------------------
ph ecog [ok] | 0.36 | 0.20 | [-0.03, 0.75] | 3.19 | 0.074
ph ecog [limited] | 0.87 | 0.23 | [ 0.41, 1.33] | 13.87 | < .001
age, linear | 0.01 | 9.36e-03 | [-0.01, 0.03] | 1.30 | 0.253
age, nonlin | | | | 2.83 | 0.093
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/model_parameters.glm.md 0000644 0001762 0000144 00000002607 14716604201 023333 0 ustar ligges users # print digits model_parameters.lm
Code
params
Output
Parameter | Coefficient | SE | 95% CI | t(30) | p
------------------------------------------------------------------
(Intercept) | 37.29 | 1.88 | [33.45, 41.12] | 19.86 | < .001
wt | -5.34 | 0.56 | [-6.49, -4.20] | -9.56 | < .001
Model: mpg ~ wt (32 Observations)
Sigma: 3.046 (df = 30)
RMSE : 2.949
R2: 0.753; adjusted R2: 0.745
---
Code
params
Output
Parameter | Coefficient | SE | 95% CI | t(30) | p
------------------------------------------------------------------
(Intercept) | 37.29 | 1.88 | [33.45, 41.12] | 19.86 | < .001
wt | -5.34 | 0.56 | [-6.49, -4.20] | -9.56 | < .001
# model_parameters.glm - Gamma - print
Code
mp
Output
Parameter | Prevalence Ratio | SE | 95% CI | t(7) | p
---------------------------------------------------------------------------
(Intercept) | 245.48 | 46.72 | [173.66, 351.67] | 28.92 | < .001
u [log] | 0.55 | 0.03 | [ 0.49, 0.61] | -10.88 | < .001
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald t-distribution approximation.
parameters/tests/testthat/_snaps/panelr.md 0000644 0001762 0000144 00000001475 14716610165 020523 0 ustar ligges users # model_parameters, asym
Code
print(model_parameters(m4))
Output
Parameter | Coefficient | SE | 95% CI | t(3447) | p
--------------------------------------------------------------------
(Intercept) | 5.08 | 1.36 | [ 2.41, 7.75] | 3.73 | < .001
+lag(pov) | -0.70 | 0.73 | [-2.14, 0.74] | -0.95 | 0.344
-lag(pov) | 2.74 | 0.79 | [ 1.20, 4.29] | 3.48 | < .001
+spouse | -3.00 | 1.32 | [-5.58, -0.41] | -2.27 | 0.023
-spouse | -0.40 | 2.49 | [-5.28, 4.48] | -0.16 | 0.872
wave | -0.81 | 0.34 | [-1.48, -0.14] | -2.38 | 0.018
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
parameters/tests/testthat/_snaps/mipo.md 0000644 0001762 0000144 00000003464 14716604200 020177 0 ustar ligges users # param ordinal
Code
print(mp)
Output
# 6 response
Parameter | Coefficient | SE | 95% CI | Statistic | df | p
--------------------------------------------------------------------------------
(Intercept) | -54.29 | 46.90 | [-151.05, 42.46] | -1.16 | 24.19 | 0.258
disp | 0.22 | 0.39 | [ -0.58, 1.02] | 0.58 | 23.81 | 0.570
hp | 0.20 | 0.57 | [ -0.97, 1.38] | 0.36 | 23.73 | 0.724
# 8 response
Parameter | Coefficient | SE | 95% CI | Statistic | df | p
--------------------------------------------------------------------------------
(Intercept) | -92.86 | 67.62 | [-232.47, 46.75] | -1.37 | 23.87 | 0.182
disp | 0.26 | 0.40 | [ -0.57, 1.09] | 0.64 | 23.53 | 0.528
hp | 0.43 | 0.63 | [ -0.88, 1.73] | 0.67 | 24.15 | 0.507
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald distribution approximation.
# param normal
Code
print(mp)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | Statistic | df | p
----------------------------------------------------------------------------------
(Intercept) | 30.65 | 1.43 | [27.72, 33.58] | 21.46 | 26.96 | < .001
disp | -0.03 | 7.52e-03 | [-0.05, -0.02] | -4.40 | 25.57 | < .001
hp | -0.02 | 0.01 | [-0.05, 0.01] | -1.37 | 24.82 | 0.182
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald distribution approximation.
parameters/tests/testthat/_snaps/printing.md 0000644 0001762 0000144 00000044654 14726272305 021103 0 ustar ligges users # print model with multiple components
Code
print(out)
Output
# Fixed Effects (Count Model)
Parameter | IRR | SE | 95% CI | z | p
---------------------------------------------------------
(Intercept) | 0.54 | 0.22 | [0.25, 1.20] | -1.51 | 0.132
spp [PR] | 0.38 | 0.25 | [0.11, 1.35] | -1.50 | 0.134
spp [DM] | 1.19 | 0.28 | [0.75, 1.88] | 0.73 | 0.468
spp [EC-A] | 0.68 | 0.23 | [0.35, 1.33] | -1.13 | 0.258
spp [EC-L] | 1.63 | 0.39 | [1.02, 2.60] | 2.05 | 0.041
spp [DES-L] | 1.80 | 0.41 | [1.15, 2.82] | 2.59 | 0.010
spp [DF] | 0.89 | 0.22 | [0.55, 1.44] | -0.46 | 0.642
mined [no] | 4.18 | 1.53 | [2.04, 8.57] | 3.90 | < .001
# Fixed Effects (Zero-Inflation Component)
Parameter | Odds Ratio | SE | 95% CI | z | p
----------------------------------------------------------------
(Intercept) | 2.48 | 1.56 | [0.73, 8.51] | 1.45 | 0.147
spp [PR] | 3.19 | 4.26 | [0.23, 43.70] | 0.87 | 0.384
spp [DM] | 0.39 | 0.31 | [0.08, 1.88] | -1.17 | 0.241
spp [EC-A] | 2.84 | 2.02 | [0.70, 11.49] | 1.46 | 0.144
spp [EC-L] | 0.57 | 0.41 | [0.14, 2.37] | -0.77 | 0.439
spp [DES-L] | 0.41 | 0.31 | [0.09, 1.79] | -1.19 | 0.236
spp [DF] | 0.08 | 0.17 | [0.00, 5.68] | -1.16 | 0.244
mined [no] | 0.08 | 0.05 | [0.02, 0.25] | -4.24 | < .001
# Dispersion
Parameter | Coefficient | 95% CI
----------------------------------------
(Intercept) | 1.51 | [0.93, 2.46]
# Random Effects Variances
Parameter | Coefficient | 95% CI
-------------------------------------------------
SD (Intercept: site) | 0.38 | [0.17, 0.87]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
---
Code
print(out, split_component = FALSE)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | z | p | Effects | Component
----------------------------------------------------------------------------------------------------
(Intercept) | 0.54 | 0.22 | [0.25, 1.20] | -1.51 | 0.132 | fixed | conditional
spp [PR] | 0.38 | 0.25 | [0.11, 1.35] | -1.50 | 0.134 | fixed | conditional
spp [DM] | 1.19 | 0.28 | [0.75, 1.88] | 0.73 | 0.468 | fixed | conditional
spp [EC-A] | 0.68 | 0.23 | [0.35, 1.33] | -1.13 | 0.258 | fixed | conditional
spp [EC-L] | 1.63 | 0.39 | [1.02, 2.60] | 2.05 | 0.041 | fixed | conditional
spp [DES-L] | 1.80 | 0.41 | [1.15, 2.82] | 2.59 | 0.010 | fixed | conditional
spp [DF] | 0.89 | 0.22 | [0.55, 1.44] | -0.46 | 0.642 | fixed | conditional
mined [no] | 4.18 | 1.53 | [2.04, 8.57] | 3.90 | < .001 | fixed | conditional
(Intercept) | 2.48 | 1.56 | [0.73, 8.51] | 1.45 | 0.147 | fixed | zero_inflated
sppPR | 3.19 | 4.26 | [0.23, 43.70] | 0.87 | 0.384 | fixed | zero_inflated
sppDM | 0.39 | 0.31 | [0.08, 1.88] | -1.17 | 0.241 | fixed | zero_inflated
sppEC-A | 2.84 | 2.02 | [0.70, 11.49] | 1.46 | 0.144 | fixed | zero_inflated
sppEC-L | 0.57 | 0.41 | [0.14, 2.37] | -0.77 | 0.439 | fixed | zero_inflated
sppDES-L | 0.41 | 0.31 | [0.09, 1.79] | -1.19 | 0.236 | fixed | zero_inflated
sppDF | 0.08 | 0.17 | [0.00, 5.68] | -1.16 | 0.244 | fixed | zero_inflated
minedno | 0.08 | 0.05 | [0.02, 0.25] | -4.24 | < .001 | fixed | zero_inflated
(Intercept) | 1.51 | | [0.93, 2.46] | | | fixed | dispersion
SD (Intercept: site) | 0.38 | | [0.17, 0.87] | | | random | conditional
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
# adding model summaries
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(144) | p
-------------------------------------------------------------------------------------------
(Intercept) | 4.21 | 0.41 | [ 3.41, 5.02] | 10.34 | < .001
Species [versicolor] | -1.81 | 0.60 | [-2.99, -0.62] | -3.02 | 0.003
Species [virginica] | -3.15 | 0.63 | [-4.41, -1.90] | -4.97 | < .001
Petal Length | 0.54 | 0.28 | [ 0.00, 1.09] | 1.96 | 0.052
Species [versicolor] * Petal Length | 0.29 | 0.30 | [-0.30, 0.87] | 0.97 | 0.334
Species [virginica] * Petal Length | 0.45 | 0.29 | [-0.12, 1.03] | 1.56 | 0.120
Model: Sepal.Length ~ Species * Petal.Length (150 Observations)
Sigma: 0.336 (df = 144)
RMSE : 0.330
R2: 0.840; adjusted R2: 0.835
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
# grouped parameters
Code
print(out, groups = list(Engine = c("cyl6", "cyl8", "vs", "hp"), Interactions = c(
"gear4:vs", "gear5:vs"), Controls = c(2, 3, 7)))
Output
Parameter | Coefficient | SE | 95% CI | t(22) | p
-----------------------------------------------------------------------
Engine | | | | |
cyl [6] | -2.47 | 2.21 | [ -7.05, 2.12] | -1.12 | 0.276
cyl [8] | 1.97 | 5.11 | [ -8.63, 12.58] | 0.39 | 0.703
vs | 3.18 | 3.79 | [ -4.68, 11.04] | 0.84 | 0.410
hp | -0.06 | 0.02 | [ -0.11, -0.02] | -2.91 | 0.008
Interactions | | | | |
gear [4] * vs | -2.90 | 4.67 | [-12.57, 6.78] | -0.62 | 0.541
gear [5] * vs | 2.59 | 4.54 | [ -6.82, 12.00] | 0.57 | 0.574
Controls | | | | |
gear [4] | 3.10 | 4.34 | [ -5.90, 12.10] | 0.71 | 0.482
gear [5] | 4.80 | 3.48 | [ -2.42, 12.01] | 1.38 | 0.182
drat | 2.70 | 2.03 | [ -1.52, 6.91] | 1.33 | 0.198
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, sep = " ", groups = list(Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"), Controls = c(2, 3, 7)))
Output
Parameter Coefficient SE 95% CI t(22) p
------------------------------------------------------------------
Engine
cyl [6] -2.47 2.21 [ -7.05, 2.12] -1.12 0.276
cyl [8] 1.97 5.11 [ -8.63, 12.58] 0.39 0.703
vs 3.18 3.79 [ -4.68, 11.04] 0.84 0.410
hp -0.06 0.02 [ -0.11, -0.02] -2.91 0.008
Interactions
gear [4] * vs -2.90 4.67 [-12.57, 6.78] -0.62 0.541
gear [5] * vs 2.59 4.54 [ -6.82, 12.00] 0.57 0.574
Controls
gear [4] 3.10 4.34 [ -5.90, 12.10] 0.71 0.482
gear [5] 4.80 3.48 [ -2.42, 12.01] 1.38 0.182
drat 2.70 2.03 [ -1.52, 6.91] 1.33 0.198
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
# digits and ci_digits
Code
model_parameters(model, digits = 4)
Output
Parameter | Coefficient | SE | 95% CI | t(24) | p
-------------------------------------------------------------------------
(Intercept) | 18.9880 | 7.4728 | [ 3.5648, 34.4112] | 2.5409 | 0.018
hp | -0.0627 | 0.0199 | [-0.1038, -0.0217] | -3.1541 | 0.004
gear [4] | 0.8223 | 2.2921 | [-3.9084, 5.5530] | 0.3587 | 0.723
gear [5] | 5.1839 | 2.6751 | [-0.3373, 10.7051] | 1.9378 | 0.064
vs | 1.9583 | 2.0920 | [-2.3593, 6.2759] | 0.9361 | 0.359
cyl [6] | -2.3057 | 2.1418 | [-6.7262, 2.1148] | -1.0765 | 0.292
cyl [8] | 0.9279 | 4.3980 | [-8.1490, 10.0049] | 0.2110 | 0.835
drat | 2.3430 | 1.9741 | [-1.7313, 6.4172] | 1.1869 | 0.247
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
model_parameters(model, digits = 4, ci_digits = 1)
Output
Parameter | Coefficient | SE | 95% CI | t(24) | p
-------------------------------------------------------------------
(Intercept) | 18.9880 | 7.4728 | [ 3.6, 34.4] | 2.5409 | 0.018
hp | -0.0627 | 0.0199 | [-0.1, 0.0] | -3.1541 | 0.004
gear [4] | 0.8223 | 2.2921 | [-3.9, 5.6] | 0.3587 | 0.723
gear [5] | 5.1839 | 2.6751 | [-0.3, 10.7] | 1.9378 | 0.064
vs | 1.9583 | 2.0920 | [-2.4, 6.3] | 0.9361 | 0.359
cyl [6] | -2.3057 | 2.1418 | [-6.7, 2.1] | -1.0765 | 0.292
cyl [8] | 0.9279 | 4.3980 | [-8.1, 10.0] | 0.2110 | 0.835
drat | 2.3430 | 1.9741 | [-1.7, 6.4] | 1.1869 | 0.247
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, digits = 4)
Output
Parameter | Coefficient | SE | 95% CI | t(24) | p
-------------------------------------------------------------------------
(Intercept) | 18.9880 | 7.4728 | [ 3.5648, 34.4112] | 2.5409 | 0.018
hp | -0.0627 | 0.0199 | [-0.1038, -0.0217] | -3.1541 | 0.004
gear [4] | 0.8223 | 2.2921 | [-3.9084, 5.5530] | 0.3587 | 0.723
gear [5] | 5.1839 | 2.6751 | [-0.3373, 10.7051] | 1.9378 | 0.064
vs | 1.9583 | 2.0920 | [-2.3593, 6.2759] | 0.9361 | 0.359
cyl [6] | -2.3057 | 2.1418 | [-6.7262, 2.1148] | -1.0765 | 0.292
cyl [8] | 0.9279 | 4.3980 | [-8.1490, 10.0049] | 0.2110 | 0.835
drat | 2.3430 | 1.9741 | [-1.7313, 6.4172] | 1.1869 | 0.247
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, digits = 4, ci_digits = 1)
Output
Parameter | Coefficient | SE | 95% CI | t(24) | p
-------------------------------------------------------------------
(Intercept) | 18.9880 | 7.4728 | [ 3.6, 34.4] | 2.5409 | 0.018
hp | -0.0627 | 0.0199 | [-0.1, 0.0] | -3.1541 | 0.004
gear [4] | 0.8223 | 2.2921 | [-3.9, 5.6] | 0.3587 | 0.723
gear [5] | 5.1839 | 2.6751 | [-0.3, 10.7] | 1.9378 | 0.064
vs | 1.9583 | 2.0920 | [-2.4, 6.3] | 0.9361 | 0.359
cyl [6] | -2.3057 | 2.1418 | [-6.7, 2.1] | -1.0765 | 0.292
cyl [8] | 0.9279 | 4.3980 | [-8.1, 10.0] | 0.2110 | 0.835
drat | 2.3430 | 1.9741 | [-1.7, 6.4] | 1.1869 | 0.247
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
# select pattern
Code
print(out, groups = list(Engine = c("cyl6", "cyl8", "vs", "hp"), Interactions = c(
"gear4:vs", "gear5:vs"), Controls = c(2, 3, 7)))
Output
Parameter | Coefficient | SE | 95% CI | t(22) | p
-----------------------------------------------------------------------
Engine | | | | |
cyl [6] | -2.47 | 2.21 | [ -7.05, 2.12] | -1.12 | 0.276
cyl [8] | 1.97 | 5.11 | [ -8.63, 12.58] | 0.39 | 0.703
vs | 3.18 | 3.79 | [ -4.68, 11.04] | 0.84 | 0.410
hp | -0.06 | 0.02 | [ -0.11, -0.02] | -2.91 | 0.008
Interactions | | | | |
gear [4] * vs | -2.90 | 4.67 | [-12.57, 6.78] | -0.62 | 0.541
gear [5] * vs | 2.59 | 4.54 | [ -6.82, 12.00] | 0.57 | 0.574
Controls | | | | |
gear [4] | 3.10 | 4.34 | [ -5.90, 12.10] | 0.71 | 0.482
gear [5] | 4.80 | 3.48 | [ -2.42, 12.01] | 1.38 | 0.182
drat | 2.70 | 2.03 | [ -1.52, 6.91] | 1.33 | 0.198
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, select = "{coef} ({se})")
Output
Parameter | Estimate (SE)
-----------------------------
hp | -0.06 (0.02)
gear [4] | 3.10 (4.34)
gear [5] | 4.80 (3.48)
vs | 3.18 (3.79)
cyl [6] | -2.47 (2.21)
cyl [8] | 1.97 (5.11)
drat | 2.70 (2.03)
gear [4] * vs | -2.90 (4.67)
gear [5] * vs | 2.59 (4.54)
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, select = "{coef}{stars}|[{ci}]")
Output
Parameter | Estimate | [ci]
------------------------------------------
hp | -0.06** | [ -0.11, -0.02]
gear [4] | 3.10 | [ -5.90, 12.10]
gear [5] | 4.80 | [ -2.42, 12.01]
vs | 3.18 | [ -4.68, 11.04]
cyl [6] | -2.47 | [ -7.05, 2.12]
cyl [8] | 1.97 | [ -8.63, 12.58]
drat | 2.70 | [ -1.52, 6.91]
gear [4] * vs | -2.90 | [-12.57, 6.78]
gear [5] * vs | 2.59 | [ -6.82, 12.00]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, groups = list(Engine = c("cyl6", "cyl8", "vs", "hp"), Interactions = c(
"gear4:vs", "gear5:vs"), Controls = c(2, 3, 7)), select = "{coef}{stars}|[{ci}]")
Output
Parameter | Estimate | [ci]
---------------------------------------------
Engine | |
cyl [6] | -2.47 | [ -7.05, 2.12]
cyl [8] | 1.97 | [ -8.63, 12.58]
vs | 3.18 | [ -4.68, 11.04]
hp | -0.06** | [ -0.11, -0.02]
Interactions | |
gear [4] * vs | -2.90 | [-12.57, 6.78]
gear [5] * vs | 2.59 | [ -6.82, 12.00]
Controls | |
gear [4] | 3.10 | [ -5.90, 12.10]
gear [5] | 4.80 | [ -2.42, 12.01]
drat | 2.70 | [ -1.52, 6.91]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
print(out, sep = " ", groups = list(Engine = c("cyl6", "cyl8", "vs", "hp"),
Interactions = c("gear4:vs", "gear5:vs"), Controls = c(2, 3, 7)), select = "{coef}{stars}|[{ci}]")
Output
Parameter Estimate [ci]
-------------------------------------------
Engine
cyl [6] -2.47 [ -7.05, 2.12]
cyl [8] 1.97 [ -8.63, 12.58]
vs 3.18 [ -4.68, 11.04]
hp -0.06** [ -0.11, -0.02]
Interactions
gear [4] * vs -2.90 [-12.57, 6.78]
gear [5] * vs 2.59 [ -6.82, 12.00]
Controls
gear [4] 3.10 [ -5.90, 12.10]
gear [5] 4.80 [ -2.42, 12.01]
drat 2.70 [ -1.52, 6.91]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
# no more message about interpretation of log-resoponse
Code
print(out)
Output
Parameter | Coefficient | SE | 95% CI | t(30) | p
-----------------------------------------------------------------
(Intercept) | 9.29 | 2.24 | [5.67, 15.21] | 9.23 | < .001
gear | 1.22 | 0.08 | [1.07, 1.39] | 3.08 | 0.004
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
# no fail for mgcv-binomial
Code
print(out)
Output
# Fixed Effects
Parameter | Log-Odds | SE | 95% CI | z | df | p
---------------------------------------------------------------------
(Intercept) | -0.20 | 0.50 | [-1.18, 0.79] | -0.39 | 29.98 | 0.695
# Smooth Terms
Parameter | z | df | p
---------------------------------------
Smooth term (mpg) | 7.24 | 1.02 | 0.007
Message
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
parameters/tests/testthat/_snaps/glmer.md 0000644 0001762 0000144 00000004713 14716604200 020337 0 ustar ligges users # print model_parameters
Code
params
Output
# Fixed Effects
Parameter | Log-Odds | SE | 95% CI | z | p
---------------------------------------------------------------
(Intercept) | -1.36 | 0.23 | [-1.81, -0.91] | -5.98 | < .001
period [2] | -0.98 | 0.30 | [-1.57, -0.38] | -3.22 | 0.001
period [3] | -1.11 | 0.32 | [-1.75, -0.48] | -3.43 | < .001
period [4] | -1.56 | 0.42 | [-2.39, -0.73] | -3.67 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
---
Code
mp
Output
# Fixed Effects
Parameter | Odds Ratio | SE | 95% CI | z | p
---------------------------------------------------------------
(Intercept) | 0.26 | 0.06 | [0.16, 0.40] | -5.98 | < .001
period [2] | 0.38 | 0.11 | [0.21, 0.68] | -3.22 | 0.001
period [3] | 0.33 | 0.11 | [0.17, 0.62] | -3.43 | < .001
period [4] | 0.21 | 0.09 | [0.09, 0.48] | -3.67 | < .001
# Random Effects
Parameter | Coefficient
----------------------------------
SD (Intercept: herd) | 0.64
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
---
Code
mp
Output
# Fixed Effects
Parameter | Log-Odds | SE | 95% CI | z | p
---------------------------------------------------------------
(Intercept) | -1.40 | 0.23 | [-1.85, -0.94] | -6.02 | < .001
period [2] | -0.99 | 0.31 | [-1.59, -0.39] | -3.24 | 0.001
period [3] | -1.13 | 0.33 | [-1.77, -0.49] | -3.46 | < .001
period [4] | -1.58 | 0.43 | [-2.42, -0.74] | -3.70 | < .001
# Random Effects
Parameter | Coefficient | SE | 95% CI
--------------------------------------------------------
SD (Intercept: herd) | 0.64 | 0.18 | [0.37, 1.11]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/glmmTMB-profile_CI.md 0000644 0001762 0000144 00000004317 14716604200 022541 0 ustar ligges users # glmmTMB profiled and uniroot CI work
Code
print(mp1)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | z | p
--------------------------------------------------------------------
(Intercept) | 251.40 | 6.63 | [237.68, 265.13] | 37.91 | < .001
Days | 10.47 | 1.50 | [ 7.36, 13.58] | 6.97 | < .001
# Random Effects
Parameter | Coefficient | 95% CI
------------------------------------------------------------
SD (Intercept: Subject) | 23.78 | [15.02, 37.66]
SD (Days: Subject) | 5.72 | [ 3.81, 8.59]
Cor (Intercept~Days: Subject) | 0.08 | [-0.49, 0.59]
SD (Residual) | 25.59 | [22.80, 28.72]
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation. Uncertainty
intervals for random effect variances computed using a Wald
z-distribution approximation.
---
Code
print(mp2)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | z | p
--------------------------------------------------------------------
(Intercept) | 251.40 | 6.63 | [237.68, 265.13] | 37.91 | < .001
Days | 10.47 | 1.50 | [ 7.36, 13.58] | 6.97 | < .001
# Random Effects
Parameter | Coefficient | 95% CI
------------------------------------------------------------
SD (Intercept: Subject) | 23.78 | [15.02, 37.66]
SD (Days: Subject) | 5.72 | [ 3.81, 8.59]
Cor (Intercept~Days: Subject) | 0.08 | [-0.49, 0.59]
SD (Residual) | 25.59 | [22.80, 28.72]
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation. Uncertainty
intervals for random effect variances computed using a Wald
z-distribution approximation.
parameters/tests/testthat/_snaps/p_significance.md 0000644 0001762 0000144 00000001564 14716604201 022174 0 ustar ligges users # p_significance
Code
print(x)
Output
Practical Significance (threshold: -0.60, 0.60)
Parameter | 95% CI | ps
-------------------------------------
(Intercept) | [24.44, 48.94] | 100%
gear | [-1.69, 2.41] | 39.83%
wt | [-4.77, -1.28] | 99.59%
cyl | [-2.17, 0.55] | 61.88%
hp | [-0.05, 0.01] | 0.00%
# p_significance, robust
Code
print(x)
Output
Practical Significance (threshold: -0.60, 0.60)
Parameter | 95% CI | ps
-------------------------------------
(Intercept) | [20.32, 53.06] | 100%
gear | [-2.04, 2.77] | 41.23%
wt | [-4.91, -1.13] | 99.39%
cyl | [-2.53, 0.91] | 59.51%
hp | [-0.06, 0.01] | 0.00%
parameters/tests/testthat/_snaps/pool_parameters.md 0000644 0001762 0000144 00000001517 14716604201 022425 0 ustar ligges users # pooled parameters
Code
print(pp)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | Statistic | df | p
------------------------------------------------------------------------------
(Intercept) | 18.21 | 4.37 | [ 8.37, 28.06] | 4.17 | 9.22 | 0.002
age [40-59] | -4.65 | 2.41 | [-10.18, 0.88] | -1.93 | 8.19 | 0.089
age [60-99] | -6.71 | 3.84 | [-17.75, 4.34] | -1.75 | 3.67 | 0.162
hyp [yes] | 1.52 | 2.26 | [ -3.49, 6.54] | 0.67 | 10.26 | 0.515
chl | 0.06 | 0.03 | [ -0.01, 0.12] | 2.11 | 6.44 | 0.077
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald distribution approximation.
parameters/tests/testthat/_snaps/visualisation_recipe.md 0000644 0001762 0000144 00000001162 14716604201 023446 0 ustar ligges users # vis_recipe.cluster_analysis
Code
print(out)
Output
Layer 1
--------
Geom type: text
data = [150 x 4]
aes_string(
x = 'x'
y = 'y'
label = 'label'
color = 'Cluster'
)
Layer 2
--------
Geom type: point
data = [4 x 3]
aes_string(
x = 'x'
y = 'y'
color = 'Cluster'
)
shape = '+'
size = 10
Layer 3
--------
Geom type: labs
x = 'PCA - 1'
y = 'PCA - 2'
title = 'Clustering Solution'
parameters/tests/testthat/_snaps/windows/ 0000755 0001762 0000144 00000000000 14736731407 020410 5 ustar ligges users parameters/tests/testthat/_snaps/windows/model_parameters.logistf.md 0000644 0001762 0000144 00000005260 14716604201 025713 0 ustar ligges users # model_parameters.logistf
Code
params
Output
# Fixed Effects
Parameter | Log-Odds | SE | 95% CI | Chi2(1) | p
-----------------------------------------------------------------
(Intercept) | 0.12 | 0.48 | [-0.82, 1.07] | 0.06 | 0.802
age | -1.11 | 0.41 | [-1.97, -0.31] | 7.51 | 0.006
oc | -0.07 | 0.43 | [-0.94, 0.79] | 0.02 | 0.875
vic | 2.27 | 0.54 | [ 1.27, 3.44] | 22.93 | < .001
vicl | -2.11 | 0.53 | [-3.26, -1.12] | 19.10 | < .001
vis | -0.79 | 0.41 | [-1.61, 0.02] | 3.70 | 0.054
dia | 3.10 | 1.51 | [ 0.77, 8.03] | 7.90 | 0.005
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
# model_parameters.flic
Code
params
Output
# Fixed Effects
Parameter | Log-Odds | SE | 95% CI | Chi2(1) | p
-----------------------------------------------------------------
(Intercept) | 0.13 | 0.28 | [-0.82, 1.08] | 0.85 | 0.358
age | -1.11 | 0.29 | [-1.97, -0.31] | 7.51 | 0.006
oc | -0.07 | 0.24 | [-0.94, 0.79] | 0.02 | 0.875
vic | 2.27 | 0.24 | [ 1.27, 3.44] | 22.93 | < .001
vicl | -2.11 | 0.25 | [-3.26, -1.12] | 19.10 | < .001
vis | -0.79 | 0.26 | [-1.61, 0.02] | 3.70 | 0.054
dia | 3.10 | 0.41 | [ 0.77, 8.03] | 7.90 | 0.005
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
# model_parameters.flac
Code
params
Output
# Fixed Effects
Parameter | Log-Odds | SE | 95% CI | Chi2(1) | p
-----------------------------------------------------------------
(Intercept) | 0.12 | 0.48 | [-0.81, 1.07] | 0.07 | 0.797
age | -1.10 | 0.42 | [-1.95, -0.31] | 7.55 | 0.006
oc | -0.07 | 0.43 | [-0.93, 0.79] | 0.02 | 0.879
vic | 2.28 | 0.54 | [ 1.29, 3.43] | 23.37 | < .001
vicl | -2.11 | 0.53 | [-3.24, -1.13] | 19.45 | < .001
vis | -0.79 | 0.41 | [-1.60, 0.01] | 3.74 | 0.053
dia | 3.18 | 1.53 | [ 0.87, 7.99] | 8.54 | 0.003
Message
Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
computed using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/windows/model_parameters.logitr.md 0000644 0001762 0000144 00000002327 14736731407 025560 0 ustar ligges users # model_parameters.logitr
Code
params
Output
Parameter | Log-Odds | SE | 95% CI | z | p
---------------------------------------------------------------------
scalePar | 0.37 | 0.02 | [ 0.32, 0.41] | 15.04 | < .001
feat | 1.34 | 0.36 | [ 0.64, 2.04] | 3.77 | < .001
brand [hiland] | -10.14 | 0.58 | [-11.26, -9.01] | -17.59 | < .001
brand [weight] | -1.75 | 0.18 | [ -2.10, -1.40] | -9.72 | < .001
brand [yoplait] | 2.00 | 0.14 | [ 1.72, 2.28] | 14.07 | < .001
---
Code
params
Output
Parameter | Log-Odds | SE | 95% CI | z | df | p
----------------------------------------------------------------------------
scalePar | 0.37 | 0.02 | [ 0.32, 0.41] | 15.04 | 2407 | < .001
feat | 1.34 | 0.36 | [ 0.64, 2.04] | 3.77 | 2407 | < .001
brand [hiland] | -10.14 | 0.58 | [-11.27, -9.01] | -17.59 | 2407 | < .001
brand [weight] | -1.75 | 0.18 | [ -2.10, -1.40] | -9.72 | 2407 | < .001
brand [yoplait] | 2.00 | 0.14 | [ 1.72, 2.28] | 14.07 | 2407 | < .001
parameters/tests/testthat/_snaps/compare_parameters.md 0000644 0001762 0000144 00000025333 14716604200 023103 0 ustar ligges users # compare_parameters, proper printing for CI=NULL #820
Code
compare_parameters(m1, m2, ci = NULL)
Output
Parameter | m1 | m2
----------------------------
(Intercept) | 30.10 | 30.10
hp | -0.07 | -0.07
----------------------------
Observations | 32 | 32
# compare_parameters, correct random effects
Code
cp
Output
# Fixed Effects
Parameter | m0 | m1 | m2
--------------------------------------------------------------------------------
(Intercept) | 0.91 ( 0.75, 1.07) | 0.68 (-0.54, 1.91) | 1.41 ( 1.06, 1.75)
child | -1.23 (-1.39, -1.08) | -1.67 (-1.84, -1.51) | -0.53 (-0.77, -0.29)
camper [1] | 1.05 ( 0.88, 1.23) | 0.94 ( 0.77, 1.12) | 0.58 ( 0.39, 0.78)
zg | | | 0.13 ( 0.05, 0.21)
# Fixed Effects (Zero-Inflation Component)
Parameter | m0 | m1 | m2
--------------------------------------------
(Intercept) | | | -0.92 (-2.07, 0.22)
child | | | 1.96 ( 1.38, 2.54)
# Random Effects
Parameter | m0 | m1 | m2
--------------------------------------------------------------------------
SD (Intercept: ID) | | 0.27 ( 0.11, 0.63) | 0.28 ( 0.13, 0.60)
SD (Intercept: persons) | | 1.21 ( 0.60, 2.43) |
# Random Effects (Zero-Inflation Component)
Parameter | m0 | m1 | m2
--------------------------------------------------------
SD (Intercept: persons) | | | 1.08 ( 0.49, 2.37)
# compare_parameters, print_md
Code
print(out)
Output
+----------------+-----------------------+--------+----------------------+--------+
| | lm1 | lm2 |
+----------------+-----------------------+--------+----------------------+--------+
| Parameter | Estimate (ci) | p | Estimate (ci) | p |
+================+=======================+========+======================+========+
| *Groups* |
+----------------+-----------------------+--------+----------------------+--------+
| grp (2) | -4.31 (-15.95, 7.32) | 0.465 | 0.32 (-22.56, 23.20) | 0.978 |
+----------------+-----------------------+--------+----------------------+--------+
| grp (3) | -1.31 (-13.47, 10.84) | 0.831 | 3.77 (-19.72, 27.26) | 0.752 |
+----------------+-----------------------+--------+----------------------+--------+
| *Interactions* |
+----------------+-----------------------+--------+----------------------+--------+
| Days * grp (2) | | | -1.01 (-5.35, 3.32) | 0.645 |
+----------------+-----------------------+--------+----------------------+--------+
| Days * grp (3) | | | -1.11 (-5.53, 3.31) | 0.621 |
+----------------+-----------------------+--------+----------------------+--------+
| *Controls* |
+----------------+-----------------------+--------+----------------------+--------+
| Days | 10.44 (8.84, 12.03) | <0.001 | 11.23 (7.87, 14.60) | <0.001 |
+----------------+-----------------------+--------+----------------------+--------+
| | | | | |
+----------------+-----------------------+--------+----------------------+--------+
| Observations | 180 | | 180 | |
+----------------+-----------------------+--------+----------------------+--------+
---
Code
print_md(cp)
Output
+-------------------------+-----------------------+--------+----------------------+--------+
| | lm1 | lm2 |
+-------------------------+-----------------------+--------+----------------------+--------+
| Parameter | Estimate (ci) | p | Estimate (ci) | p |
+=========================+=======================+========+======================+========+
| Fixed Effects |
+-------------------------+-----------------------+--------+----------------------+--------+
| Days | 10.44 (8.84, 12.03) | <0.001 | 11.23 (7.87, 14.60) | <0.001 |
+-------------------------+-----------------------+--------+----------------------+--------+
| grp [2] | -4.31 (-15.95, 7.32) | 0.465 | 0.32 (-22.56, 23.20) | 0.978 |
+-------------------------+-----------------------+--------+----------------------+--------+
| grp [3] | -1.31 (-13.47, 10.84) | 0.831 | 3.77 (-19.72, 27.26) | 0.752 |
+-------------------------+-----------------------+--------+----------------------+--------+
| Days * grp [2] | | | -1.01 (-5.35, 3.32) | 0.645 |
+-------------------------+-----------------------+--------+----------------------+--------+
| Days * grp [3] | | | -1.11 (-5.53, 3.31) | 0.621 |
+-------------------------+-----------------------+--------+----------------------+--------+
| Random Effects |
+-------------------------+-----------------------+--------+----------------------+--------+
| SD (Intercept: Subject) | 37.06 (25.85, 53.13) | | 37.08 (25.85, 53.19) | |
+-------------------------+-----------------------+--------+----------------------+--------+
| SD (Residual) | 31.13 (27.89, 34.75) | | 31.30 (28.02, 34.96) | |
+-------------------------+-----------------------+--------+----------------------+--------+
---
Code
print(out)
Output
+----------------+-----------------------+--------+----------------------+--------+
| | lm1 | lm2 |
+----------------+-----------------------+--------+----------------------+--------+
| Parameter | Estimate (ci) | p | Estimate (ci) | p |
+================+=======================+========+======================+========+
| *Groups* |
+----------------+-----------------------+--------+----------------------+--------+
| grp (1) | 0.00 | | 0.00 | |
+----------------+-----------------------+--------+----------------------+--------+
| grp (2) | -4.31 (-15.95, 7.32) | 0.465 | 0.32 (-22.56, 23.20) | 0.978 |
+----------------+-----------------------+--------+----------------------+--------+
| grp (3) | -1.31 (-13.47, 10.84) | 0.831 | 3.77 (-19.72, 27.26) | 0.752 |
+----------------+-----------------------+--------+----------------------+--------+
| *Interactions* |
+----------------+-----------------------+--------+----------------------+--------+
| Days * grp (2) | | | -1.01 (-5.35, 3.32) | 0.645 |
+----------------+-----------------------+--------+----------------------+--------+
| Days * grp (3) | | | -1.11 (-5.53, 3.31) | 0.621 |
+----------------+-----------------------+--------+----------------------+--------+
| *Controls* |
+----------------+-----------------------+--------+----------------------+--------+
| Days | 10.44 (8.84, 12.03) | <0.001 | 11.23 (7.87, 14.60) | <0.001 |
+----------------+-----------------------+--------+----------------------+--------+
| | | | | |
+----------------+-----------------------+--------+----------------------+--------+
| Observations | 180 | | 180 | |
+----------------+-----------------------+--------+----------------------+--------+
---
Code
print(out)
Output
+----------------+-----------------------+----------------------+
| Parameter | lm1 | lm2 |
+================+=======================+======================+
| *Groups* |
+----------------+-----------------------+----------------------+
| grp (1) | 0.00 | 0.00 |
+----------------+-----------------------+----------------------+
| grp (2) | -4.31 (-15.95, 7.32) | 0.32 (-22.56, 23.20) |
+----------------+-----------------------+----------------------+
| grp (3) | -1.31 (-13.47, 10.84) | 3.77 (-19.72, 27.26) |
+----------------+-----------------------+----------------------+
| *Interactions* |
+----------------+-----------------------+----------------------+
| Days * grp (2) | | -1.01 (-5.35, 3.32) |
+----------------+-----------------------+----------------------+
| Days * grp (3) | | -1.11 (-5.53, 3.31) |
+----------------+-----------------------+----------------------+
| *Controls* |
+----------------+-----------------------+----------------------+
| Days | 10.44 (8.84, 12.03) | 11.23 (7.87, 14.60) |
+----------------+-----------------------+----------------------+
| | | |
+----------------+-----------------------+----------------------+
| Observations | 180 | 180 |
+----------------+-----------------------+----------------------+
parameters/tests/testthat/_snaps/model_parameters.mixed.md 0000644 0001762 0000144 00000005331 14716604201 023657 0 ustar ligges users # print-model_parameters
Code
model_parameters(model, effects = "fixed")
Output
Parameter | Coefficient | SE | 95% CI | t(558) | p
-------------------------------------------------------------------
(Intercept) | 71.53 | 1.56 | [68.48, 74.59] | 45.98 | < .001
time | 1.09 | 0.64 | [-0.17, 2.34] | 1.70 | 0.089
# Within-Effects
Parameter | Coefficient | SE | 95% CI | t(558) | p
-------------------------------------------------------------------
phq4 within | -3.66 | 0.41 | [-4.46, -2.86] | -8.95 | < .001
# Between-Effects
Parameter | Coefficient | SE | 95% CI | t(558) | p
--------------------------------------------------------------------
phq4 between | -6.28 | 0.50 | [-7.27, -5.30] | -12.53 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
---
Code
model_parameters(m1, effects = "all")
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | t(28) | p
-----------------------------------------------------------------
(Intercept) | 0.65 | 0.50 | [-0.38, 1.68] | 1.29 | 0.206
cyl | 0.40 | 0.08 | [ 0.25, 0.56] | 5.29 | < .001
# Random Effects
Parameter | Coefficient | SE | 95% CI
--------------------------------------------------------
SD (Intercept: gear) | 0.27 | 0.24 | [0.05, 1.54]
SD (Residual) | 0.59 | 0.08 | [0.46, 0.77]
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation. Uncertainty intervals for
random effect variances computed using a Wald z-distribution
approximation.
---
Code
model_parameters(m1, effects = "fixed", include_info = TRUE)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | t(28) | p
-----------------------------------------------------------------
(Intercept) | 0.65 | 0.50 | [-0.38, 1.68] | 1.29 | 0.206
cyl | 0.40 | 0.08 | [ 0.25, 0.56] | 5.29 | < .001
Model: wt ~ cyl (32 Observations)
Sigma: 0.594 (df = 28)
RMSE : 0.564
Conditional R2: 0.628; Marginal R2: 0.550
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
parameters/tests/testthat/_snaps/model_parameters.ggeffects.md 0000644 0001762 0000144 00000002127 14716604200 024505 0 ustar ligges users # model_parameters.ggeffects
Code
print(params)
Output
# Species = setosa
Petal.Length | Predicted | 95% CI
----------------------------------------
1.00 | 4.79 | [4.36, 5.21]
2.50 | 5.59 | [4.97, 6.21]
4.00 | 6.40 | [4.99, 7.80]
7.00 | 8.00 | [4.96, 11.05]
# Species = versicolor
Petal.Length | Predicted | 95% CI
---------------------------------------
1.00 | 3.26 | [2.53, 4.00]
2.50 | 4.49 | [4.10, 4.89]
4.00 | 5.72 | [5.61, 5.83]
7.00 | 8.17 | [7.52, 8.83]
# Species = virginica
Petal.Length | Predicted | 95% CI
---------------------------------------
1.00 | 2.05 | [1.26, 2.85]
2.50 | 3.54 | [2.99, 4.08]
4.00 | 5.03 | [4.69, 5.36]
7.00 | 8.00 | [7.57, 8.42]
Adjusted for:
* Petal.Width = 1.20
parameters/tests/testthat/_snaps/p_direction.md 0000644 0001762 0000144 00000000646 14716604201 021532 0 ustar ligges users # p_direction
Code
print(x)
Output
Probability of Direction (null: 0)
Parameter | 95% CI | pd
-------------------------------------
(Intercept) | [24.44, 48.94] | 100%
gear | [-1.69, 2.41] | 63.59%
wt | [-4.77, -1.28] | 99.92%
cyl | [-2.17, 0.55] | 88.20%
hp | [-0.05, 0.01] | 91.17%
parameters/tests/testthat/_snaps/svylme.md 0000644 0001762 0000144 00000001704 14716604201 020546 0 ustar ligges users # model_parameters svylme
Code
print(mp)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | t | p
--------------------------------------------------------------------
(Intercept) | -60.98 | 34.48 | [-128.57, 6.61] | -1.77 | 0.077
ell | 0.92 | 0.26 | [ 0.41, 1.42] | 3.56 | < .001
mobility | -0.38 | 0.24 | [ -0.85, 0.08] | -1.60 | 0.109
api99 | 1.10 | 0.03 | [ 1.03, 1.17] | 31.44 | < .001
# Random Effects
Parameter | Coefficient
-----------------------------------
SD (Intercept: dnum1) | 1.19
SD (api99: dnum2) | 1.39e-03
SD (Residual) | 20.00
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
parameters/tests/testthat/_snaps/plm.md 0000644 0001762 0000144 00000002542 14716604201 020020 0 ustar ligges users # vcov standard errors
Code
print(model_parameters(ran))
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | z | df | p
-----------------------------------------------------------------------------
(Intercept) | 817.10 | 188.26 | [445.84, 1188.36] | 4.34 | 197 | < .001
capital | -0.58 | 0.15 | [ -0.88, -0.29] | -3.95 | 197 | < .001
inv | 2.92 | 0.30 | [ 2.33, 3.51] | 9.80 | 197 | < .001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
---
Code
print(model_parameters(ran, vcov = "HC1"))
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | z | df | p
----------------------------------------------------------------------------
(Intercept) | 817.10 | 274.75 | [275.28, 1358.92] | 2.97 | 197 | 0.003
capital | -0.58 | 0.43 | [ -1.43, 0.26] | -1.37 | 197 | 0.173
inv | 2.92 | 0.89 | [ 1.16, 4.67] | 3.28 | 197 | 0.001
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/bootstrap_parameters.md 0000644 0001762 0000144 00000000717 14716604200 023471 0 ustar ligges users # bootstrap_parameters.bootstrap_model
Code
print(out)
Output
# Fixed Effects
Parameter | Coefficient | 95% CI | p
--------------------------------------------------
(Intercept) | 2.25 | [1.79, 2.69] | < .001
Sepal.Width | 0.60 | [0.47, 0.72] | < .001
Petal.Length | 0.47 | [0.44, 0.50] | < .001
lin_comb | 0.13 | [0.00, 0.24] | 0.036
parameters/tests/testthat/_snaps/serp.md 0000644 0001762 0000144 00000003142 14716604201 020176 0 ustar ligges users # model_parameters.serp
Code
suppressMessages(print(mp))
Output
Parameter | Log-Odds | SE | 95% CI | z | p
------------------------------------------------------------------------------
(Intercept):1 | 1.40 | 0.54 | [ 0.33, 2.46] | 2.57 | 0.010
(Intercept):2 | -1.13 | 0.51 | [-2.13, -0.12] | -2.19 | 0.028
(Intercept):3 | -3.44 | 0.71 | [-4.84, -2.04] | -4.82 | < .001
(Intercept):4 | -4.98 | 0.95 | [-6.85, -3.11] | -5.23 | < .001
tempwarm:1 | 2.38 | 0.81 | [ 0.79, 3.97] | 2.93 | 0.003
tempwarm:2 | 2.26 | 0.71 | [ 0.87, 3.66] | 3.18 | 0.001
tempwarm:3 | 2.41 | 0.77 | [ 0.89, 3.92] | 3.11 | 0.002
tempwarm:4 | 2.51 | 0.88 | [ 0.79, 4.23] | 2.85 | 0.004
contactyes:1 | 1.38 | 0.74 | [-0.08, 2.84] | 1.85 | 0.064
contactyes:2 | 1.35 | 0.67 | [ 0.03, 2.66] | 2.01 | 0.044
contactyes:3 | 1.35 | 0.76 | [-0.13, 2.83] | 1.78 | 0.075
contactyes:4 | 1.22 | 0.86 | [-0.46, 2.89] | 1.42 | 0.156
temp [warm] * contactyes:1 | 0.37 | 1.12 | [-1.82, 2.56] | 0.33 | 0.741
temp [warm] * contactyes:2 | 0.35 | 1.03 | [-1.66, 2.37] | 0.34 | 0.730
temp [warm] * contactyes:3 | 0.36 | 0.97 | [-1.55, 2.26] | 0.37 | 0.713
temp [warm] * contactyes:4 | 0.32 | 1.02 | [-1.68, 2.33] | 0.32 | 0.751
parameters/tests/testthat/_snaps/printing2.md 0000644 0001762 0000144 00000032605 14716604201 021147 0 ustar ligges users # multiple model
Code
print(out)
Output
Parameter | lm1 | lm2 | lm3
-----------------------------------------------------------------------------------------------------
(Intercept) | 5.01 (4.86, 5.15) | 3.68 ( 3.47, 3.89) | 4.21 ( 3.41, 5.02)
Species [versicolor] | 0.93 (0.73, 1.13) | -1.60 (-1.98, -1.22) | -1.81 (-2.99, -0.62)
Species [virginica] | 1.58 (1.38, 1.79) | -2.12 (-2.66, -1.58) | -3.15 (-4.41, -1.90)
Petal Length | | 0.90 ( 0.78, 1.03) | 0.54 ( 0.00, 1.09)
Species [versicolor] * Petal Length | | | 0.29 (-0.30, 0.87)
Species [virginica] * Petal Length | | | 0.45 (-0.12, 1.03)
-----------------------------------------------------------------------------------------------------
Observations | 150 | 150 | 150
# templates
Code
print(out)
Output
Parameter | lm1 | lm2 | lm3
----------------------------------------------------------------------------------------
(Intercept) | 5.01*** (0.07) | 3.68*** (0.11) | 4.21*** (0.41)
Species [versicolor] | 0.93*** (0.10) | -1.60*** (0.19) | -1.81 ** (0.60)
Species [virginica] | 1.58*** (0.10) | -2.12*** (0.27) | -3.15*** (0.63)
Petal Length | | 0.90*** (0.06) | 0.54 (0.28)
Species [versicolor] * Petal Length | | | 0.29 (0.30)
Species [virginica] * Petal Length | | | 0.45 (0.29)
----------------------------------------------------------------------------------------
Observations | 150 | 150 | 150
# templates, glue-1
Code
print(out)
Output
Parameter | lm1 | lm2 | lm3
----------------------------------------------------------------------------------------
(Intercept) | 5.01*** (0.07) | 3.68*** (0.11) | 4.21*** (0.41)
Species [versicolor] | 0.93*** (0.10) | -1.60*** (0.19) | -1.81 ** (0.60)
Species [virginica] | 1.58*** (0.10) | -2.12*** (0.27) | -3.15*** (0.63)
Petal Length | | 0.90*** (0.06) | 0.54 (0.28)
Species [versicolor] * Petal Length | | | 0.29 (0.30)
Species [virginica] * Petal Length | | | 0.45 (0.29)
----------------------------------------------------------------------------------------
Observations | 150 | 150 | 150
# templates, glue-2
Code
print(out)
Output
Parameter | lm1 | lm2 | lm3
-----------------------------------------------------------------------------------------------------------------------------------------
(Intercept) | 5.01 (4.86, 5.15), p<0.001*** | 3.68 ( 3.47, 3.89), p<0.001*** | 4.21 ( 3.41, 5.02), p<0.001***
Species [versicolor] | 0.93 (0.73, 1.13), p<0.001*** | -1.60 (-1.98, -1.22), p<0.001*** | -1.81 (-2.99, -0.62), p=0.003 **
Species [virginica] | 1.58 (1.38, 1.79), p<0.001*** | -2.12 (-2.66, -1.58), p<0.001*** | -3.15 (-4.41, -1.90), p<0.001***
Petal Length | | 0.90 ( 0.78, 1.03), p<0.001*** | 0.54 ( 0.00, 1.09), p=0.052
Species [versicolor] * Petal Length | | | 0.29 (-0.30, 0.87), p=0.334
Species [virginica] * Petal Length | | | 0.45 (-0.12, 1.03), p=0.120
-----------------------------------------------------------------------------------------------------------------------------------------
Observations | 150 | 150 | 150
# templates, glue-3, separate columnns
Code
print(out)
Output
Parameter | Estimate (SE) (lm1) | p (lm1) | Estimate (SE) (lm2) | p (lm2) | Estimate (SE) (lm3) | p (lm3)
-----------------------------------------------------------------------------------------------------------------------------------
(Intercept) | 5.01 (0.07) | <0.001 | 3.68 (0.11) | <0.001 | 4.21 (0.41) | <0.001
Species [versicolor] | 0.93 (0.10) | <0.001 | -1.60 (0.19) | <0.001 | -1.81 (0.60) | 0.003
Species [virginica] | 1.58 (0.10) | <0.001 | -2.12 (0.27) | <0.001 | -3.15 (0.63) | <0.001
Petal Length | | | 0.90 (0.06) | <0.001 | 0.54 (0.28) | 0.052
Species [versicolor] * Petal Length | | | | | 0.29 (0.30) | 0.334
Species [virginica] * Petal Length | | | | | 0.45 (0.29) | 0.120
-----------------------------------------------------------------------------------------------------------------------------------
Observations | 150 | | 150 | | 150 |
---
Code
print(out, groups = list(Species = c("Species [versicolor]",
"Species [virginica]"), Interactions = c(
"Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"),
Controls = "Petal Length"))
Output
Parameter | lm1 | lm2
-----------------------------------------------------------------------------------
Species | |
Species [versicolor] | -1.60 (-1.98, -1.22) | -1.69 (-2.80, -0.57)
Species [virginica] | -2.12 (-2.66, -1.58) | -1.19 (-2.37, -0.01)
Interactions | |
Species [versicolor] * Petal Length | | -0.01 (-0.56, 0.53)
Species [virginica] * Petal Length | | -0.15 (-0.69, 0.39)
Controls | |
Petal Length | 0.90 ( 0.78, 1.03) | 0.39 (-0.13, 0.90)
-----------------------------------------------------------------------------------
Observations | 150 | 150
---
Code
print(out, groups = list(Species = c("Species [versicolor]",
"Species [virginica]"), Interactions = c(
"Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"),
Controls = "Petal Length"), select = "{estimate}{stars}")
Output
Parameter | lm1 | lm2
----------------------------------------------------------
Species | |
Species [versicolor] | -1.60*** | -1.69**
Species [virginica] | -2.12*** | -1.19 *
Interactions | |
Species [versicolor] * Petal Length | | -0.01
Species [virginica] * Petal Length | | -0.15
Controls | |
Petal Length | 0.90*** | 0.39
----------------------------------------------------------
Observations | 150 | 150
---
Code
print(out, groups = list(Species = c("Species [versicolor]",
"Species [virginica]"), Interactions = c(
"Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"),
Controls = "Petal Length"), select = "{estimate}|{p}")
Output
Parameter | Estimate (lm1) | p (lm1) | Estimate (lm2) | p (lm2)
-------------------------------------------------------------------------------------------
Species | | | |
Species [versicolor] | -1.60 | <0.001 | -1.69 | 0.003
Species [virginica] | -2.12 | <0.001 | -1.19 | 0.048
Interactions | | | |
Species [versicolor] * Petal Length | | | -0.01 | 0.961
Species [virginica] * Petal Length | | | -0.15 | 0.574
Controls | | | |
Petal Length | 0.90 | <0.001 | 0.39 | 0.138
-------------------------------------------------------------------------------------------
Observations | 150 | | 150 |
---
Code
print(out, groups = list(Species = c("Species [versicolor]",
"Species [virginica]"), Interactions = c(
"Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"),
Controls = "Petal Length"), select = "{estimate}|{p}")
Output
Parameter | Estimate (lm1) | p (lm1)
----------------------------------------------------------------
Species | |
Species [versicolor] | -1.60 | <0.001
Species [virginica] | -2.12 | <0.001
Interactions | |
Species [versicolor] * Petal Length | |
Species [virginica] * Petal Length | |
Controls | |
Petal Length | 0.90 | <0.001
----------------------------------------------------------------
Observations | 150 |
Parameter | Estimate (lm2) | p (lm2)
----------------------------------------------------------------
Species | |
Species [versicolor] | -1.69 | 0.003
Species [virginica] | -1.19 | 0.048
Interactions | |
Species [versicolor] * Petal Length | -0.01 | 0.961
Species [virginica] * Petal Length | -0.15 | 0.574
Controls | |
Petal Length | 0.39 | 0.138
----------------------------------------------------------------
Observations | 150 |
# combination of different models
Code
print(cp)
Output
# Fixed Effects
Parameter | m0 | m1 | m2
--------------------------------------------------------------------------------
(Intercept) | 0.91 ( 0.75, 1.07) | 0.68 (-0.54, 1.91) | 1.41 ( 1.06, 1.75)
child | -1.23 (-1.39, -1.08) | -1.67 (-1.84, -1.51) | -0.53 (-0.77, -0.29)
camper [1] | 1.05 ( 0.88, 1.23) | 0.94 ( 0.77, 1.12) | 0.58 ( 0.39, 0.78)
zg | | | 0.13 ( 0.05, 0.21)
# Fixed Effects (Zero-Inflation Component)
Parameter | m0 | m1 | m2
--------------------------------------------
(Intercept) | | | -0.92 (-2.07, 0.22)
child | | | 1.96 ( 1.38, 2.54)
# Random Effects
Parameter | m0 | m1 | m2
--------------------------------------------------------------------------
SD (Intercept: ID) | | 0.27 ( 0.11, 0.63) | 0.28 ( 0.13, 0.60)
SD (Intercept: persons) | | 1.21 ( 0.60, 2.43) |
# Random Effects (Zero-Inflation Component)
Parameter | m0 | m1 | m2
--------------------------------------------------------
SD (Intercept: persons) | | | 1.08 ( 0.49, 2.37)
parameters/tests/testthat/_snaps/print_AER_labels.md 0000644 0001762 0000144 00000001731 14716604201 022374 0 ustar ligges users # templates
Code
print(mp, pretty_names = "labels")
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | z | p
-----------------------------------------------------------------------------------------------
(Intercept) | 8.72 | 3.45 | [ 1.95, 15.48] | 2.52 | 0.012
elder's dependency [slightly dependent] | -1.00 | 3.61 | [-8.08, 6.08] | -0.28 | 0.782
elder's dependency [moderately dependent] | 2.68 | 3.06 | [-3.32, 8.68] | 0.88 | 0.381
elder's dependency [severely dependent] | 3.88 | 3.00 | [-2.01, 9.77] | 1.29 | 0.197
carer's level of education | 1.14 | 0.90 | [-0.62, 2.90] | 1.27 | 0.204
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald z-distribution approximation.
parameters/tests/testthat/_snaps/standardize_parameters.md 0000644 0001762 0000144 00000000620 14716604201 023756 0 ustar ligges users # Preserve labels
Code
print(out)
Output
# Standardization method: refit
Parameter | Std. Coef. | 95% CI
--------------------------------------------------
(Intercept) | -1.01 | [-1.18, -0.84]
Species [versicolor] | 1.12 | [ 0.88, 1.37]
Species [virginica] | 1.91 | [ 1.66, 2.16]
parameters/tests/testthat/_snaps/equivalence_test.md 0000644 0001762 0000144 00000002356 14716604200 022572 0 ustar ligges users # equivalence_test
Code
print(x)
Output
# TOST-test for Practical Equivalence
ROPE: [-0.60 0.60]
Parameter | 90% CI | SGPV | Equivalence | p
------------------------------------------------------------
(Intercept) | [26.52, 46.86] | < .001 | Rejected | > .999
gear | [-1.34, 2.07] | 0.475 | Undecided | 0.578
wt | [-4.47, -1.57] | < .001 | Rejected | 0.996
cyl | [-1.94, 0.32] | 0.351 | Undecided | 0.644
hp | [-0.05, 0.01] | > .999 | Accepted | < .001
# equivalence_test, robust
Code
print(x)
Output
# TOST-test for Practical Equivalence
ROPE: [-0.60 0.60]
Parameter | 90% CI | SGPV | Equivalence | p
------------------------------------------------------------
(Intercept) | [23.10, 50.28] | < .001 | Rejected | > .999
gear | [-1.63, 2.36] | 0.421 | Undecided | 0.628
wt | [-4.59, -1.45] | 0.001 | Rejected | 0.993
cyl | [-2.24, 0.62] | 0.361 | Undecided | 0.649
hp | [-0.05, 0.01] | > .999 | Accepted | < .001
parameters/tests/testthat/_snaps/model_parameters.fixest.md 0000644 0001762 0000144 00000003305 14736731407 024065 0 ustar ligges users # model_parameters.fixest
Code
model_parameters(m1, include_info = TRUE, verbose = FALSE)
Output
# Fixed Effects
Parameter | Coefficient | SE | 95% CI | t(187) | p
-----------------------------------------------------------------
time | 1.09 | 0.67 | [-0.23, 2.41] | 1.63 | 0.106
phq4 | -3.66 | 0.67 | [-4.98, -2.34] | -5.45 | < .001
Model: QoL ~ time + phq4 (564 Observations)
Sigma: 12.365 (df = 561)
RMSE : 10.069
r2: 0.743; ar2: 0.613; wr2: 0.180; war2: 0.175
# model_parameters works for fixest-negbin
Code
print(out)
Output
# Fixed Effects
Parameter | Log-Mean | SE | 95% CI | t(636) | p
----------------------------------------------------------------
(Intercept) | -1.46 | 0.21 | [-1.86, -1.06] | -7.11 | < .001
mined [no] | 2.04 | 0.15 | [ 1.75, 2.33] | 13.72 | < .001
spp [PR] | -1.23 | 0.29 | [-1.80, -0.65] | -4.20 | < .001
spp [DM] | 0.40 | 0.23 | [-0.05, 0.86] | 1.75 | 0.080
spp [EC-A] | -0.67 | 0.26 | [-1.18, -0.16] | -2.60 | 0.010
spp [EC-L] | 0.64 | 0.22 | [ 0.20, 1.07] | 2.89 | 0.004
spp [DES-L] | 0.82 | 0.22 | [ 0.38, 1.26] | 3.69 | < .001
spp [DF] | 0.36 | 0.24 | [-0.10, 0.82] | 1.52 | 0.128
Message
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
using a Wald t-distribution approximation.
The model has a log- or logit-link. Consider using `exponentiate =
TRUE` to interpret coefficients as ratios.
parameters/tests/testthat/test-cluster_analysis.R 0000644 0001762 0000144 00000001220 14410544614 022101 0 ustar ligges users test_that("cluster_analysis, predict, matrix", {
data(iris)
iris.dat <- iris[c(1:15, 51:65, 101:115), -5]
set.seed(123)
iris.dat.km <- cluster_analysis(iris.dat, n = 4, method = "kmeans")
x1 <- predict(iris.dat.km)
set.seed(123)
iris.mat <- as.matrix(iris.dat)
iris.mat.km <- cluster_analysis(iris.mat, n = 4, method = "kmeans")
x2 <- predict(iris.mat.km)
expect_identical(x1, x2)
})
test_that("cluster_analysis, works with include_factors, #847", {
d <- iris[3:5]
rz_kmeans <- cluster_analysis(d, n = 3, method = "kmeans", include_factors = TRUE)
expect_identical(rz_kmeans$Cluster, c("1", "2", "3"))
})
parameters/tests/testthat/test-backticks.R 0000644 0001762 0000144 00000006641 14413515226 020467 0 ustar ligges users skip_on_cran()
data(iris)
iris$`a m` <<- iris$Species
iris$`Sepal Width` <<- iris$Sepal.Width
m1 <- lm(`Sepal Width` ~ Petal.Length + `a m` * log(Sepal.Length), data = iris)
m2 <- lm(Sepal.Width ~ Petal.Length + Species * log(Sepal.Length), data = iris)
test_that("standard_error, backticks", {
expect_identical(
standard_error(m1)$Parameter,
c(
"(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica",
"log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)"
)
)
expect_identical(
standard_error(m2)$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciesversicolor", "Speciesvirginica",
"log(Sepal.Length)", "Speciesversicolor:log(Sepal.Length)", "Speciesvirginica:log(Sepal.Length)"
)
)
})
test_that("ci, backticks", {
expect_identical(
ci(m1)$Parameter,
c(
"(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica",
"log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)"
)
)
expect_identical(
ci(m2)$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciesversicolor", "Speciesvirginica",
"log(Sepal.Length)", "Speciesversicolor:log(Sepal.Length)", "Speciesvirginica:log(Sepal.Length)"
)
)
expect_identical(
ci(m1, method = "wald")$Parameter,
c(
"(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica",
"log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)"
)
)
expect_identical(
ci(m2, method = "wald")$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciesversicolor", "Speciesvirginica",
"log(Sepal.Length)", "Speciesversicolor:log(Sepal.Length)", "Speciesvirginica:log(Sepal.Length)"
)
)
})
test_that("p, backticks", {
expect_identical(
p_value(m1)$Parameter,
c(
"(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica",
"log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)"
)
)
expect_identical(
p_value(m2)$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciesversicolor", "Speciesvirginica",
"log(Sepal.Length)", "Speciesversicolor:log(Sepal.Length)", "Speciesvirginica:log(Sepal.Length)"
)
)
})
test_that("model_parameters, backticks", {
expect_identical(
model_parameters(m1)$Parameter,
c(
"(Intercept)", "Petal.Length", "a mversicolor", "a mvirginica",
"log(Sepal.Length)", "a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)"
)
)
expect_identical(
model_parameters(m2)$Parameter,
c(
"(Intercept)", "Petal.Length", "Speciesversicolor", "Speciesvirginica",
"log(Sepal.Length)", "Speciesversicolor:log(Sepal.Length)", "Speciesvirginica:log(Sepal.Length)"
)
)
})
test_that("model_parameters-2, backticks", {
expect_identical(
model_parameters(select_parameters(m1))$Parameter,
c(
"(Intercept)", "a mversicolor", "a mvirginica", "log(Sepal.Length)",
"a mversicolor:log(Sepal.Length)", "a mvirginica:log(Sepal.Length)"
)
)
expect_identical(
model_parameters(select_parameters(m2))$Parameter,
c(
"(Intercept)", "Speciesversicolor", "Speciesvirginica", "log(Sepal.Length)",
"Speciesversicolor:log(Sepal.Length)", "Speciesvirginica:log(Sepal.Length)"
)
)
})
parameters/tests/testthat/test-lmerTest.R 0000644 0001762 0000144 00000002024 14413515226 020317 0 ustar ligges users skip_on_cran()
skip_if_not_installed("lmerTest")
skip_if_not_installed("pbkrtest")
data("carrots", package = "lmerTest")
m1 <- lmerTest::lmer(Preference ~ sens2 + Homesize + (1 + sens2 | Consumer), data = carrots)
test_that("model_parameters, satterthwaite", {
params <- model_parameters(m1, effects = "fixed", ci_method = "satterthwaite")
s <- summary(m1)
expect_equal(params$df, as.vector(s$coefficients[, "df"]), tolerance = 1e-4)
expect_equal(params$t, as.vector(s$coefficients[, "t value"]), tolerance = 1e-4)
expect_equal(params$p, as.vector(s$coefficients[, "Pr(>|t|)"]), tolerance = 1e-4)
})
test_that("model_parameters, kenward", {
params <- model_parameters(m1, effects = "fixed", ci_method = "kenward")
s <- summary(m1, ddf = "Kenward-Roger")
expect_equal(params$df, as.vector(s$coefficients[, "df"]), tolerance = 1e-4)
expect_equal(params$t, as.vector(s$coefficients[, "t value"]), tolerance = 1e-4)
expect_equal(params$p, as.vector(s$coefficients[, "Pr(>|t|)"]), tolerance = 1e-4)
})
parameters/tests/testthat/test-format_model_parameters.R 0000644 0001762 0000144 00000016267 14716604201 023427 0 ustar ligges users skip_if_not_installed("withr")
# make sure we have the correct interaction mark for tests
withr::with_options(
list(parameters_interaction = "*"),
{
test_that("format_model_parameters-1", {
m <- lm(mpg ~ qsec:wt + wt:drat, data = mtcars)
expect_identical(unname(format_parameters(m)), c("(Intercept)", "qsec * wt", "wt * drat"))
})
test_that("format_model_parameters-2", {
m <- lm(mpg ~ qsec:wt + wt / drat, data = mtcars)
expect_identical(unname(format_parameters(m)), c("(Intercept)", "wt", "qsec * wt", "wt * drat"))
})
test_that("format_model_parameters-3", {
m <- lm(mpg ~ qsec:wt + wt:drat + wt, data = mtcars)
expect_identical(unname(format_parameters(m)), c("(Intercept)", "wt", "qsec * wt", "wt * drat"))
})
test_that("format_model_parameters-4", {
m <- lm(mpg ~ qsec:wt + wt / drat + wt, data = mtcars)
expect_identical(unname(format_parameters(m)), c("(Intercept)", "wt", "qsec * wt", "wt * drat"))
})
test_that("format_model_parameters-5", {
m <- lm(mpg ~ qsec * wt + wt:drat + wt, data = mtcars)
expect_identical(unname(format_parameters(m)), c("(Intercept)", "qsec", "wt", "qsec * wt", "wt * drat"))
})
test_that("format_model_parameters-6", {
m <- lm(mpg ~ wt + qsec + wt:qsec, data = mtcars)
expect_identical(unname(format_parameters(m)), c("(Intercept)", "wt", "qsec", "wt * qsec"))
})
test_that("format_model_parameters-7", {
m <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-8", {
m <- lm(Sepal.Width ~ Species:Petal.Length, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [setosa] * Petal Length",
"Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-9", {
m <- lm(Sepal.Width ~ Species / Petal.Length, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Species [setosa] * Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-10", {
m <- lm(Sepal.Width ~ Species * Petal.Length + Species, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-11", {
m <- lm(Sepal.Width ~ Species:Petal.Length + Species, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Species [setosa] * Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-12", {
m <- lm(Sepal.Width ~ Species / Petal.Length + Species, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Species [setosa] * Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-13", {
m <- lm(Sepal.Width ~ Species * Petal.Length + Petal.Length, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-14", {
m <- lm(Sepal.Width ~ Species:Petal.Length + Petal.Length, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Petal Length", "Species [versicolor] * Petal Length",
"Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-15", {
m <- lm(Sepal.Width ~ Species / Petal.Length + Petal.Length, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-16", {
m <- lm(Sepal.Width ~ Species * Petal.Length + Petal.Length + Species, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-17", {
m <- lm(Sepal.Width ~ Species:Petal.Length + Petal.Length + Species, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Petal Length", "Species [versicolor]", "Species [virginica]",
"Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"
)
)
})
test_that("format_model_parameters-18", {
m <- lm(Sepal.Width ~ Species / Petal.Length + Petal.Length + Species, data = iris)
expect_identical(
unname(format_parameters(m)),
c(
"(Intercept)", "Species [versicolor]", "Species [virginica]",
"Petal Length", "Species [versicolor] * Petal Length", "Species [virginica] * Petal Length"
)
)
})
}
)
skip_if_not_installed("lme4")
skip_if_not_installed("glmmTMB")
test_that("format, compare_parameters, mixed models", {
data(mtcars)
data(Salamanders, package = "glmmTMB")
model1 <- lme4::lmer(mpg ~ wt + (1 | gear), data = mtcars)
model2 <- glmmTMB::glmmTMB(
count ~ spp + mined + (1 | site),
ziformula = ~mined,
family = poisson(),
data = Salamanders
)
out <- compare_parameters(model1, model2, effects = "all", component = "all")
f <- format(out)
expect_length(f, 3)
f <- format(out, format = "html")
expect_identical(
f$Component,
c(
"Fixed Effects", "Fixed Effects", "Fixed Effects", "Fixed Effects",
"Fixed Effects", "Fixed Effects", "Fixed Effects", "Fixed Effects",
"Fixed Effects", "Fixed Effects (Zero-Inflation Component)",
"Fixed Effects (Zero-Inflation Component)", "Random Effects",
"Random Effects", "Random Effects"
)
)
})
parameters/tests/testthat/test-model_parameters_random_pars.R 0000644 0001762 0000144 00000014537 14413515226 024444 0 ustar ligges users skip_on_cran()
skip_if_not_installed("lme4")
data(sleepstudy, package = "lme4")
model <- lme4::lmer(Reaction ~ Days + (1 | Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 1", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(6.81191, 1.72707), tolerance = 1e-3)
expect_equal(mp$CI_low, c(25.90983, 27.78454), tolerance = 1e-3)
expect_equal(mp$Parameter, c("SD (Intercept)", "SD (Observations)"))
})
model <- lme4::lmer(Reaction ~ Days + (1 + Days | Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 2", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(5.83626, 1.24804, 0.31859, 1.50801), tolerance = 1e-3)
expect_equal(mp$CI_low, c(15.5817, 3.91828, -0.50907, 22.80044), tolerance = 1e-3)
expect_equal(mp$Parameter, c("SD (Intercept)", "SD (Days)", "Cor (Intercept~Days)", "SD (Observations)"))
})
model <- lme4::lmer(Reaction ~ Days + (1 + Days || Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 3", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(5.66046, 1.21291, 1.50063), tolerance = 1e-3)
expect_equal(mp$CI_low, c(16.08784, 4.0261, 22.78698), tolerance = 1e-3)
expect_equal(mp$Parameter, c("SD (Intercept)", "SD (Days)", "SD (Observations)"))
})
model <- lme4::lmer(Reaction ~ Days + (0 + Days || Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 4", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(1.31507, 1.6171), tolerance = 1e-3)
expect_equal(mp$CI_low, c(5.09041, 26.01525), tolerance = 1e-3)
expect_equal(mp$Parameter, c("SD (Days)", "SD (Observations)"))
})
data(sleepstudy, package = "lme4")
set.seed(12345)
sleepstudy$grp <- sample(1:5, size = 180, replace = TRUE)
sleepstudy$subgrp <- NA
for (i in 1:5) {
filter_group <- sleepstudy$grp == i
sleepstudy$subgrp[filter_group] <-
sample(1:30, size = sum(filter_group), replace = TRUE)
}
model <- lme4::lmer(Reaction ~ Days + (1 | grp / subgrp) + (1 | Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random", ci_random = TRUE)
test_that("model_parameters-random pars 5", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(8.92501, 6.80902, 6.70278, 2.41892), tolerance = 1e-3)
expect_equal(mp$CI_low, c(0.37493, 25.90517, 0.00135, 25.92818), tolerance = 1e-3)
expect_equal(mp$Parameter, c("SD (Intercept)", "SD (Intercept)", "SD (Intercept)", "SD (Observations)"))
})
model <- lme4::lmer(Reaction ~ Days + (1 | grp / subgrp), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 6", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(11.37581, 10.02558, 3.45893), tolerance = 1e-3)
expect_equal(mp$CI_low, c(1.33029, 0.00166, 40.13353), tolerance = 1e-3)
expect_equal(mp$Parameter, c("SD (Intercept)", "SD (Intercept)", "SD (Observations)"))
})
data(sleepstudy, package = "lme4")
sleepstudy$Days2 <- cut(sleepstudy$Days, breaks = c(-1, 3, 6, 10))
model <- lme4::lmer(Reaction ~ Days2 + (1 + Days2 | Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 7", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(5.68189, 5.16887, 8.47536, 0.3384, 0.47038, 0.41966, 1.7238), tolerance = 1e-3)
expect_equal(mp$CI_low, c(16.7131, 21.12065, 24.1964, -0.36662, -0.59868, -0.93174, 24.18608), tolerance = 1e-3)
expect_equal(
mp$Parameter,
c(
"SD (Intercept)", "SD (Days2(3,6])", "SD (Days2(6,10])", "Cor (Intercept~Days2(3,6])",
"Cor (Intercept~Days2(6,10])", "Cor (Days2(3,6]~Days2(6,10])",
"SD (Observations)"
)
)
})
model <- lme4::lmer(Reaction ~ Days2 + (0 + Days2 | Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
test_that("model_parameters-random pars 8", {
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(5.68188, 4.951, 9.773, 0.34887, 0.59977, 0.3494, 1.7238), tolerance = 1e-3)
expect_equal(mp$CI_low, c(16.713, 37.06178, 36.14261, -0.65336, -0.92243, -0.99569, 24.18612), tolerance = 1e-3)
expect_equal(
mp$Parameter,
c(
"SD (Days2(-1,3])", "SD (Days2(3,6])", "SD (Days2(6,10])",
"Cor (Days2(-1,3]~Days2(3,6])", "Cor (Days2(-1,3]~Days2(6,10])",
"Cor (Days2(3,6]~Days2(6,10])", "SD (Observations)"
)
)
})
test_that("model_parameters-random pars 9", {
suppressMessages(
model <- lme4::lmer(Reaction ~ Days2 + (1 + Days2 || Subject), data = sleepstudy)
)
mp <- model_parameters(model, effects = "random", verbose = FALSE)
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_true(all(is.na(mp$SE)))
expect_equal(
mp$Parameter,
c(
"SD (Intercept)", "SD (Days2(-1,3])", "SD (Days2(3,6])", "SD (Days2(6,10])",
"Cor (Days2(-1,3]~Days2(3,6])", "Cor (Days2(-1,3]~Days2(6,10])",
"Cor (Days2(3,6]~Days2(6,10])", "SD (Observations)"
)
)
})
test_that("model_parameters-random pars 10", {
model <- lme4::lmer(Reaction ~ Days2 + (0 + Days2 || Subject), data = sleepstudy)
mp <- model_parameters(model, effects = "random")
expect_equal(mp$Coefficient, as.data.frame(lme4::VarCorr(model))$sdcor, tolerance = 1e-3)
expect_equal(mp$SE, c(5.68188, 4.951, 9.773, 0.34887, 0.59977, 0.3494, 1.7238), tolerance = 1e-3)
expect_equal(mp$CI_low, c(16.713, 37.06178, 36.14261, -0.65336, -0.92243, -0.99569, 24.18612), tolerance = 1e-3)
expect_equal(
mp$Parameter,
c(
"SD (Days2(-1,3])", "SD (Days2(3,6])", "SD (Days2(6,10])",
"Cor (Days2(-1,3]~Days2(3,6])", "Cor (Days2(-1,3]~Days2(6,10])",
"Cor (Days2(3,6]~Days2(6,10])", "SD (Observations)"
)
)
})
parameters/tests/testthat/test-simulate_parameters.R 0000644 0001762 0000144 00000002740 14413515226 022573 0 ustar ligges users skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.0.0")
skip_if_not_installed("sandwich")
mod <- lm(mpg ~ wt + cyl, data = mtcars)
test_that("simulate_parameters, lm", {
set.seed(123)
s1 <- simulate_parameters(mod)
set.seed(123)
s2 <- simulate_parameters(mod, vcov = "HC1")
expect_equal(dim(s1), c(3L, 5L))
expect_equal(dim(s2), c(3L, 5L))
expect_false(isTRUE(all.equal(s1$Coefficient, s2$Coefficient, tolerance = 1e-5)))
expect_false(isTRUE(all.equal(s1$Coefficient, s2$CI_low, tolerance = 1e-5)))
})
skip_on_cran()
skip_if_not_installed("glmmTMB")
data(fish)
mod <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 | persons),
ziformula = ~ child + camper + (1 | persons),
data = fish,
family = glmmTMB::truncated_poisson()
))
test_that("simulate_parameters, glmmTMB", {
set.seed(123)
s <- simulate_parameters(mod)
expect_equal(dim(s), c(6L, 6L))
expect_equal(s$Coefficient, c(1.26979, -1.14433, 0.73637, -0.39618, 2.05839, -1.01957), tolerance = 1e-1)
expect_equal(s$CI_low, c(0.33767, -1.33193, 0.55914, -1.65328, 1.44539, -1.65345), tolerance = 1e-1)
})
test_that("simulate_parameters, glmmTMB, conditional only", {
set.seed(123)
s <- simulate_parameters(mod, component = "conditional")
expect_equal(dim(s), c(3L, 5L))
expect_equal(s$Coefficient, c(1.26979, -1.14433, 0.73637), tolerance = 1e-1)
expect_equal(s$CI_low, c(0.33767, -1.33193, 0.55914), tolerance = 1e-1)
})
parameters/tests/testthat/test-get_scores.R 0000644 0001762 0000144 00000000624 14413515226 020661 0 ustar ligges users skip_on_cran()
test_that("get_scores", {
skip_if_not_installed("psych")
pca <- principal_components(mtcars[, 1:7], n = 2, rotation = "varimax")
scores <- get_scores(pca)
expect_equal(head(scores$Component_1), c(38.704, 38.755, 28.194, 58.339, 78.658, 51.064), tolerance = 1e-2)
expect_equal(head(scores$Component_2), c(63.23, 63.51, 55.805, 64.72, 96.01, 62.61), tolerance = 1e-2)
})
parameters/tests/testthat/test-model_parameters.mediate.R 0000644 0001762 0000144 00000004311 14413515226 023453 0 ustar ligges users skip_if_not_installed("mediation")
skip_if_not_installed("MASS")
data(jobs, package = "mediation")
b <- lm(job_seek ~ treat + econ_hard + sex + age, data = jobs)
c <- lm(depress2 ~ treat + job_seek + econ_hard + sex + age, data = jobs)
set.seed(1234)
m1 <- mediation::mediate(b, c, sims = 50, treat = "treat", mediator = "job_seek")
b2 <- lm(job_seek ~ educ + sex, data = jobs)
c2 <- lm(depress2 ~ educ + job_seek + sex, data = jobs)
set.seed(1234)
m2 <- mediation::mediate(b2, c2,
treat = "educ", mediator = "job_seek", sims = 50,
control.value = "gradwk", treat.value = "somcol"
)
test_that("model_parameters.mediate-1", {
params <- model_parameters(m1)
expect_equal(params$Estimate, c(-0.01488, -0.04753, -0.06242, 0.16635), tolerance = 1e-2)
expect_equal(params$Parameter, c("ACME", "ADE", "Total Effect", "Prop. Mediated"))
})
test_that("model_parameters.mediate-2", {
params <- model_parameters(m2)
expect_equal(params$Estimate, c(0.02484, -0.05793, -0.03309, -0.27914), tolerance = 1e-2)
expect_equal(params$Parameter, c("ACME", "ADE", "Total Effect", "Prop. Mediated"))
})
test_that("model_parameters.mediate-3", {
skip_on_cran()
jobs$job_disc <- as.factor(jobs$job_disc)
b.ord <- MASS::polr(
job_disc ~ treat + econ_hard + sex + age,
data = jobs,
method = "probit",
Hess = TRUE
)
d.bin <- glm(
work1 ~ treat + job_disc + econ_hard + sex + age,
data = jobs,
family = binomial(link = "probit")
)
set.seed(1234)
m3 <- mediation::mediate(b.ord, d.bin, sims = 50, treat = "treat", mediator = "job_disc")
params <- model_parameters(m3)
expect_equal(params$Estimate, c(
0.00216, 0.00231, 0.0486, 0.04875, 0.05091, 0.03981, 0.04829,
0.00223, 0.04868, 0.04405
), tolerance = 1e-2)
expect_equal(params$Parameter, c(
"ACME (control)", "ACME (treated)", "ADE (control)", "ADE (treated)",
"Total Effect", "Prop. Mediated (control)", "Prop. Mediated (treated)",
"ACME (average)", "ADE (average)", "Prop. Mediated (average)"
))
expect_equal(params$Component, c(
"control", "treated", "control", "treated", "Total Effect",
"control", "treated", "average", "average", "average"
))
})
parameters/tests/testthat/test-model_parameters.truncreg.R 0000644 0001762 0000144 00000001176 14413515226 023702 0 ustar ligges users test_that("model_parameters.truncreg", {
skip_if_not_installed("truncreg")
skip_if_not_installed("survival")
set.seed(123)
data("tobin", package = "survival")
model <- truncreg::truncreg(
formula = durable ~ age + quant,
data = tobin,
subset = durable > 0
)
params <- model_parameters(model)
expect_equal(params$SE, c(9.21875, 0.22722, 0.03259, 0.56841), tolerance = 1e-3)
expect_equal(params$t, c(1.36653, 1.89693, -3.64473, 2.90599), tolerance = 1e-3)
expect_equal(
colnames(params),
c("Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "t", "df_error", "p")
)
})
parameters/tests/testthat/test-model_parameters.epi2x2.R 0000644 0001762 0000144 00000001126 14716604201 023153 0 ustar ligges users skip_on_cran()
skip_if_not_installed("epiR")
test_that("model_parameters.epi2x2", {
data(mtcars)
tab <- xtabs(~ am + vs, data = mtcars)
out <- model_parameters(epiR::epi.2by2(tab))
expect_identical(out$Parameter, c("RR", "OR", "ARisk", "AFRisk", "PARisk", "PAFRisk"))
expect_identical(
attributes(out)$pretty_names,
c(
RR = "Risk Ratio", OR = "Odds Ratio", ARisk = "Attributable Risk",
AFRisk = "Attributable Fraction in Exposed (%)", PARisk = "Attributable Risk in Population",
PAFRisk = "Attributable Fraction in Population (%)"
)
)
})
parameters/tests/testthat/test-mipo.R 0000644 0001762 0000144 00000002174 14433114017 017465 0 ustar ligges users skip_if_not_installed("mice")
skip_if_not_installed("nnet")
skip_if_not(packageVersion("insight") > "0.19.1")
test_that("param ordinal", {
set.seed(1234)
d <- suppressWarnings(mice::ampute(mtcars)) ## Ampute mtcars and impute two data sets
imp <- suppressWarnings(mice::mice(d$amp, m = 2, printFlag = FALSE))
imp.l <- mice::complete(imp, action = "long")
model <- list() ## Fit and pool models
for (i in 1:2) {
capture.output({
model[[i]] <- nnet::multinom(cyl ~ disp + hp, data = imp.l, subset = .imp == i)
})
}
pooled <- mice::pool(model)
mp <- model_parameters(pooled)
expect_snapshot(print(mp))
})
test_that("param normal", {
set.seed(1234)
d <- suppressWarnings(mice::ampute(mtcars)) ## Ampute mtcars and impute two data sets
imp <- suppressWarnings(mice::mice(d$amp, m = 2, printFlag = FALSE))
imp.l <- mice::complete(imp, action = "long")
model <- list() ## Fit and pool models
for (i in 1:2) model[[i]] <- lm(mpg ~ disp + hp, data = imp.l, subset = .imp == i)
pooled <- mice::pool(model)
mp <- model_parameters(pooled)
expect_snapshot(print(mp))
})
parameters/tests/testthat/test-model_parameters_ordinal.R 0000644 0001762 0000144 00000006034 14716604201 023556 0 ustar ligges users skip_on_cran()
skip_if_not_installed("ordinal")
d <- data.frame(
Stim = c(
"New", "New", "New", "New", "New", "New",
"Old", "Old", "Old", "Old", "Old", "Old"
),
Response = c(
"Confidence1", "Confidence2", "Confidence3", "Confidence4",
"Confidence5", "Confidence6", "Confidence1", "Confidence2",
"Confidence3", "Confidence4", "Confidence5", "Confidence6"
),
w = c(320, 295, 243, 206, 174, 159, 136, 188, 208, 256, 302, 333),
stringsAsFactors = FALSE
)
m1 <- ordinal::clm(ordered(Response) ~ Stim,
scale = ~Stim,
link = "probit",
data = d, weights = w
)
m2 <- ordinal::clm2(ordered(Response) ~ Stim,
scale = ~Stim,
link = "probit",
data = d, weights = w
)
test_that("model_parameters.clm", {
mp <- model_parameters(m1)
expect_equal(
mp$Parameter,
c(
"Confidence1|Confidence2", "Confidence2|Confidence3", "Confidence3|Confidence4",
"Confidence4|Confidence5", "Confidence5|Confidence6", "StimOld",
"StimOld"
),
tolerance = 1e-4
)
expect_equal(
mp$Component,
c("intercept", "intercept", "intercept", "intercept", "intercept", "location", "scale"),
tolerance = 1e-4
)
expect_equal(
mp$Coefficient,
c(-0.72845, -0.15862, 0.26583, 0.69614, 1.23477, 0.55237, -0.04069),
tolerance = 1e-4
)
mp <- model_parameters(m1, exponentiate = TRUE)
expect_equal(
mp$Coefficient,
c(0.48266, 0.85332, 1.30451, 2.006, 3.4376, 0.55237, -0.04069),
tolerance = 1e-4
)
expect_snapshot(print(mp))
})
test_that("model_parameters.clm2", {
mp <- model_parameters(m2)
expect_equal(
mp$Parameter,
c(
"Confidence1|Confidence2", "Confidence2|Confidence3", "Confidence3|Confidence4",
"Confidence4|Confidence5", "Confidence5|Confidence6", "StimOld",
"StimOld"
),
tolerance = 1e-4
)
expect_equal(
mp$Component,
c("intercept", "intercept", "intercept", "intercept", "intercept", "location", "scale"),
tolerance = 1e-4
)
expect_equal(
mp$Coefficient,
c(-0.72845, -0.15862, 0.26583, 0.69614, 1.23477, 0.55237, -0.04069),
tolerance = 1e-4
)
mp <- model_parameters(m2, exponentiate = TRUE)
expect_equal(
mp$Coefficient,
c(0.48266, 0.85332, 1.30451, 2.006, 3.4376, 0.55237, -0.04069),
tolerance = 1e-4
)
expect_snapshot(print(mp))
})
test_that("model_parameters.clmm, exponentiate works w/o component column", {
data(wine, package = "ordinal")
mox <- ordinal::clmm(rating ~ temp + contact + (1 | judge), data = wine)
out1 <- model_parameters(mox, exponentiate = FALSE)
out2 <- model_parameters(mox, exponentiate = TRUE)
expect_equal(out1$Coefficient, c(-1.62367, 1.51337, 4.22853, 6.08877, 3.063, 1.83488, 1.13113), tolerance = 1e-4)
expect_equal(out2$Coefficient, c(0.19717, 4.54199, 68.61606, 440.87991, 21.39156, 6.26441, 1.13113), tolerance = 1e-4)
expect_identical(attributes(out1)$coefficient_name, "Log-Odds")
expect_identical(attributes(out2)$coefficient_name, "Odds Ratio")
})
parameters/tests/testthat/test-rank_deficienty.R 0000644 0001762 0000144 00000000770 14716604201 021662 0 ustar ligges users set.seed(123)
data(mtcars)
model <-
stats::lm(
formula = wt ~ am * cyl * vs,
data = mtcars
)
test_that("model_parameters-rank_deficiency", {
expect_message(model_parameters(model))
params <- suppressWarnings(suppressMessages(model_parameters(model)))
expect_equal(params$Parameter, c("(Intercept)", "am", "cyl", "vs", "am:cyl", "am:vs"), tolerance = 1e-3)
expect_equal(params$Coefficient, c(2.28908, -1.37908, 0.22688, -0.26158, 0.08062, 0.14987), tolerance = 1e-3)
})
parameters/tests/testthat/test-simulate_model.R 0000644 0001762 0000144 00000003416 14413515226 021531 0 ustar ligges users skip_on_os(c("mac", "linux", "solaris"))
skip_if_not(getRversion() >= "4.0.0")
skip_if_not_installed("sandwich")
mod <- lm(mpg ~ wt + cyl, data = mtcars)
test_that("simulate_model, lm", {
set.seed(123)
s1 <- simulate_model(mod, iterations = 100)
set.seed(123)
s2 <- simulate_model(mod, iterations = 100, vcov = "HC1")
expect_identical(dim(s1), c(100L, 3L))
expect_identical(dim(s2), c(100L, 3L))
expect_false(isTRUE(all.equal(head(s1$wt), head(s2$wt), tolerance = 1e-5)))
expect_false(isTRUE(all.equal(mean(s1$cyl), mean(s2$cyl), tolerance = 1e-5)))
})
skip_on_cran()
skip_if_not_installed("glmmTMB")
data(fish)
mod <- suppressWarnings(glmmTMB::glmmTMB(
count ~ child + camper + (1 | persons),
ziformula = ~ child + camper + (1 | persons),
data = fish,
family = glmmTMB::truncated_poisson()
))
test_that("simulate_model, glmmTMB", {
set.seed(123)
s <- simulate_model(mod, iterations = 100)
expect_identical(dim(s), c(100L, 6L))
expect_identical(
colnames(s),
c(
"(Intercept)", "child", "camper1", "(Intercept)_zi", "child_zi",
"camper1_zi"
)
)
expect_equal(
head(s$child),
c(-1.21946, -1.23724, -1.10968, -1.14867, -1.04882, -1.11192),
tolerance = 1e-2
)
expect_equal(mean(s$camper1), 0.717259, tolerance = 1e-1)
})
test_that("simulate_model, glmmTMB, conditional only", {
set.seed(123)
s <- simulate_model(mod, component = "conditional", iterations = 100)
expect_identical(dim(s), c(100L, 3L))
expect_identical(colnames(s), c("(Intercept)", "child", "camper1"))
expect_equal(
head(s$child),
c(-1.21946, -1.23724, -1.10968, -1.14867, -1.04882, -1.11192),
tolerance = 1e-2
)
expect_equal(mean(s$camper1), 0.717259, tolerance = 1e-1)
})
parameters/tests/testthat/test-model_parameters.maov.R 0000644 0001762 0000144 00000000703 14355245205 023010 0 ustar ligges users fit <- lm(cbind(mpg, disp, hp) ~ factor(cyl), data = mtcars)
m <- aov(fit)
mp <- model_parameters(m)
test_that("model_parameters.maov", {
expect_equal(
mp$Sum_Squares,
as.vector(do.call(c, lapply(summary(m), function(i) as.data.frame(i)$`Sum Sq`))),
tolerance = 1e-3
)
expect_equal(
mp[["F"]],
as.vector(do.call(c, lapply(summary(m), function(i) as.data.frame(i)[["F value"]]))),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-rstanarm.R 0000644 0001762 0000144 00000002531 14716604201 020350 0 ustar ligges users skip_on_os("mac")
skip_on_cran()
test_that("mp", {
skip_if_not_installed("rstanarm")
set.seed(123)
model <- rstanarm::stan_glm(
vs ~ mpg + cyl,
data = mtcars,
refresh = 0,
family = "binomial",
seed = 123
)
mp <- model_parameters(model, centrality = "mean")
s <- summary(model)
expect_equal(mp$Mean, unname(s[1:3, 1]), tolerance = 1e-2, ignore_attr = TRUE)
expect_equal(mp$Prior_Scale, c(2.5, 0.4148, 1.39984), tolerance = 1e-2)
})
test_that("mp2", {
skip_if_not_installed("rstanarm")
data(pbcLong, package = "rstanarm")
pbcLong$ybern <- as.integer(pbcLong$logBili >= mean(pbcLong$logBili))
set.seed(123)
invisible(capture.output({
model <- rstanarm::stan_mvmer(
formula = list(
ybern ~ year + (1 | id),
albumin ~ sex + year + (year | id)
),
data = pbcLong,
refresh = 0,
seed = 123
)
}))
mp <- suppressWarnings(model_parameters(model, centrality = "mean"))
s <- summary(model)
expect_equal(
mp$Mean,
unname(s[c("y1|(Intercept)", "y1|year", "y2|(Intercept)", "y2|sexf", "y2|year"), 1]),
tolerance = 1e-2,
ignore_attr = TRUE
)
expect_identical(mp$Response, c("y1", "y1", "y2", "y2", "y2"))
expect_equal(mp$Prior_Scale, c(4.9647, 0.3465, 5.57448, 1.39362, 0.38906), tolerance = 1e-2)
})
parameters/tests/testthat/test-model_parameters.mixed.R 0000644 0001762 0000144 00000012530 14757342252 023163 0 ustar ligges users skip_if_not_installed("lme4")
skip_on_cran()
m1 <- lme4::lmer(wt ~ cyl + (1 | gear), data = mtcars)
m2 <- lme4::glmer(vs ~ cyl + (1 | gear), data = mtcars, family = "binomial")
m3 <- lme4::lmer(wt ~ cyl + mpg + (1 | gear), data = mtcars)
test_that("model_parameters.mixed", {
params <- model_parameters(m3, keep = "^cyl", effects = "fixed")
expect_identical(dim(params), c(1L, 10L))
expect_message({
params <- model_parameters(m3, keep = "^abc", effects = "fixed")
})
expect_identical(dim(params), c(3L, 10L))
params <- model_parameters(m1, ci_method = "normal", effects = "fixed")
expect_identical(c(nrow(params), ncol(params)), c(2L, 10L))
expect_equal(params$CI_high, c(1.6373105660317, 0.554067677205595), tolerance = 1e-3)
params <- model_parameters(m1, effects = "fixed")
expect_identical(c(nrow(params), ncol(params)), c(2L, 10L))
expect_equal(params$CI_high, c(1.68181, 0.56083), tolerance = 1e-3)
params <- model_parameters(m1, ci = c(0.8, 0.9), ci_method = "normal", effects = "fixed")
expect_identical(c(nrow(params), ncol(params)), c(2L, 11L))
expect_equal(params$CI_high_0.8, c(1.29595665381331, 0.502185700948862), tolerance = 1e-3)
expect_equal(params$CI_high_0.9, c(1.47875781798108, 0.529969433080186), tolerance = 1e-3)
params <- model_parameters(m1, ci_method = "normal", effects = "fixed")
lme4_ci <- na.omit(as.data.frame(confint(m1, method = "Wald")))
expect_equal(params$CI_low, lme4_ci$`2.5 %`, tolerance = 1e-4)
params <- model_parameters(m1, ci = c(0.8, 0.9), ci_method = "wald", effects = "fixed")
expect_identical(c(nrow(params), ncol(params)), c(2L, 11L))
expect_equal(params$CI_high_0.8, c(1.31154, 0.50455), tolerance = 1e-3)
expect_equal(params$CI_high_0.9, c(1.50707, 0.53427), tolerance = 1e-3)
params <- model_parameters(m1, ci = c(0.8, 0.9), effects = "fixed")
expect_identical(c(nrow(params), ncol(params)), c(2L, 11L))
expect_equal(params$CI_high_0.8, c(1.31154, 0.50455), tolerance = 1e-3)
expect_equal(params$CI_high_0.9, c(1.50707, 0.53427), tolerance = 1e-3)
params <- model_parameters(m2, effects = "fixed")
expect_identical(c(nrow(params), ncol(params)), c(2L, 10L))
model <- lme4::glmer(vs ~ drat + cyl + (1 | gear), data = mtcars, family = "binomial")
params <- model_parameters(model, effects = "fixed")
cs <- coef(summary(model))
expect_identical(c(nrow(params), ncol(params)), c(3L, 10L))
expect_named(params, c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"z", "df_error", "p", "Effects"
))
expect_identical(params$Parameter, rownames(cs))
})
test_that("model_parameters.mixed bootstrap", {
skip_on_os(c("linux", "mac"))
skip_on_cran()
set.seed(123)
suppressWarnings(expect_message(
{
params <- model_parameters(m1, bootstrap = TRUE, iterations = 100)
},
regex = "only returns"
))
expect_equal(params$Coefficient, c(0.60496, 0.41412), tolerance = 1e-3)
})
test_that("model_parameters.mixed-random", {
params <- model_parameters(m1, effects = "random", group_level = TRUE)
expect_identical(c(nrow(params), ncol(params)), c(3L, 9L))
expect_identical(as.vector(params$Parameter), c("(Intercept)", "(Intercept)", "(Intercept)"))
expect_identical(as.vector(params$Level), c("3", "4", "5"))
expect_equal(params$Coefficient, c(0.1692, 0.0566, -0.2259), tolerance = 1e-2)
})
test_that("model_parameters.mixed-ran_pars", {
params <- model_parameters(m1, effects = "random")
expect_identical(c(nrow(params), ncol(params)), c(2L, 8L))
expect_identical(
as.vector(params$Parameter),
c("SD (Intercept)", "SD (Observations)")
)
expect_equal(params$Coefficient, c(0.27049, 0.59385), tolerance = 1e-2)
})
test_that("model_parameters.mixed-all", {
params <- model_parameters(m1, effects = "all")
expect_identical(c(nrow(params), ncol(params)), c(4L, 11L))
expect_identical(
as.vector(params$Parameter),
c("(Intercept)", "cyl", "SD (Intercept)", "SD (Observations)")
)
expect_equal(params$Coefficient, c(0.65112, 0.40418, 0.27049, 0.59385), tolerance = 1e-2)
})
test_that("model_parameters.mixed-all_pars", {
params <- model_parameters(m1, effects = "all", group_level = TRUE)
expect_identical(c(nrow(params), ncol(params)), c(5L, 12L))
expect_identical(
as.vector(params$Parameter),
c("(Intercept)", "cyl", "(Intercept)", "(Intercept)", "(Intercept)")
)
expect_equal(as.vector(params$Level), c(NA, NA, "3", "4", "5"), ignore_attr = TRUE)
expect_equal(
params$Coefficient,
c(0.65112, 0.40418, 0.16923, 0.05663, -0.22586),
tolerance = 1e-2
)
})
data("qol_cancer")
qol_cancer <- cbind(
qol_cancer,
demean(qol_cancer, select = c("phq4", "QoL"), by = "ID")
)
model <- lme4::lmer(
QoL ~ time + phq4_within + phq4_between + (1 | ID),
data = qol_cancer
)
mp <- model_parameters(model, effects = "fixed")
test_that("model_parameters.mixed", {
expect_identical(mp$Component, c("rewb-contextual", "rewb-contextual", "within", "between"))
})
test_that("print-model_parameters", {
expect_snapshot(model_parameters(model, effects = "fixed"))
})
test_that("print-model_parameters", {
skip_if_not_installed("merDeriv")
expect_snapshot(model_parameters(m1, effects = "all"))
expect_snapshot(model_parameters(m1, effects = "fixed", include_info = TRUE))
})
parameters/tests/testthat/test-parameters_type-2.R 0000644 0001762 0000144 00000004604 14355245205 022073 0 ustar ligges users dat <- iris
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type default contrasts", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, "versicolor", "virginica"))
})
dat <- iris
dat$Species <- as.ordered(dat$Species)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type ordered factor", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "ordered", "ordered"))
expect_equal(p_type$Level, c(NA, "[linear]", "[quadratic]"))
})
dat <- iris
dat$Species <- as.ordered(dat$Species)
contrasts(dat$Species) <- contr.treatment(3)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type ordered factor", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, "2", "3"))
})
dat <- iris
contrasts(dat$Species) <- contr.poly(3)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type poly contrasts", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, ".L", ".Q"))
})
dat <- iris
contrasts(dat$Species) <- contr.treatment(3)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type treatment contrasts", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, "2", "3"))
})
dat <- iris
contrasts(dat$Species) <- contr.sum(3)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type sum contrasts", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, "1", "2"))
})
dat <- iris
contrasts(dat$Species) <- contr.helmert(3)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type helmert contrasts", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, "1", "2"))
})
dat <- iris
contrasts(dat$Species) <- contr.SAS(3)
m <- lm(Sepal.Length ~ Species, data = dat)
test_that("parameters_type SAS contrasts", {
p_type <- parameters_type(m)
expect_equal(p_type$Type, c("intercept", "factor", "factor"))
expect_equal(p_type$Level, c(NA, "1", "2"))
})
parameters/tests/testthat/test-zeroinfl.R 0000644 0001762 0000144 00000004610 14413515226 020353 0 ustar ligges users skip_if_not_installed("pscl")
data("bioChemists", package = "pscl")
m1 <- pscl::zeroinfl(art ~ fem + mar + kid5 + ment | kid5 + phd, data = bioChemists)
test_that("ci", {
expect_equal(
ci(m1)$CI_low,
c(0.42844, -0.34446, 0.00734, -0.26277, 0.01717, -1.77978, -0.37558, -0.51411),
tolerance = 1e-4
)
})
test_that("se", {
expect_equal(
standard_error(m1)$SE,
c(0.06797, 0.05868, 0.06593, 0.04874, 0.00212, 0.43378, 0.21509, 0.1352),
tolerance = 1e-4
)
})
test_that("p_value", {
expect_equal(
p_value(m1)$p,
c(0, 9e-05, 0.03833, 6e-04, 0, 0.03211, 0.83068, 0.06539),
tolerance = 1e-4
)
expect_s3_class(p_value(m1, method = "robust"), "data.frame")
expect_s3_class(p_value(m1, method = "robust", vcov = NULL), "data.frame")
expect_s3_class(p_value(m1, vcov = NULL), "data.frame")
## TODO package sandwich errors for these...
# expect_s3_class(p_value(m1, vcov = "HC"), "data.frame")
# expect_s3_class(p_value(m1, method = "robust", vcov = "HC"), "data.frame")
})
test_that("model_parameters", {
expect_equal(
model_parameters(m1)$Coefficient,
as.vector(coef(m1)),
tolerance = 1e-4
)
})
m2 <- pscl::zeroinfl(formula = art ~ . | 1, data = bioChemists, dist = "negbin")
test_that("model_parameters", {
expect_equal(
model_parameters(m2)$Coefficient,
as.vector(coef(m2)),
tolerance = 1e-4
)
expect_equal(
model_parameters(m2)$Component,
c(
"conditional", "conditional", "conditional", "conditional",
"conditional", "conditional", "zero_inflated"
)
)
})
m3 <- pscl::zeroinfl(art ~ mar + kid5 * fem + ment | kid5 * fem + phd, data = bioChemists)
test_that("model_parameters", {
expect_equal(
model_parameters(m3)$Coefficient,
as.vector(coef(m3)),
tolerance = 1e-4
)
})
test_that("parameters_type", {
expect_equal(
parameters_type(m3)$Type,
c(
"intercept", "factor", "numeric", "factor", "numeric", "interaction",
"intercept", "numeric", "factor", "numeric", "interaction"
),
tolerance = 1e-4
)
})
test_that("parameters_type", {
expect_equal(
parameters_type(m3)$Link,
c(
"Mean", "Difference", "Association", "Difference", "Association",
"Difference", "Mean", "Association", "Difference", "Association",
"Difference"
),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-model_parameters.metaBMA.R 0000644 0001762 0000144 00000007154 14412513617 023322 0 ustar ligges users skip_if_not_installed("metaBMA")
data(towels, package = "metaBMA")
set.seed(1234)
m <- suppressWarnings(
metaBMA::meta_random(
logOR,
SE,
study,
data = towels,
ci = 0.95,
iter = 100,
logml_iter = 200
)
)
test_that("model_parameters.meta_random", {
params <- model_parameters(m)
expect_identical(
params$Parameter,
c(
"Goldstein, Cialdini, & Griskevicius (2008), Exp. 1", "Goldstein, Cialdini, & Griskevicius (2008), Exp. 2",
"Schultz, Khazian, & Zaleski (2008), Exp. 2", "Schultz, Khazian, & Zaleski (2008), Exp. 3",
"Mair & Bergin-Seers (2010), Exp. 1", "Bohner & Schluter (2014), Exp. 1",
"Bohner & Schluter (2014), Exp. 2", "Overall", "tau"
)
)
expect_equal(
params$Coefficient,
c(0.3806, 0.30494, 0.20554, 0.25084, 0.28768, -0.12154, -1.45792, 0.2004, 0.12107),
tolerance = 1e-3
)
expect_equal(
params$CI_low,
c(-0.00686, 0.03816, -0.16998, -0.0825, -1.32685, -0.60772, -2.94785, -0.02744, 0.02641),
tolerance = 1e-3
)
expect_identical(
colnames(params),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Weight",
"BF", "Rhat", "ESS", "Component", "Prior_Distribution", "Prior_Location", "Prior_Scale", "Method"
)
)
})
set.seed(1234)
m2 <- metaBMA::meta_fixed(
logOR,
SE,
study,
data = towels,
ci = 0.95
)
test_that("model_parameters.meta_fixed", {
params <- model_parameters(m2)
expect_identical(params$Parameter, c(
"Goldstein, Cialdini, & Griskevicius (2008), Exp. 1", "Goldstein, Cialdini, & Griskevicius (2008), Exp. 2",
"Schultz, Khazian, & Zaleski (2008), Exp. 2", "Schultz, Khazian, & Zaleski (2008), Exp. 3",
"Mair & Bergin-Seers (2010), Exp. 1", "Bohner & Schluter (2014), Exp. 1",
"Bohner & Schluter (2014), Exp. 2", "Overall"
))
expect_equal(params$Coefficient,
c(0.3806, 0.30494, 0.20554, 0.25084, 0.28768, -0.12154, -1.45792, 0.22141),
tolerance = 1e-3
)
expect_equal(
params$CI_low,
c(-0.00686, 0.03816, -0.16998, -0.0825, -1.32685, -0.60772, -2.94785, 0.06839),
tolerance = 1e-3
)
expect_identical(
colnames(params),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Weight",
"BF", "Rhat", "ESS", "Component", "Prior_Distribution", "Prior_Location", "Prior_Scale", "Method"
)
)
})
set.seed(1234)
m3 <- suppressWarnings(
metaBMA::meta_random(
logOR,
SE,
study,
data = towels,
ci = 0.99,
iter = 100,
logml_iter = 200
)
)
test_that("model_parameters.meta_random", {
params <- model_parameters(m3)
expect_identical(
params$Parameter,
c(
"Goldstein, Cialdini, & Griskevicius (2008), Exp. 1", "Goldstein, Cialdini, & Griskevicius (2008), Exp. 2",
"Schultz, Khazian, & Zaleski (2008), Exp. 2", "Schultz, Khazian, & Zaleski (2008), Exp. 3",
"Mair & Bergin-Seers (2010), Exp. 1", "Bohner & Schluter (2014), Exp. 1",
"Bohner & Schluter (2014), Exp. 2", "Overall", "tau"
)
)
expect_equal(
params$Coefficient,
c(0.3806, 0.30494, 0.20554, 0.25084, 0.28768, -0.12154, -1.45792, 0.2004, 0.12107),
tolerance = 1e-3
)
expect_equal(
params$CI_low,
c(-0.00686, 0.03816, -0.16998, -0.0825, -1.32685, -0.60772, -2.94785, -0.15494, 0.01993),
tolerance = 1e-3
)
expect_identical(
colnames(params),
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high", "Weight",
"BF", "Rhat", "ESS", "Component", "Prior_Distribution", "Prior_Location", "Prior_Scale", "Method"
)
)
})
parameters/tests/testthat/test-bracl.R 0000644 0001762 0000144 00000003224 14413515226 017606 0 ustar ligges users skip_if_not_installed("brglm2")
data("stemcell", package = "brglm2")
levels(stemcell$research) <- c("definitly", "alterly", "probably not", "definitely not")
m1 <- brglm2::bracl(research ~ as.numeric(religion) + gender, weights = frequency, data = stemcell, type = "ML")
test_that("model_parameters", {
params <- model_parameters(m1, verbose = FALSE)
expect_identical(
params$Response,
c(
"definitly",
"alterly",
"probably not",
"definitly",
"alterly",
"probably not",
"definitly",
"alterly",
"probably not"
)
)
expect_identical(
params$Parameter,
c(
"definitly:(Intercept)", "alterly:(Intercept)", "probably not:(Intercept)",
"definitly:as.numeric(religion)", "alterly:as.numeric(religion)",
"probably not:as.numeric(religion)", "definitly:genderfemale",
"alterly:genderfemale", "probably not:genderfemale"
)
)
expect_equal(
params$Coefficient,
c(-1.24836, 0.47098, 0.42741, 0.4382, 0.25962, 0.01192, -0.13683, 0.18707, -0.16093),
tolerance = 1e-3
)
})
# check vcov args
test_that("model_parameters", {
expect_message({
out <- model_parameters(m1, vcov = "vcovHAC")
})
expect_equal(out$SE, unname(coef(summary(m1))[, 2]), tolerance = 1e-3)
})
# check order of response levels
test_that("print model_parameters", {
out <- suppressMessages(utils::capture.output(print(model_parameters(m1, verbose = FALSE))))
expect_identical(out[1], "# Response level: definitly")
expect_identical(out[9], "# Response level: alterly")
expect_identical(out[17], "# Response level: probably not")
})
parameters/tests/testthat/test-model_parameters_std_mixed.R 0000644 0001762 0000144 00000015051 14716604201 024105 0 ustar ligges users skip_if_not_installed("effectsize")
skip_if_not_installed("lme4")
skip_on_cran()
data(iris)
set.seed(1234)
iris$grp <- as.factor(sample(1:3, nrow(iris), replace = TRUE))
# fit example model
model <- lme4::lmer(
Sepal.Length ~ Species * Sepal.Width + Petal.Length + (1 | grp),
data = iris
)
test_that("model_parameters, standardize-refit, wald-normal", {
params <- model_parameters(
model,
ci_method = "normal",
standardize = "refit",
verbose = FALSE,
effects = "fixed"
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Coefficient,
c(
0.96949,
-1.28631,
-1.81461,
0.34791,
1.74252,
-0.25421,
-0.18834
),
tolerance = 1e-3
)
expect_equal(
params$SE,
c(0.2045, 0.2619, 0.34035, 0.05968, 0.13914, 0.09762, 0.0945),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(
1.37031,
-0.77301,
-1.14754,
0.46488,
2.01523,
-0.06287,
-0.00312
),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-refit, wald-t", {
params <- model_parameters(
model,
ci_method = "wald",
standardize = "refit",
verbose = FALSE,
effects = "fixed"
)
expect_equal(
params$CI_high,
c(
1.37378,
-0.76856,
-1.14177,
0.4659,
2.01759,
-0.06121,
-0.00151
),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-refit", {
params <- model_parameters(
model,
standardize = "refit",
verbose = FALSE,
effects = "fixed"
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Coefficient,
c(
0.96949,
-1.28631,
-1.81461,
0.34791,
1.74252,
-0.25421,
-0.18834
),
tolerance = 1e-3
)
expect_equal(params$SE,
c(0.2045, 0.2619, 0.34035, 0.05968, 0.13914, 0.09762, 0.0945),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(
1.37378,
-0.76856,
-1.14177,
0.4659,
2.01759,
-0.06121,
-0.00151
),
tolerance = 1e-3
)
params <- model_parameters(
model,
standardize = "refit",
verbose = FALSE,
effects = "all"
)
paramsZ <- model_parameters(
effectsize::standardize(model),
effects = "all",
verbose = FALSE
)
expect_equal(paramsZ, params, ignore_attr = TRUE)
})
test_that("model_parameters, standardize-posthoc", {
params <- model_parameters(model,
standardize = "posthoc",
verbose = FALSE,
effects = "fixed"
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Std_Coefficient,
c(0, 0.49679, -0.49355, 0.34791, 1.74252, -0.25421, -0.18834),
tolerance = 1e-3
)
expect_equal(params$SE,
c(0, 0.66228, 0.70202, 0.05968, 0.13914, 0.09762, 0.0945),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(0, 1.80607, 0.8943, 0.4659, 2.01759, -0.06121, -0.00151),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-posthoc", {
params <- model_parameters(
model,
ci_method = "normal",
standardize = "posthoc",
verbose = FALSE,
effects = "fixed"
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Std_Coefficient,
c(0, 0.49679, -0.49355, 0.34791, 1.74252, -0.25421, -0.18834),
tolerance = 1e-3
)
expect_equal(
params$SE,
c(0, 0.66228, 0.70202, 0.05968, 0.13914, 0.09762, 0.0945),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(0, 1.79483, 0.88238, 0.46488, 2.01523, -0.06287, -0.00312),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-posthoc, wald-t", {
params <- model_parameters(
model,
ci_method = "wald",
standardize = "posthoc",
verbose = FALSE,
effects = "fixed"
)
expect_equal(
params$CI_high,
c(0, 1.80607, 0.8943, 0.4659, 2.01759, -0.06121, -0.00151),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-basic", {
params <- model_parameters(
model,
ci_method = "normal",
standardize = "basic",
verbose = FALSE,
effects = "fixed"
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Std_Coefficient,
c(0, 0.23497, -0.23344, 0.34791, 1.74252, -0.77129, -0.61304),
tolerance = 1e-3
)
expect_equal(params$SE,
c(0, 0.31325, 0.33204, 0.05968, 0.13914, 0.2962, 0.30761),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(0, 0.84893, 0.41735, 0.46488, 2.01523, -0.19075, -0.01014),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-basic", {
params <- model_parameters(
model,
ci_method = "residual",
standardize = "basic",
verbose = FALSE,
effects = "fixed"
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Std_Coefficient,
c(0, 0.23497, -0.23344, 0.34791, 1.74252, -0.77129, -0.61304),
tolerance = 1e-3
)
expect_equal(
params$SE,
c(0, 0.31325, 0.33204, 0.05968, 0.13914, 0.2962, 0.30761),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(0, 0.85424, 0.42299, 0.4659, 2.01759, -0.18572, -0.00492),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-basic", {
params <- model_parameters(model,
standardize = "basic",
verbose = FALSE,
effects = "fixed"
)
expect_equal(
params$CI_high,
c(0, 0.85424, 0.42299, 0.4659, 2.01759, -0.18572, -0.00492),
tolerance = 1e-3
)
})
test_that("model_parameters, standardize-refit robust", {
skip_if_not_installed("clubSandwich")
params <- model_parameters(
model,
standardize = "refit",
effects = "fixed",
vcov = "CR",
vcov_args = list(type = "CR1", cluster = iris$grp),
verbose = FALSE
)
expect_equal(c(nrow(params), ncol(params)), c(7, 10))
expect_equal(
params$Coefficient,
c(
0.96949,
-1.28631,
-1.81461,
0.34791,
1.74252,
-0.25421,
-0.18834
),
tolerance = 1e-3
)
expect_equal(
params$SE,
c(0.07726, 0.33406, 0.22647, 0.0524, 0.10092, 0.18537, 0.05552),
tolerance = 1e-3
)
expect_equal(
params$CI_high,
c(
1.12224,
-0.6259,
-1.36691,
0.45151,
1.94204,
0.11227,
-0.07858
),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-parameters_selection.R 0000644 0001762 0000144 00000000250 14355245205 022731 0 ustar ligges users test_that("select_parameters", {
model <- lm(mpg ~ ., data = mtcars)
x <- select_parameters(model)
expect_equal(n_parameters(model) - n_parameters(x), 7)
})
parameters/tests/testthat/test-base.R 0000644 0001762 0000144 00000001630 14716604201 017432 0 ustar ligges users test_that("model_parameters.data.frame", {
data(iris)
expect_warning(expect_null(model_parameters(iris)))
})
test_that("model_parameters.data.frame as draws", {
data(iris)
mp <- suppressWarnings(model_parameters(iris[1:4], as_draws = TRUE))
expect_equal(mp$Median, c(5.8, 3, 4.35, 1.3), tolerance = 1e-2, ignore_attr = TRUE)
expect_identical(mp$Parameter, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width"))
expect_identical(colnames(mp), c("Parameter", "Median", "CI_low", "CI_high", "pd"))
})
test_that("model_parameters.data.frame as draws, exponentiate", {
data(iris)
mp <- suppressWarnings(model_parameters(iris[1:4], as_draws = TRUE, exponentiate = TRUE))
expect_equal(mp$Median, c(330.29956, 20.08554, 77.47846, 3.6693), tolerance = 1e-2, ignore_attr = TRUE)
})
# require model input
test_that("model_parameters", {
expect_error(model_parameters())
})
parameters/tests/testthat/test-pool_parameters.R 0000644 0001762 0000144 00000012465 14726272305 021733 0 ustar ligges users test_that("pooled parameters", {
skip_if_not_installed("mice")
data("nhanes2", package = "mice")
set.seed(123)
imp <- mice::mice(nhanes2, printFlag = FALSE)
models <- lapply(1:5, function(i) {
lm(bmi ~ age + hyp + chl, data = mice::complete(imp, action = i))
})
pp <- pool_parameters(models)
expect_equal(pp$df_error, c(9.2225, 8.1903, 3.6727, 10.264, 6.4385), tolerance = 1e-3)
expect_snapshot(print(pp))
})
test_that("pooled parameters", {
skip_if_not_installed("mice")
skip_if_not_installed("datawizard")
data("nhanes2", package = "mice")
nhanes2$hyp <- datawizard::slide(as.numeric(nhanes2$hyp))
set.seed(123)
imp <- mice::mice(nhanes2, printFlag = FALSE)
models <- lapply(1:5, function(i) {
glm(hyp ~ age + chl, family = binomial, data = mice::complete(imp, action = i))
})
pp1 <- pool_parameters(models)
expect_equal(pp1$df_error, c(Inf, Inf, Inf, Inf), tolerance = 1e-3)
pp2 <- pool_parameters(models, ci_method = "residual")
m_mice <- with(data = imp, exp = glm(hyp ~ age + chl, family = binomial))
pp3 <- summary(mice::pool(m_mice))
expect_equal(pp2$df_error, pp3$df, tolerance = 1e-3)
})
skip_on_cran()
test_that("pooled parameters, glmmTMB, components", {
skip_if_not_installed("mice")
skip_if_not_installed("glmmTMB")
sim1 <- function(nfac = 4, nt = 10, facsd = 0.1, tsd = 0.15, mu = 0, residsd = 1) {
dat <- expand.grid(fac = factor(letters[1:nfac]), t = 1:nt)
n <- nrow(dat)
dat$REfac <- rnorm(nfac, sd = facsd)[dat$fac]
dat$REt <- rnorm(nt, sd = tsd)[dat$t]
dat$x <- rnorm(n, mean = mu, sd = residsd) + dat$REfac + dat$REt
dat
}
set.seed(101)
d1 <- sim1(mu = 100, residsd = 10)
d2 <- sim1(mu = 200, residsd = 5)
d1$sd <- "ten"
d2$sd <- "five"
dat <- rbind(d1, d2)
set.seed(101)
dat$REfac[sample.int(nrow(dat), 10)] <- NA
dat$x[sample.int(nrow(dat), 10)] <- NA
dat$sd[sample.int(nrow(dat), 10)] <- NA
impdat <- suppressWarnings(mice::mice(dat, printFlag = FALSE))
models <- lapply(1:5, function(i) {
glmmTMB::glmmTMB(
x ~ sd + (1 | t),
dispformula = ~sd,
data = mice::complete(impdat, action = i)
)
})
out <- pool_parameters(models, component = "conditional")
expect_named(
out,
c(
"Parameter", "Coefficient", "SE", "CI_low", "CI_high", "Statistic",
"df_error", "p"
)
)
expect_equal(out$Coefficient, c(187.280225, -87.838969), tolerance = 1e-3)
out <- suppressMessages(pool_parameters(models, component = "all", effects = "all"))
expect_named(
out,
c(
"Parameter", "Coefficient", "Effects", "SE", "CI_low", "CI_high",
"Statistic", "df_error", "p", "Component"
)
)
expect_equal(
out$Coefficient,
c(187.280225, -87.838969, 3.51576, -1.032665, 0.610992, NaN),
tolerance = 1e-3
)
out <- pool_parameters(models, component = "all", effects = "fixed")
expect_named(
out,
c(
"Parameter", "Coefficient", "SE", "CI_low", "CI_high",
"Statistic", "df_error", "p", "Component"
)
)
expect_equal(
out$Coefficient,
c(187.280225, -87.838969, 3.51576, -1.032665),
tolerance = 1e-3
)
})
test_that("pooled parameters, glmmTMB, zero-inflated", {
skip_if_not_installed("mice")
skip_if_not_installed("glmmTMB")
skip_if_not_installed("broom.mixed")
data(Salamanders, package = "glmmTMB")
set.seed(123)
Salamanders$cover[sample.int(nrow(Salamanders), 50)] <- NA
Salamanders$mined[sample.int(nrow(Salamanders), 10)] <- NA
impdat <- suppressWarnings(mice::mice(Salamanders, printFlag = FALSE))
models <- lapply(1:5, function(i) {
glmmTMB::glmmTMB(
count ~ mined + cover + (1 | site),
ziformula = ~mined,
family = poisson(),
data = mice::complete(impdat, action = i)
)
})
out <- pool_parameters(models, ci_method = "residual")
expect_named(
out,
c(
"Parameter", "Coefficient", "SE", "CI_low", "CI_high", "Statistic",
"df_error", "p", "Component"
)
)
expect_equal(
out$Coefficient,
c(0.13409, 1.198551, -0.181912, 1.253029, -1.844026),
tolerance = 1e-3
)
# validate against mice ---------------
m_mice <- suppressWarnings(with(data = impdat, exp = glmmTMB::glmmTMB(
count ~ mined + cover + (1 | site),
ziformula = ~mined,
family = poisson()
)))
mice_summ <- summary(mice::pool(m_mice, dfcom = Inf))
expect_equal(out$Coefficient, mice_summ$estimate, tolerance = 1e-3)
expect_equal(out$SE, mice_summ$std.error, tolerance = 1e-3)
expect_equal(out$p, mice_summ$p.value, tolerance = 1e-3)
out <- pool_parameters(models, component = "all", effects = "all")
expect_named(
out,
c(
"Parameter", "Coefficient", "Effects", "SE", "CI_low", "CI_high",
"Statistic", "df_error", "p", "Component"
)
)
expect_equal(
out$Coefficient,
c(0.13409, 1.198551, -0.181912, 1.253029, -1.844026, 0.158795),
tolerance = 1e-3
)
out <- pool_parameters(models, component = "conditional", effects = "fixed")
expect_named(
out,
c(
"Parameter", "Coefficient", "SE", "CI_low", "CI_high",
"Statistic", "df_error", "p"
)
)
expect_equal(
out$Coefficient,
c(0.13409, 1.198551, -0.181912),
tolerance = 1e-3
)
})
parameters/tests/testthat/test-p_adjust.R 0000644 0001762 0000144 00000004005 14716604201 020330 0 ustar ligges users skip_on_cran()
test_that("model_parameters, p-adjust", {
model <- lm(mpg ~ wt * cyl + am + log(hp), data = mtcars)
mp <- model_parameters(model)
expect_equal(mp$p, c(0, 0.00304, 0.02765, 0.65851, 0.01068, 0.02312), tolerance = 1e-3)
mp <- model_parameters(model, p_adjust = "BH")
expect_equal(mp$p, c(0, 0.00912, 0.03318, 0.65851, 0.02137, 0.03318), tolerance = 1e-3)
mp <- model_parameters(model, p_adjust = "bonferroni")
expect_equal(mp$p, c(0, 0.01824, 0.16588, 1, 0.06411, 0.13869), tolerance = 1e-3)
})
test_that("model_parameters, p-adjust after keep/drop", {
model <- lm(mpg ~ wt + cyl + gear + hp, data = mtcars)
mp <- model_parameters(model, p_adjust = "bonferroni")
expect_equal(
mp[["p"]],
p.adjust(coef(summary(model))[, 4], "bonferroni"),
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_message(
mp <- model_parameters(model, include_info = TRUE, keep = c("wt", "hp"), p_adjust = "bonferroni"),
"more than 1 element"
)
expect_equal(
mp[["p"]],
p.adjust(coef(summary(model))[c(2, 5), 4], "bonferroni"),
tolerance = 1e-4,
ignore_attr = TRUE
)
expect_message(
mp <- model_parameters(model, include_info = TRUE, keep = c("cyl", "gear"), p_adjust = "bonferroni"),
"more than 1 element"
)
expect_equal(
mp[["p"]],
p.adjust(coef(summary(model))[3:4, 4], "bonferroni"),
tolerance = 1e-4,
ignore_attr = TRUE
)
})
test_that("model_parameters, emmeans, p-adjust", {
skip_if_not_installed("emmeans")
m <- pairs(emmeans::emmeans(aov(Sepal.Width ~ Species, data = iris), ~Species))
mp <- model_parameters(m)
expect_equal(mp$p, as.data.frame(m)$p.value, tolerance = 1e-4)
})
test_that("model_parameters, emmeans, p-adjust", {
skip_if_not_installed("emmeans")
m <- pairs(emmeans::emmeans(aov(Sepal.Width ~ Species, data = iris), ~Species), adjust = "scheffe")
mp <- model_parameters(m, p_adjust = "scheffe")
expect_equal(mp$p, as.data.frame(m)$p.value, tolerance = 1e-4)
})
parameters/tests/testthat/test-polr.R 0000644 0001762 0000144 00000000747 14736731407 017517 0 ustar ligges users skip_if_not_installed("MASS")
skip_on_cran()
test_that("robust-se polr", {
data(housing, package = "MASS")
m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
out <- model_parameters(m)
expect_identical(attributes(out)$coefficient_name, "Log-Odds")
m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing, method = "probit")
out <- model_parameters(m)
expect_identical(attributes(out)$coefficient_name, "Coefficient")
})
parameters/tests/testthat/test-PMCMRplus.R 0000644 0001762 0000144 00000000551 14413515226 020305 0 ustar ligges users test_that("model_parameters.PMCMR", {
skip_if_not_installed("PMCMRplus")
set.seed(123)
mod <- suppressWarnings(PMCMRplus::kwAllPairsConoverTest(count ~ spray, data = InsectSprays))
df <- as.data.frame(model_parameters(mod))
# no need to add strict tests, since `toTidy` is tested in `PMCMRplus` itself
expect_equal(dim(df), c(15L, 8L))
})
parameters/tests/testthat/test-model_parameters.bracl.R 0000644 0001762 0000144 00000002120 14506526355 023132 0 ustar ligges users skip_if_not_installed("brglm2")
skip_if_not_installed("faraway")
skip_if_not(packageVersion("insight") > "0.19.1")
skip_on_cran()
test_that("model_parameters.bracl", {
data("cns", package = "faraway")
cns2 <- reshape(cns,
direction = "long", timevar = "Type",
times = names(cns)[3:5], varying = 3:5, v.names = "Freq"
)[, 3:6]
cns2$Type <- factor(cns2$Type, levels = unique(cns2$Type))
mbracl <- brglm2::bracl(Type ~ Water + Work, data = cns2, weights = Freq)
mpbracl <- model_parameters(mbracl)
expect_named(
mpbracl,
c(
"Parameter", "Coefficient", "SE", "CI", "CI_low", "CI_high",
"z", "df_error", "p", "Response"
)
)
expect_identical(
mpbracl$Parameter,
c(
"An:(Intercept)", "Sp:(Intercept)", "An:Water", "Sp:Water",
"An:WorkNonManual", "Sp:WorkNonManual"
)
)
expect_identical(
mpbracl$Response,
c("An", "Sp", "An", "Sp", "An", "Sp")
)
expect_equal(
mpbracl$Coefficient,
c(-0.37392, 1.49063, 0.00129, -0.00349, -0.11292, 0.36384),
tolerance = 1e-4
)
})
parameters/tests/testthat/test-model_parameters_df.R 0000644 0001762 0000144 00000026651 14736731407 022541 0 ustar ligges users skip_on_cran()
# glm ---------------------------
set.seed(123)
data(mtcars)
model <- glm(vs ~ wt + cyl, data = mtcars, family = "binomial")
test_that("model_parameters.glm", {
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(4.7888, -0.52956, -6.91917), tolerance = 1e-3)
expect_equal(params$p, c(0.01084, 0.17431, 0.03362), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(2.4503, -0.9299, -5.63472), tolerance = 1e-3)
expect_equal(params$p, c(0.01084, 0.17431, 0.03362), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "residual"))
expect_equal(params$df_error, c(29, 29, 29), tolerance = 1e-3)
expect_equal(params$CI_low, c(2.09492, -1.06171, -5.75235), tolerance = 1e-3)
expect_equal(params$p, c(0.0164, 0.18479, 0.04227), tolerance = 1e-3)
})
# PROreg ---------------------------
test_that("model_parameters.BBmm", {
skip_if_not_installed("PROreg", minimum_version = "1.3.0")
set.seed(1234)
# defining the parameters
k <- 100
m <- 10
phi <- 0.5
beta <- c(1.5, -1.1)
sigma <- 0.5
# simulating the covariate and random effects
x <- runif(k, 0, 10)
X <- model.matrix(~x)
z <- as.factor(PROreg::rBI(k, 4, 0.5, 2))
Z <- model.matrix(~ z - 1)
u <- rnorm(5, 0, sigma)
# the linear predictor and simulated response variable
eta <- beta[1] + beta[2] * x + crossprod(t(Z), u)
p <- 1 / (1 + exp(-eta))
y <- PROreg::rBB(k, m, p, phi)
dat <- data.frame(cbind(y, x, z))
dat$z <- as.factor(dat$z)
# apply the model
invisible(capture.output({
model <- PROreg::BBmm(
fixed.formula = y ~ x,
random.formula = ~z,
m = m,
data = dat
)
}))
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(96, 96), tolerance = 1e-3)
expect_equal(params$CI_low, c(0.26366, -1.46628), tolerance = 1e-3)
expect_equal(params$p, c(0.00814, 0), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(0.27313, -1.46119), tolerance = 1e-3)
expect_equal(params$p, c(0.00814, 0), tolerance = 1e-3)
})
test_that("model_parameters.BBreg", {
skip_if_not_installed("PROreg", minimum_version = "1.3.0")
set.seed(18)
# we simulate a covariate, fix the paramters of the beta-binomial
# distribution and simulate a response variable.
# then we apply the model, and try to get the same values.
k <- 1000
m <- 10
x <- rnorm(k, 5, 3)
beta <- c(-10, 2)
p <- 1 / (1 + exp(-1 * (beta[1] + beta[2] * x)))
phi <- 1.2
y <- PROreg::rBB(k, m, p, phi)
# model
model <- PROreg::BBreg(y ~ x, m)
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(997, 997), tolerance = 1e-3)
expect_equal(params$CI_low, c(-11.08184, 1.84727), tolerance = 1e-3)
expect_equal(params$p, c(0, 0), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(-11.08069, 1.84749), tolerance = 1e-3)
expect_equal(params$p, c(0, 0), tolerance = 1e-3)
})
# MASS / nnet ---------------------------
test_that("model_parameters.multinom", {
skip_if_not_installed("MASS")
skip_if_not_installed("nnet")
set.seed(123)
utils::example(topic = birthwt, echo = FALSE, package = "MASS")
# model
model <- nnet::multinom(
formula = low ~ .,
data = bwt,
trace = FALSE
)
params <- suppressWarnings(model_parameters(model, ci_method = "wald"))
expect_equal(params$df_error, c(178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178), tolerance = 1e-3)
expect_equal(params$CI_low, c(
-1.6332, -0.11362, -0.02963, 0.13471, -0.17058,
-0.08325, 0.39528, 0.49086, -0.23614, -1.38245, -0.72163
), tolerance = 1e-3)
expect_equal(params$p, c(
0.50926, 0.33729, 0.02833, 0.02736, 0.11049, 0.07719, 0.00575,
0.00866, 0.14473, 0.36392, 0.69537
), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(
-1.6165, -0.1131, -0.02953, 0.1419, -0.16439, -0.07755, 0.40173,
0.50053, -0.22991, -1.37601, -0.71551
), tolerance = 1e-3)
expect_equal(params$p, c(
0.5084, 0.33599, 0.02706, 0.0261, 0.10872, 0.07548, 0.00518,
0.00794, 0.14296, 0.36269, 0.6949
), tolerance = 1e-3)
})
## TODO: archieved on CRAN - add test back once ivprobit is back on CRAN.
# ivprobit ---------------------------
# test_that("model_parameters.ivprobit", {
# skip_if_not_installed("ivprobit")
# set.seed(123)
# data(eco, package = "ivprobit")
# # model
# model <- ivprobit::ivprobit(
# formula = d2 ~ ltass + roe + div | eqrat + bonus | ltass + roe + div + gap + cfa,
# data = eco
# )
# params <- suppressWarnings(model_parameters(model))
# expect_equal(params$df_error, c(789L, 789L, 789L, 789L, 789L, 789L), tolerance = 1e-3)
# expect_equal(params$CI_low, c(-35.96484, -0.27082, -0.15557, -1e-05, -15.95755, -1e-05), tolerance = 1e-3)
# expect_equal(params$p, c(0.08355, 0.12724, 0.55684, 0.63368, 0.46593, 0.61493), tolerance = 1e-3)
# params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
# expect_equal(params$df_error, c(Inf, Inf, Inf, Inf, Inf, Inf), tolerance = 1e-3)
# expect_equal(params$CI_low, c(-35.93553, -0.26895, -0.15522, -1e-05, -15.91859, -1e-05), tolerance = 1e-3)
# expect_equal(params$p, c(0.08316, 0.12684, 0.55668, 0.63355, 0.46571, 0.61479), tolerance = 1e-3)
# })
# biglm ---------------------------
test_that("model_parameters.bigglm", {
skip_if_not_installed("biglm")
set.seed(123)
data(trees)
# model
model <- biglm::bigglm(
formula = log(Volume) ~ log(Girth) + log(Height),
data = trees,
chunksize = 10,
sandwich = TRUE
)
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(28, 28, 28), tolerance = 1e-3)
expect_equal(params$CI_low, c(-8.12252, 1.86862, 0.72411), tolerance = 1e-3)
expect_equal(params$p, c(0, 0, 0), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(-8.05815, 1.87355, 0.74108), tolerance = 1e-3)
expect_equal(params$p, c(0, 0, 0), tolerance = 1e-3)
})
# ivreg ---------------------------
test_that("model_parameters.ivreg", {
skip_if_not_installed("ivreg")
data(CigaretteDemand, package = "ivreg")
model <- ivreg::ivreg(log(packs) ~ log(rprice) + log(rincome) | salestax + log(rincome),
data = CigaretteDemand
)
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(45L, 45L, 45L), tolerance = 1e-3)
expect_equal(params$CI_low, c(6.69477, -1.86742, -0.32644), tolerance = 1e-3)
expect_equal(params$p, c(0, 0.00266, 0.42867), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(6.76831, -1.84795, -0.3119), tolerance = 1e-3)
expect_equal(params$p, c(0, 0.00147, 0.42447), tolerance = 1e-3)
})
# plm ---------------------------
test_that("model_parameters.plm", {
skip_if_not_installed("plm")
data("Produc", package = "plm")
set.seed(123)
model <- suppressWarnings(plm::plm(
formula = log(gsp) ~ log(pcap) + log(pc) + log(emp) + unemp,
data = Produc,
index = c("state", "year")
))
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(764L, 764L, 764L, 764L), tolerance = 1e-3)
expect_equal(params$CI_low, c(-0.08308, 0.2427, 0.70909, -0.00724), tolerance = 1e-3)
expect_equal(params$p, c(0.36752, 0, 0, 0), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(-0.08299, 0.24277, 0.70918, -0.00724), tolerance = 1e-3)
expect_equal(params$p, c(0.36724, 0, 0, 0), tolerance = 1e-3)
})
# nlme ---------------------------
test_that("model_parameters.gls", {
skip_if_not_installed("nlme")
data(Ovary, package = "nlme")
model <- nlme::gls(
follicles ~ sin(2 * pi * Time) + cos(2 * pi * Time),
data = Ovary,
correlation = nlme::corAR1(form = ~ 1 | Mare)
)
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(305L, 305L, 305L), tolerance = 1e-3)
expect_equal(params$CI_low, c(10.90853, -4.04402, -2.2722), tolerance = 1e-3)
expect_equal(params$p, c(0, 2e-05, 0.19814), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(10.91372, -4.03898, -2.26675), tolerance = 1e-3)
expect_equal(params$p, c(0, 2e-05, 0.19716), tolerance = 1e-3)
})
# # complmrob ---------------------------
#
# test_that("model_parameters.complmrob", {
# skip_if_not_installed("complmrob")
# crimes <- data.frame(
# lifeExp = state.x77[, "Life Exp"],
# USArrests[, c("Murder", "Assault", "Rape")]
# )
#
# # model
# model <- complmrob::complmrob(formula = lifeExp ~ ., data = crimes)
# params <- suppressWarnings(model_parameters(model))
# expect_equal(params$df_error, c(46L, 46L, 46L, 46L), tolerance = 1e-3)
# expect_equal(params$CI_low, c(69.79492, -3.09088, -2.91019, 2.05479), tolerance = 1e-3)
# expect_equal(params$p, c(0, 0, 0.26437, 0), tolerance = 1e-3)
#
# params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
# expect_equal(params$df_error, c(Inf, Inf, Inf, Inf), tolerance = 1e-3)
# expect_equal(params$CI_low, c(69.81747, -3.06832, -2.86118, 2.087), tolerance = 1e-3)
# expect_equal(params$p, c(0, 0, 0.25851, 0), tolerance = 1e-3)
# })
# drc ---------------------------
test_that("model_parameters.drc", {
skip_if_not_installed("drc")
set.seed(123)
data("selenium", package = "drc")
model <- drc::drm(
formula = dead / total ~ conc,
curveid = type,
weights = total,
data = selenium,
fct = drc::LL.2(),
type = "binomial"
)
params <- suppressWarnings(model_parameters(model))
expect_equal(params$df_error, c(17L, 17L, 17L, 17L, 17L, 17L, 17L, 17L), tolerance = 1e-3)
expect_equal(params$CI_low, c(
-1.83156, -1.13673, -2.4552, -1.80875, 223.0835, 295.39556,
107.25398, 70.62683
), tolerance = 1e-3)
expect_equal(params$p, c(0, 1e-05, 0, 0, 0, 0, 0, 0), tolerance = 1e-3)
params <- suppressWarnings(model_parameters(model, ci_method = "normal"))
expect_equal(params$df_error, c(Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf), tolerance = 1e-3)
expect_equal(params$CI_low, c(
-1.80826, -1.11588, -2.43449, -1.78349, 225.15547, 301.29532,
108.13891, 71.91797
), tolerance = 1e-3)
expect_equal(params$p, c(0, 0, 0, 0, 0, 0, 0, 0), tolerance = 1e-3)
})
parameters/tests/testthat/test-model_parameters.anova.R 0000644 0001762 0000144 00000022642 14736731407 023167 0 ustar ligges users skip_on_cran()
m <- glm(am ~ mpg + hp + factor(cyl),
data = mtcars, family = binomial()
)
test_that("model_parameters.anova", {
a <- anova(m, test = "Chisq")
mp <- model_parameters(a)
expect_named(mp, c("Parameter", "df", "Deviance", "df_error", "Deviance_error", "p"))
expect_equal(mp$Deviance_error, c(43.22973, 29.67517, 19.23255, 10.48692), tolerance = 1e-3)
expect_equal(mp$p, c(NA, 0.00023, 0.00123, 0.01262), tolerance = 1e-3)
expect_snapshot(mp)
})
test_that("model_parameters.anova", {
skip_if_not_installed("car")
a <- car::Anova(m, type = 3, test.statistic = "F")
mp <- model_parameters(a)
expect_named(mp, c("Parameter", "Sum_Squares", "df", "Mean_Square", "F", "p"))
expect_equal(mp[["F"]], c(53.40138, 60.42944, 13.96887, NA), tolerance = 1e-3)
})
test_that("model_parameters.anova for mixed models", {
skip_if_not_installed("lme4")
skip_if_not_installed("lmerTest")
m <- lmerTest::lmer(mpg ~ wt + (1 | gear), data = mtcars)
out <- parameters::model_parameters(anova(m))
expect_named(out, c("Parameter", "Sum_Squares", "df", "df_error", "Mean_Square", "F", "p"))
expect_equal(out$df_error, 21.92272, tolerance = 1e-4)
})
test_that("linear hypothesis tests", {
skip_if_not_installed("car")
skip_if_not_installed("carData")
data(Davis, package = "carData")
data(Duncan, package = "carData")
mod.davis <- lm(weight ~ repwt, data = Davis)
## the following are equivalent:
p1 <- parameters(car::linearHypothesis(mod.davis, diag(2), c(0, 1)))
p2 <- parameters(car::linearHypothesis(mod.davis, c("(Intercept) = 0", "repwt = 1")))
p3 <- parameters(car::linearHypothesis(mod.davis, c("(Intercept)", "repwt"), c(0, 1)))
p4 <- parameters(car::linearHypothesis(mod.davis, c("(Intercept)", "repwt = 1")))
expect_equal(p1, p2, ignore_attr = TRUE)
expect_equal(p1, p3, ignore_attr = TRUE)
expect_equal(p1, p4, ignore_attr = TRUE)
expect_identical(nrow(p1), 2L)
## FIXME: this has changed since {car} 3.1.3
# expect_identical(p1$Parameter, c("(Intercept) = 0", "repwt = 1"))
expect_identical(p1$Parameter, c("1", "2"))
mod.duncan <- lm(prestige ~ income + education, data = Duncan)
p <- parameters(car::linearHypothesis(mod.duncan, "1*income - 1*education + 1 = 1"))
expect_identical(nrow(p), 2L)
## FIXME: this has changed since {car} 3.1.3
# expect_identical(p$Parameter, "income - education = 0")
expect_identical(p1$Parameter, c("1", "2"))
})
test_that("print-model_parameters", {
skip_if_not_installed("car")
a <- car::Anova(m, type = 3, test.statistic = "F")
mp <- model_parameters(a)
expect_snapshot(mp)
})
test_that("model_parameters_Anova.mlm", {
skip_if_not_installed("car")
m <- lm(cbind(hp, mpg) ~ factor(cyl) * am, data = mtcars)
a <- car::Anova(m, type = 3, test.statistic = "Pillai")
mp <- model_parameters(a, verbose = FALSE)
expect_named(mp, c("Parameter", "df", "Statistic", "df_num", "df_error", "F", "p"))
expect_equal(mp[["F"]], c(158.2578, 6.60593, 3.71327, 3.28975), tolerance = 1e-3)
expect_equal(mp$Statistic, c(0.9268, 0.67387, 0.22903, 0.4039), tolerance = 1e-3)
})
test_that("model_parameters_Anova.mlm", {
skip_if_not_installed("MASS")
skip_if_not_installed("car")
data(housing, package = "MASS")
m <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
a <- car::Anova(m)
mp <- model_parameters(a)
expect_named(mp, c("Parameter", "Chi2", "df", "p"))
expect_equal(mp$Chi2, c(108.2392, 55.91008, 14.30621), tolerance = 1e-3)
})
test_that("model_parameters_Anova-effectsize", {
skip_if_not_installed("lme4")
skip_if_not_installed("effectsize", minimum_version = "0.4.3")
df <- iris
df$Sepal.Big <- ifelse(df$Sepal.Width >= 3, "Yes", "No")
mm <- suppressMessages(lme4::lmer(Sepal.Length ~ Sepal.Big + Petal.Width + (1 | Species), data = df))
model <- anova(mm)
# parameters table including effect sizes
mp <- model_parameters(
model,
es_type = "eta",
ci = 0.9,
df_error = dof_satterthwaite(mm)[2:3]
)
expect_identical(
colnames(mp),
c(
"Parameter", "Sum_Squares", "df", "Mean_Square", "F", "Eta2_partial",
"Eta2_CI_low", "Eta2_CI_high"
)
)
expect_equal(mp$Eta2_partial, c(0.03262, 0.6778), tolerance = 1e-3)
})
# XXX -----
test_that("anova type | lm", {
skip_if_not_installed("car")
m <- lm(mpg ~ factor(cyl) * hp + disp, mtcars)
a1 <- aov(m)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a1 <- anova(m)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a2 <- car::Anova(m, type = 2)
a3 <- car::Anova(m, type = 3)
expect_identical(attr(model_parameters(a2), "anova_type"), 2)
expect_message(
expect_identical(attr(model_parameters(a3), "anova_type"), 3),
"Type 3 ANOVAs only give"
)
m <- lm(mpg ~ factor(cyl) + hp + disp, mtcars)
expect_warning(model_parameters(aov(m)), regexp = NA) # no need for warning, because no interactions
m <- lm(mpg ~ factor(cyl) * scale(disp, TRUE, FALSE) + scale(disp, TRUE, FALSE),
mtcars,
contrasts = list("factor(cyl)" = contr.helmert)
)
a3 <- car::Anova(m, type = 3)
expect_message(
model_parameters(a3),
"Type 3 ANOVAs only give"
)
})
test_that("anova type | mlm", {
skip_if_not_installed("car")
m <- lm(cbind(mpg, drat) ~ factor(cyl) * hp + disp, mtcars)
a1 <- aov(m)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a1 <- anova(m)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a2 <- car::Anova(m, type = 2)
a3 <- car::Anova(m, type = 3)
expect_identical(attr(model_parameters(a2), "anova_type"), 2)
expect_identical(attr(model_parameters(a3, verbose = FALSE), "anova_type"), 3)
})
test_that("anova type | glm", {
skip_if_not_installed("car")
m <- suppressWarnings(glm(am ~ factor(cyl) * hp + disp, mtcars, family = binomial()))
a1 <- anova(m)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a2 <- suppressWarnings(car::Anova(m, type = 2))
a3 <- suppressWarnings(car::Anova(m, type = 3))
expect_identical(attr(model_parameters(a2), "anova_type"), 2)
expect_message(
expect_identical(attr(model_parameters(a3), "anova_type"), 3),
"Type 3 ANOVAs only give"
)
})
test_that("anova type | lme4", {
skip_if_not_installed("lmerTest")
skip_if_not_installed("lme4")
skip_if_not_installed("car")
m1 <- lme4::lmer(mpg ~ factor(cyl) * hp + disp + (1 | gear), mtcars)
suppressMessages({
m2 <- lme4::glmer(carb ~ factor(cyl) * hp + disp + (1 | gear), mtcars,
family = poisson()
)
})
a1 <- anova(m1)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a1 <- anova(m2)
expect_identical(attr(model_parameters(a1), "anova_type"), 1)
a3 <- anova(lmerTest::as_lmerModLmerTest(m1))
expect_message(
expect_identical(attr(model_parameters(a3), "anova_type"), 3),
"Type 3 ANOVAs only give"
)
a2 <- car::Anova(m1, type = 2)
a3 <- car::Anova(m1, type = 3)
expect_identical(attr(model_parameters(a2), "anova_type"), 2)
expect_message(
expect_identical(attr(model_parameters(a3), "anova_type"), 3),
"Type 3 ANOVAs only give"
)
a2 <- car::Anova(m2, type = 2)
a3 <- car::Anova(m2, type = 3)
expect_identical(attr(model_parameters(a2), "anova_type"), 2)
expect_message(
expect_identical(attr(model_parameters(a3), "anova_type"), 3),
"Type 3 ANOVAs only give"
)
})
test_that("anova type | afex + Anova.mlm", {
skip_if_not_installed("afex")
data(obk.long, package = "afex")
suppressMessages({
m <- afex::aov_ez("id", "value", obk.long,
between = c("treatment", "gender"),
within = c("phase", "hour"), observed = "gender"
)
})
expect_identical(attr(model_parameters(m), "anova_type"), 3)
expect_identical(attr(model_parameters(m$Anova, verbose = FALSE), "anova_type"), 3)
})
test_that("anova rms", {
skip_if_not_installed("rms")
m <- rms::ols(mpg ~ cyl + disp + hp + drat, data = mtcars)
a <- anova(m)
mp <- model_parameters(a)
expect_identical(attr(mp, "anova_type"), 2)
expect_identical(mp$Parameter, c("cyl", "disp", "hp", "drat", "Total", "Residuals"))
expect_identical(colnames(mp), c("Parameter", "Sum_Squares_Partial", "df", "Mean_Square", "F", "p"))
expect_equal(mp$Sum_Squares_Partial, data.frame(a)$Partial.SS, tolerance = 1e-3)
})
test_that("anova rms", {
skip_if_not_installed("rms")
skip_if(getRversion() < "4.2.0")
m <- rms::orm(mpg ~ cyl + disp + hp + drat, data = mtcars)
a <- anova(m)
mp <- model_parameters(a)
expect_identical(attr(mp, "anova_type"), 2)
expect_identical(mp$Parameter, c("cyl", "disp", "hp", "drat", "Total"))
expect_named(mp, c("Parameter", "Chi2", "df", "p"))
expect_equal(mp$Chi2, data.frame(a)$Chi.Square, tolerance = 1e-3)
})
skip_if_not_installed("withr")
skip_if_not_installed("survey")
withr::with_package(
"survey",
test_that("anova survey", {
data(api, package = "survey")
dclus2 <<- survey::svydesign(id = ~ dnum + snum, weights = ~pw, data = apiclus2)
model0 <- survey::svyglm(
I(sch.wide == "Yes") ~ ell * meals,
design = dclus2,
family = quasibinomial()
)
out <- anova(model0)
expect_snapshot(print(model_parameters(out)))
out <- anova(model0, method = "Wald")
expect_snapshot(print(model_parameters(out)))
})
)
parameters/tests/testthat/test-model_parameters.logitr.R 0000644 0001762 0000144 00000001022 14736731407 023350 0 ustar ligges users skip_on_cran()
skip_if_not_installed("logitr")
test_that("model_parameters.logitr", {
data(yogurt, package = "logitr")
m <- logitr::logitr(
data = yogurt,
outcome = "choice",
obsID = "obsID",
pars = c("feat", "brand"),
scalePar = "price",
numMultiStarts = 5
)
params <- model_parameters(m, verbose = FALSE)
expect_snapshot(params, variant = "windows")
params <- model_parameters(m, verbose = FALSE, ci_method = "residual")
expect_snapshot(params, variant = "windows")
})
parameters/tests/testthat/test-model_parameters.fixest.R 0000644 0001762 0000144 00000013365 14736731407 023367 0 ustar ligges users test_that("model_parameters.fixest", {
skip_on_cran()
skip_if_not_installed("fixest")
skip_if_not_installed("carData")
# avoid warnings
fixest::setFixest_nthreads(1)
data("qol_cancer")
data(trade, package = "fixest")
data(Greene, package = "carData")
data(iris)
d <- Greene
d$dv <- as.numeric(Greene$decision == "yes")
qol_cancer <- cbind(
qol_cancer,
datawizard::demean(qol_cancer, select = c("phq4", "QoL"), by = "ID")
)
m1 <- fixest::feols(QoL ~ time + phq4 | ID, data = qol_cancer)
m2 <- fixest::femlm(Euros ~ log(dist_km) | Origin + Destination + Product, data = trade)
m3 <- fixest::femlm(log1p(Euros) ~ log(dist_km) | Origin + Destination + Product, data = trade, family = "gaussian")
m4 <- fixest::feglm(Euros ~ log(dist_km) | Origin + Destination + Product, data = trade, family = "poisson")
m5 <- fixest::feols(Sepal.Width ~ Petal.Length | Species | Sepal.Length ~ Petal.Width, data = iris)
m6 <- fixest::feglm(dv ~ language | judge, data = d, cluster = "judge", family = "logit")
params <- model_parameters(m1, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(2L, 9L))
expect_equal(params$p, as.vector(fixest::pvalue(m1)), tolerance = 1e-4)
expect_equal(params$df_error[1], as.vector(fixest::degrees_freedom(m1, type = "t")), tolerance = 1e-4)
expect_equal(params$Coefficient, as.vector(coef(m1)), tolerance = 1e-4)
# currently, a bug for fixest 10.4 on R >= 4.3
# skip_if_not(getRversion() < "4.2.0")
expect_snapshot(
model_parameters(m1, include_info = TRUE, verbose = FALSE)
)
# Poission, df = Inf
params <- model_parameters(m2, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(1L, 9L))
expect_equal(params$p, as.vector(fixest::pvalue(m2)), tolerance = 1e-4)
expect_identical(params$df_error[1], Inf)
expect_equal(params$Coefficient, as.vector(coef(m2)), tolerance = 1e-4)
params <- model_parameters(m3, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(1L, 9L))
expect_equal(params$p, as.vector(fixest::pvalue(m3)), tolerance = 1e-4)
expect_equal(params$df_error[1], as.vector(fixest::degrees_freedom(m3, type = "t")), tolerance = 1e-4)
expect_equal(params$Coefficient, as.vector(coef(m3)), tolerance = 1e-4)
# Poission, df = Inf
params <- model_parameters(m4, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(1L, 9L))
expect_equal(params$p, as.vector(fixest::pvalue(m4)), tolerance = 1e-4)
expect_identical(params$df_error[1], Inf)
expect_equal(params$Coefficient, as.vector(coef(m4)), tolerance = 1e-4)
params <- model_parameters(m5, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(2L, 9L))
expect_equal(params$p, as.vector(fixest::pvalue(m5)), tolerance = 1e-4)
expect_equal(params$df_error[1], as.vector(fixest::degrees_freedom(m5, type = "t")), tolerance = 1e-4)
expect_equal(params$Coefficient, as.vector(coef(m5)), tolerance = 1e-4)
# logit, df = Inf
params <- model_parameters(m6, verbose = FALSE)
expect_identical(c(nrow(params), ncol(params)), c(1L, 9L))
expect_equal(params$p, as.vector(fixest::pvalue(m6)), tolerance = 1e-4)
expect_identical(params$df_error[1], Inf)
expect_equal(params$Coefficient, as.vector(coef(m6)), tolerance = 1e-4)
})
test_that("model_parameters.fixest", {
skip_on_cran()
skip_if_not_installed("fixest")
skip_if_not_installed("carData")
data(Greene, package = "carData")
d <- Greene
d$dv <- as.numeric(Greene$decision == "yes")
mod1 <- fixest::feglm(dv ~ language | judge,
data = d,
cluster = "judge", family = "logit"
)
out1 <- model_parameters(mod1)
expect_equal(out1$p, as.vector(fixest::pvalue(mod1)), tolerance = 1e-4, ignore_attr = TRUE)
expect_equal(out1$SE, as.vector(sqrt(diag(vcov(mod1)))), tolerance = 1e-4, ignore_attr = TRUE)
})
test_that("robust standard errors", {
skip_if_not_installed("fixest")
mod <- fixest::feols(mpg ~ hp + am | cyl, data = mtcars)
se1 <- sqrt(diag(vcov(mod)))
se2 <- sqrt(diag(vcov(mod, vcov = "HC1")))
se3 <- sqrt(diag(vcov(mod, vcov = ~gear)))
expect_equal(standard_error(mod)$SE, se1, ignore_attr = TRUE)
expect_equal(standard_error(mod, vcov = "HC1")$SE, se2, ignore_attr = TRUE)
expect_equal(standard_error(mod, vcov = ~gear)$SE, se3, ignore_attr = TRUE)
p1 <- p_value(mod)
p2 <- p_value(mod, vcov = "HC1")
p3 <- p_value(mod, vcov = ~gear)
expect_true(all(p1$p != p2$p))
expect_true(all(p2$p != p3$p))
expect_true(all(p1$p != p3$p))
expect_error(standard_error(mod, vcov = "HC3"))
expect_error(parameters(mod, vcov = "HC3"))
expect_error(parameters(mod, vcov = "hetero"), NA)
expect_error(parameters(mod, vcov = "iid"), NA)
})
test_that("standard errors, Sun and Abraham", {
skip_if_not_installed("did")
data(mpdta, package = "did")
m <- fixest::feols(
lemp ~ sunab(first.treat, year, ref.p = -1:-4, att = TRUE) | countyreal + year,
data = mpdta,
cluster = ~countyreal
)
out <- model_parameters(m)
expect_equal(out$SE, m$coeftable[, "Std. Error"], tolerance = 1e-4, ignore_attr = TRUE)
data(base_stagg, package = "fixest")
m <- fixest::feols(y ~ x1 + sunab(year_treated, year) | id + year, base_stagg)
out <- model_parameters(m)
expect_equal(out$SE, m$coeftable[, "Std. Error"], tolerance = 1e-4, ignore_attr = TRUE)
})
skip_if_not_installed("withr")
skip_if_not_installed("glmmTMB")
withr::with_options(
list(parameters_warning_exponentiate = TRUE),
test_that("model_parameters works for fixest-negbin", {
data(Salamanders, package = "glmmTMB")
mod <- fixest::fenegbin(count ~ mined + spp, data = Salamanders)
out <- model_parameters(mod)
expect_snapshot(print(out))
})
)
parameters/tests/testthat/test-model_parameters.htest.R 0000644 0001762 0000144 00000011163 14716604201 023173 0 ustar ligges users skip_if_not_installed("effectsize")
## TODO: add more tests for different htest objects and effectsize types
test_that("model_parameters.htest", {
params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "pearson"))
expect_named(
params,
c(
"Parameter1", "Parameter2", "r", "CI", "CI_low", "CI_high",
"t", "df_error", "p", "Method", "Alternative"
)
)
expect_equal(params$r, -0.852, tolerance = 0.05)
expect_warning({
params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "spearman"))
})
expect_equal(params$rho, -0.9108, tolerance = 0.05)
expect_warning({
params <- model_parameters(cor.test(mtcars$mpg, mtcars$cyl, method = "kendall"))
})
expect_equal(params$tau, -0.795, tolerance = 0.05)
params <- model_parameters(t.test(iris$Sepal.Width, iris$Sepal.Length))
expect_equal(params$Difference, -2.786, tolerance = 0.05)
params <- model_parameters(t.test(mtcars$mpg ~ mtcars$vs))
expect_equal(params$Difference, -7.940, tolerance = 0.05)
params <- model_parameters(t.test(iris$Sepal.Width, mu = 1))
expect_equal(params$Difference, 2.0573, tolerance = 0.05)
})
test_that("model_parameters.htest-2", {
x <- c(A = 20, B = 15, C = 25)
mp <- model_parameters(chisq.test(x))
expect_named(mp, c("Chi2", "df", "p", "Method"))
})
test_that("model_parameters-chisq-test NULL", {
mp <- model_parameters(stats::chisq.test(table(mtcars$am)))
expect_equal(mp$Chi2, 1.125, tolerance = 1e-3)
expect_named(mp, c("Chi2", "df", "p", "Method"))
})
test_that("model_parameters-chisq-test two way table", {
mp2 <- suppressWarnings(model_parameters(stats::chisq.test(table(mtcars$am, mtcars$cyl))))
expect_equal(mp2$Chi2, 8.740733, tolerance = 1e-3)
expect_named(mp2, c("Chi2", "df", "p", "Method"))
})
test_that("model_parameters-chisq-test works with `svychisq` objects", {
skip_if_not_installed("survey")
data(api, package = "survey")
set.seed(123)
dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)
m <- survey::svychisq(~ sch.wide + stype, dclus1)
mp <- model_parameters(m)
expect_equal(mp$F, 5.19337, tolerance = 1e-3)
expect_named(mp, c("F", "df", "df_error", "p", "Method"))
})
test_that("model_parameters-chisq-test adjusted", {
expect_message({
mp <- model_parameters(stats::chisq.test(table(mtcars$am)), es_type = "phi", ci = 0.95)
})
expect_equal(mp$Chi2, 1.125, tolerance = 1e-3)
expect_named(mp, c("Chi2", "df", "p", "Method"))
})
test_that("model_parameters-t-test standardized d", {
params <- model_parameters(t.test(iris$Sepal.Width, iris$Sepal.Length), es_type = "cohens_d")
expect_equal(params$Cohens_d, -4.210417, tolerance = 0.05)
expect_equal(params$d_CI_low, -4.655306, tolerance = 0.05)
expect_named(
params,
c(
"Parameter1", "Parameter2", "Mean_Parameter1", "Mean_Parameter2",
"Difference", "CI", "CI_low", "CI_high", "Cohens_d", "d_CI_low",
"d_CI_high", "t", "df_error", "p", "Method", "Alternative"
)
)
})
test_that("model_parameters-t-test standardized d", {
mp <- model_parameters(t.test(mtcars$mpg ~ mtcars$vs), es_type = "cohens_d", verbose = FALSE)
expect_equal(mp$Cohens_d, -1.696032, tolerance = 1e-3)
expect_named(
mp,
c(
"Parameter", "Group", "Mean_Group1", "Mean_Group2", "Difference", "CI",
"CI_low", "CI_high", "Cohens_d", "d_CI_low", "d_CI_high", "t", "df_error",
"p", "Method", "Alternative"
)
)
})
test_that("model_parameters-t-test reports the same unregarding of interface", {
g1 <- 1:10
g2 <- 7:20
df <- data.frame(y = c(g1, g2), x = rep(c(0, 1), c(length(g1), length(g2))))
compare_only <- c("Difference", "CI", "CI_low", "CI_high", "t", "df_error", "p", "Method")
default_ttest <- model_parameters(t.test(x = g1, y = g2))[compare_only]
formula_ttest <- model_parameters(t.test(y ~ x, df))[compare_only]
expect_equal(default_ttest, formula_ttest, ignore_attr = TRUE)
})
test_that("model_parameters-Box.test works, and ignores partial matching", {
set.seed(123)
ts1 <- ts(rnorm(200, mean = 10, sd = 3))
result1 <- Box.test(ts1, lag = 5, type = "Box-Pierce", fitdf = 2)
result2 <- Box.test(ts1, lag = 5, type = "Ljung-Box", fitdf = 2)
out1 <- model_parameters(result1)
out2 <- model_parameters(result1, effects = "all")
expect_equal(out1, out2, ignore_attr = TRUE)
expect_named(out1, c("Parameter", "Chi2", "df_error", "p", "Method"))
out1 <- model_parameters(result2)
out2 <- model_parameters(result2, effects = "all")
expect_equal(out1, out2, ignore_attr = TRUE)
})
parameters/tests/testthat.R 0000644 0001762 0000144 00000000104 14413515226 015540 0 ustar ligges users library(parameters)
library(testthat)
test_check("parameters")
parameters/MD5 0000644 0001762 0000144 00000074076 14761611437 012755 0 ustar ligges users aec1f89ac883c9b0f97ae4c01e2ae220 *DESCRIPTION
dace07304d592f6fb2aaa209b01ca4a2 *NAMESPACE
41d2b85e7f50cd52d1139e2b2985cfbb *NEWS.md
9bb09925e925a3186473945f59d1869a *R/1_model_parameters.R
d2fd4b8b006cd6cb3119986e7ca96f81 *R/2_ci.R
bb2f31f54a6f37c8df02a8cb4a1b1fd1 *R/3_p_value.R
2643e5bebc430f417aabd5ee8380f1af *R/4_standard_error.R
46b51118f9d818971c76f996c64b8676 *R/5_simulate_model.R
cf8687d6ff8772e19ff77f55c06b6303 *R/bootstrap_model-emmeans.R
734b0abb482e8d92d4a69c22838caee1 *R/bootstrap_model.R
3f500df6db7bde59fbadabac96aa5f64 *R/bootstrap_parameters.R
42943322a8ab50aca3b38ae13a55ed11 *R/ci_betwithin.R
b25f57e767e74646282b76020e3c6d17 *R/ci_generic.R
4073432596f7a33aa29fe5cc62dcb577 *R/ci_kenward.R
3e7ef8844be9768179f886c716547cc3 *R/ci_ml1.R
2f80f24c32164b23ef07c5ee0d0e6b6d *R/ci_profile_boot.R
bdd70653021a2f5b6823aaa1792c39b5 *R/ci_satterthwaite.R
bde5fa7f03d6235d824a72bcacc56663 *R/cluster_analysis.R
936fd6bd303e279a265753b6050cf302 *R/cluster_centers.R
2753e7a0cc667c3bc5900cfeff0656d3 *R/cluster_discrimination.R
f922c3bd0206021178e8898b65440b67 *R/cluster_meta.R
d8ef7424144ff1424d763f676eb81760 *R/cluster_performance.R
55fda0a17467a8359f4c7b8f2a7e8b48 *R/compare_parameters.R
86306ff324f39c73d6b0525e6f1148f5 *R/convert_efa_to_cfa.R
55f0da00f816533dcd93dc5130a404da *R/datasets.R
b47a9b5c49b261f37c2f59316eb1a786 *R/display.R
5814083236ea3951f62e83968399537b *R/dof.R
f3b9f6f05029f6b12fedcde24e21b38c *R/dof_betwithin.R
ef9b9c999c11434668c64183ffc62b56 *R/dof_kenward.R
b0abf838af917c66f8880a14f61a8a74 *R/dof_ml1.R
c812201314b93ae331bf728c1990cb66 *R/dof_satterthwaite.R
5c30b2624359197847e2eeeaf0584140 *R/dominance_analysis.R
c3dee8f16b3d23ef19a4a6476e19cadb *R/equivalence_test.R
eec2ff3851d6ab95c5342f66450b80cd *R/extract_parameters.R
f2145ffaf9b53997a5477682c027be74 *R/extract_parameters_anova.R
4bbf6ca23b6939427fee1bacd33fecd8 *R/extract_random_parameters.R
7f7417bf192545eadfd2cc0c4f2e5361 *R/extract_random_variances.R
d103c271fc55e8288ffd9c56da1b9f66 *R/factor_analysis.R
6b8c89599b2f226b48350211b999c70d *R/format.R
be3ff96821e907efc62fd81837e16439 *R/format_df_adjust.R
c18e18191213f065feded7446ee177f4 *R/format_order.R
965d8b1e2b62588cc46dd23dc0102629 *R/format_p_adjust.R
487e314ab03b19a190c24992783403b9 *R/format_parameters.R
7a5b24deb7abcd560fff15ff1aecc0c9 *R/group_level_total.R
4eecf1ad1f11817a893222a8022cbefe *R/methods_AER.R
79b7e90bd54c447d3d2cb81c8328cc88 *R/methods_BBMM.R
84b6d0d1c5e3f69ba7c128fa13d98c5a *R/methods_BayesFM.R
03a5b5064c9f4ef3c0a4e81ef586afcc *R/methods_BayesFactor.R
f46fb8bfaac926285cc320ab1c7d01c6 *R/methods_BayesX.R
6d0ce7b953dc464061c26b3ef39aa172 *R/methods_DirichletReg.R
bc598b46f444d379c1156811c8847519 *R/methods_FactoMineR.R
d503b934a55c6c8a82083ec918d452ef *R/methods_MCMCglmm.R
38a86ed04315e7e728178aeca000556b *R/methods_PMCMRplus.R
07a7e856db7bb581c38fdec32712c683 *R/methods_aod.R
5292787af74216eefcda3fdcaee0e6d8 *R/methods_aov.R
7e4fa74e4fd1da5bad6c3f8a891ba1fe *R/methods_averaging.R
7865d12cb9d83b6f77f2891925c9024b *R/methods_bamlss.R
b217531634123e21b45b248af2c24197 *R/methods_base.R
2b725b1ffaf9fecee20568f22500d22c *R/methods_bayesQR.R
079ada60c0566403a1903c42790d79d5 *R/methods_bayestestR.R
869569b19699269be9c2342656b33fae *R/methods_bbmle.R
be1c3f7d3171d1f92f6ddc3767c86ec1 *R/methods_betareg.R
326dd60cf3bd3be3e15f57775834b19d *R/methods_bfsl.R
de1cccfd5b748ec0a487eb689f7ab661 *R/methods_bggm.R
dd541e83b7cc6ecbed94f57b2f709425 *R/methods_bife.R
1a7e3b0d6bc8b952a3ac2284f5af4689 *R/methods_biglm.R
6ce188ac0346f60c37abc10e7171d10c *R/methods_brglm2.R
0b8a26f6d053747d01686efeb4c7f7a0 *R/methods_brms.R
b63821fb0a35a92665a0d1d97ae973b4 *R/methods_car.R
c81b6e7e6c2097be6e56e44e62ac5c01 *R/methods_censReg.R
bfa5e4ef53f799b1478bac387f65d443 *R/methods_cgam.R
b37757fbeb09ed92449676646828a5dc *R/methods_coda.R
121adf7daf5a027304edf11a8e681206 *R/methods_coxme.R
114ae39e78c7b0d4edbc0d31673fb09a *R/methods_coxrobust.R
e3a32531cf8ba9c5f78f8b3404dd61c0 *R/methods_cplm.R
f97a38c25341b6fcea36385598e8d793 *R/methods_crch.R
ec1c8164533bd06b7e105fbd2b1bc226 *R/methods_dbscan.R
dee30efadd593dbfbbeac54cd478a95b *R/methods_effect_size.R
7ff045ef7750c54be0b047c7e39488e6 *R/methods_eflm.R
d9359b80ed06f598b331f302dc58af83 *R/methods_emmeans.R
4ec7aea36ddadce2699d818bf29daf0a *R/methods_epi2x2.R
bf2f271dd612a02880e6804a93c1382c *R/methods_ergm.R
4c1e815db38ffb6614a89627ba76ff1c *R/methods_estimatr.R
314b27e1991976ff63a249ab4e578fe1 *R/methods_fitdistr.R
49d233204e9cb2d403f9561743e276ff *R/methods_fixest.R
d95cd35ecead1d0159e4c1260975ca5c *R/methods_flexsurvreg.R
39a4facdb3713a74b455004e7fdf0ad4 *R/methods_gam.R
d62a2972b77a847ce40852ed60063f1d *R/methods_gamlss.R
bad02a55f0d720ac67ff5176dee5320c *R/methods_gamm4.R
b010bbaa7ee252ae1abd439e0e628ea6 *R/methods_gee.R
a6a1f42fb032e548669ab184d75903d0 *R/methods_ggeffects.R
1852bc064dec2945aed31aae876afffb *R/methods_gjrm.R
f4a2393725bfc40edd943617019e9e40 *R/methods_glm.R
d4575c195cd86cdd9afce29d5eb722be *R/methods_glmgee.R
837465aa38819e5ea25036f0f2186151 *R/methods_glmm.R
ae05d5c7c138757d0ca2db8692ba65ae *R/methods_glmmTMB.R
0cab414df241775b26348d4593cbc985 *R/methods_glmx.R
8eab71793b700f0aa4b6778aa36d61f7 *R/methods_gmnl.R
c528a9f7b35d49e0e764075e41b039d7 *R/methods_hclust.R
a6d992096f8e5bbdc7bf2da4e58074ff *R/methods_hglm.R
87d7143200963eab57250290ffbb4eb0 *R/methods_htest.R
a35ca918213a190eb6f5e46da57a95b8 *R/methods_ivfixed.R
cb32343a61abac5e88f0a9f89e33aa90 *R/methods_ivprobit.R
55960685d785d71fdaa71a0156b1d955 *R/methods_ivreg.R
d966034455f8f6e405caef9bde657bda *R/methods_kmeans.R
0cee7cf2c745b06eb950c1b567b3a210 *R/methods_lavaan.R
487142aae40b25fdbb672d08f982f482 *R/methods_lm.R
c000d807171d3d02daabb5e6903a80a2 *R/methods_lme4.R
42c06fdb8b2f906313a1381dd72d9b26 *R/methods_lmodel2.R
ffb88aa5f89e838d4269fae424a5e8e2 *R/methods_lmtest.R
4c1cb4edf2684af9e47512b990d94a1b *R/methods_logistf.R
4acbc5d57348a926901497f13804fba3 *R/methods_lqmm.R
edebb6696258908f1cee51a4af079481 *R/methods_lrm.R
b1d7aba02c132a5d834ce700fdc38ff7 *R/methods_marginaleffects.R
54e755fd9e520d96a1c5972342fadf6c *R/methods_margins.R
ddb47fa11799b4430d2231ccd8a1ee91 *R/methods_mass.R
bb90294c2cfef72e27d30eb0bc8dde99 *R/methods_maxLik.R
81452349dc3f91d5a184e4bc42c72a71 *R/methods_mclogit.R
2035dedb2032732b8a0d3bc85dbc4b7d *R/methods_mclust.R
de90f533bb91137ea8a2a0052e90b9c2 *R/methods_mcmc.R
27b689c089ddc5f33d34bb6409f21706 *R/methods_mediate.R
2acbdf600911350d1a794f4afa024a6a *R/methods_merTools.R
f38d2d4a6f7ae8a6151847a384eebbd1 *R/methods_metafor.R
c71e65bc9479224c12bc1de152cbd2ab *R/methods_metaplus.R
0f5b41b225ccfb42347e87cc870f9099 *R/methods_mfx.R
f96c2df33c7dbca4ab6c880f8018c460 *R/methods_mgcv.R
256ce6b33f11e960d584726e85e5e4cc *R/methods_mhurdle.R
2512341f2d3bfba88aa4ce27836fbf1c *R/methods_mice.R
341b31ce1cb3c0f8718d85b6a80160f4 *R/methods_mixed.R
3ab1700d24ada08bf2293312e348866f *R/methods_mixmod.R
d4f8b0ad7037d9d402b7089a801204b0 *R/methods_mixor.R
24500a4973ccd744733dda4ade8a1e93 *R/methods_mjoint.R
ce803ef097139ef52a1f3bf6c2cbeb37 *R/methods_mlm.R
741eff53296afd0495141eada7e9dea1 *R/methods_mmrm.R
ca2ada27cca91ff68d20513ba82747be *R/methods_model_fit.R
3243bbc7a7fc52ba90cbfa5b0a1f573e *R/methods_multcomp.R
9b018d99bbbffd473193b8a5cc45e1e0 *R/methods_multgee.R
15b0cc2d1c602728bb7de45c273252c3 *R/methods_mvord.R
4440c0c736ca41de6cf099e8a63d402d *R/methods_nestedLogit.R
268623f7512ca964d69d169ca22b1be0 *R/methods_nlme.R
2da48171460c27409524f2f83bf9ea4c *R/methods_ordinal.R
e6a91d6f512fbc6c970792ffe9d75de4 *R/methods_other.R
cd23ef88541390106c7be4fa28c4724c *R/methods_pam.R
20265e3fa2d58eb9e45983c4025e7d1b *R/methods_panelr.R
1d3b9a6ff9f725a708c660c7b908e310 *R/methods_pglm.R
b4d66632f5743af68e6c29e75571129c *R/methods_phylolm.R
f585d8c8e0039159d161766b637446e8 *R/methods_plm.R
416c565280aab1fe751398b306ec5a67 *R/methods_posterior.R
32d7e18fa51ac5746276f3074db5678a *R/methods_pscl.R
0f96f46f93fc3bb5d52b15887000b39c *R/methods_psych.R
00611153a0796d302e4125246730735e *R/methods_quantreg.R
33495af1a6473d0f5122703b319f590c *R/methods_robmixglm.R
23f350a2e4e2cdb17b415a23110fb1dc *R/methods_robustlmm.R
1e94bc14383b82e0b18278be9dce4b3e *R/methods_rstan.R
3a090fa2eb6aea8d3c21b8ad6f141e95 *R/methods_rstanarm.R
39def1ddae3f5c401c685045dfd894a2 *R/methods_sarlm.R
2e5db51c3752a810c83104226afd687c *R/methods_scam.R
cceef4097f41e881a5e110b4316a29bc *R/methods_selection.R
0a211abda37ad9ee17f5308a4d6282bf *R/methods_sem.R
0549bf0dbf62cb2915c1cb390fec9147 *R/methods_skewness_kurtosis.R
5371941d1513da06f0bdc10a57738bba *R/methods_spaMM.R
629f771c4b39682c5d40e82368341144 *R/methods_speedglm.R
72eeb0ed9eb2af20725df7ed9ed3ab8a *R/methods_stats4.R
a152ff372338081aad60bcd5c80ae7be *R/methods_survey.R
fee60b2d0f7ac1e243f35f673f4b1db6 *R/methods_survival.R
881e58753c3e7fba340a4740f1d53c7a *R/methods_svy2lme.R
4fc9ad072f6099b2aca42a2998d1e6bb *R/methods_systemfit.R
9e217dbd4d68cec8f0e67f6fca858ee1 *R/methods_truncreg.R
001e965b171d6e46f0694b0c084c78dd *R/methods_varest.R
efc51f3786f6505c7311a8bd0f3c9248 *R/methods_vgam.R
9c22c8f4029bb16cb45429e748216895 *R/methods_weightit.R
6219efddd08ccb9b8f8f96156ec7587f *R/methods_wrs2.R
74ddba5250453dcfe9aed71f75c85d09 *R/n_clusters.R
0a45c14743f5b81d250f5345de6ffa74 *R/n_clusters_easystats.R
976d255486fcf4de80f7fca29cd96222 *R/n_factors.R
13d57d06de27880265635121c2c7bc0e *R/n_parameters.R
6b2b16725f98fe68882596bd5ee5ff2d *R/p_calibrate.R
fb225e003ef68e0b258b38af1d2b311b *R/p_direction.R
1d9161d13176b9c75fd24d2a11cab208 *R/p_function.R
efbf187f4aa29501687b0f7b8fed4f6c *R/p_significance.R
ad4a00785f3a30417c4932bbca203217 *R/p_value_betwithin.R
7c1f6c7f512b4175e8d3725829abba3c *R/p_value_kenward.R
339f24be8e8a13165b97390567b45153 *R/p_value_ml1.R
bb499d331d58c81bb97e36fb03a25f85 *R/p_value_satterthwaite.R
5ba5bd8380a2b3c699e630aca9682f00 *R/parameters-package.R
b558b5447053df5f414c423d3815727c *R/parameters_type.R
ab20a0eeccf5dc296c249238cd6b46af *R/plot.R
b67d73e52d8c942503c70b68da922932 *R/pool_parameters.R
bfbf9cc789b93775989ad65f889dfdb7 *R/principal_components.R
cd9b61e19e594377bb3312b6bfbb899b *R/print.compare_parameters.R
0e0c2f82c6dc1c4c589d7c5691ed7b23 *R/print.parameters_model.R
54272ad3e17d0432ec1a30378e704973 *R/print_html.R
56282c0eaaec692506a0a552eb34c100 *R/print_md.R
2756d929138634e5a83cf0f3bb412461 *R/print_table.R
4f2835839db69a98fc80f17a1a689722 *R/random_parameters.R
00493803f64747b7163596b3fc18b69d *R/reduce_parameters.R
eb3bd78fdec490ec43097188b608cc4e *R/reexports.R
26024be7b956762a332bf600548bf09a *R/reshape_loadings.R
eb3af6293ff4fec0fa16c65a1c82cbe8 *R/select_parameters.R
a8680ff58d937a154806aaa1f51f97e1 *R/simulate_parameters.R
838493d0ba8bf34928efab47a3ecf7a1 *R/sort_parameters.R
4580b00a2472cf843c6e5821998752c1 *R/standard_error_kenward.R
a5eb604c29599ba9330354300314485f *R/standard_error_satterthwaite.R
c6a6fdb3511a2864dcd12a76c20d1119 *R/standardize_info.R
801f6ca0a185831693c804ec6b122fd2 *R/standardize_parameters.R
e75d8e9e8fbf67797e67af723d7064b8 *R/standardize_posteriors.R
6d3c9ee25fa44dd6b1eaabc86bc68e06 *R/utils.R
dfc8118fcaaaed85eb4f6e6caf9a6bf3 *R/utils_cleaners.R
2b3b26fc248bbc95d4fc2d3177c300b6 *R/utils_clustering.R
6ec124a23ac173b495f8b7689dbb14cb *R/utils_format.R
70ba7899b4541338b6d6a5e7808e57c5 *R/utils_model_parameters.R
de985fb428f1806e3fe4ec1b6e2fb8c6 *R/utils_pca_efa.R
89895e2d88efc717efb4ff58bc1070b6 *R/zzz.R
30ae5e13969c094d9c823743967d919c *README.md
75d0a007992c60d09f764686e9397c0f *build/partial.rdb
3b02803df3ae5657e409e93bdd9e5b96 *build/vignette.rds
fed293a745c7a75939e2f2156aaa9afe *data/fish.RData
fca1e9b681b9f432165601e6510c483c *data/qol_cancer.RData
d9a675761b0b4ec7816a274c92857f5e *inst/CITATION
03e28ae2e4de1b60f095a52273c09fcd *inst/WORDLIST
7342a6d63f4cc4501afc55be1d148740 *inst/doc/overview_of_vignettes.R
8f5d9cba18c8d2202bfe119bcf623889 *inst/doc/overview_of_vignettes.Rmd
e95d1e6d43fd8dace29efa2f9aa04240 *inst/doc/overview_of_vignettes.html
f3f23263b0cda1f60dc1075e007707c2 *man/bootstrap_model.Rd
7c6aac09db974f09eecdfd5df69cba81 *man/bootstrap_parameters.Rd
2f3a7e271a38f563889f9f4ba1744442 *man/ci.default.Rd
d111f5645d9a0341f361fbf450d3876e *man/cluster_analysis.Rd
469236e95f075b3f84dd06c23452e102 *man/cluster_centers.Rd
c9303787525cb79563a3f8b4b9b50f68 *man/cluster_discrimination.Rd
0b44c6af54fb0c2c270729f0717ee0a3 *man/cluster_meta.Rd
22d45ca9f9552b74c949621c2748b2e1 *man/cluster_performance.Rd
f9af153adfb648a6f73a2307e647768d *man/compare_parameters.Rd
96075a57ae5632b04771b3650594b93f *man/convert_efa_to_cfa.Rd
43841d6709ae27d95c4e904fb1234015 *man/degrees_of_freedom.Rd
d20905ceae606fc5cce37a50c65d2b28 *man/display.parameters_model.Rd
0bf3c9185c349ccba1162869b58ac292 *man/dominance_analysis.Rd
ada4525e7f51696872af8e67a11a8a03 *man/dot-data_frame.Rd
d497a17727c64a877268d9e06f0cd046 *man/dot-factor_to_dummy.Rd
6f88971941994882a00c6f6fe9b59ea2 *man/dot-filter_component.Rd
d345ca758850004bcc8f2dfbfa129a77 *man/dot-n_factors_bartlett.Rd
d773be8d96a78e87754d7ffd0e64102b *man/dot-n_factors_bentler.Rd
8d7187c3a82dbaaea1fa0368bea3914a *man/dot-n_factors_cng.Rd
9545ed998c17d115ed152a3f269530fd *man/dot-n_factors_mreg.Rd
1e126d6996539eff78565cf11aeb80ec *man/dot-n_factors_scree.Rd
4e979353266706b75a554fe0b05420ae *man/dot-n_factors_sescree.Rd
99a0486ee7f327494c805e6b1fcba4b6 *man/equivalence_test.lm.Rd
b21e4345f92f98ffb97d0f3b06492a42 *man/figures/card.png
80c2c196a70f7211c90bf2c510d39d41 *man/figures/figure1.png
763d72787cad1fca6fc76de99da06308 *man/figures/figure2.png
34f97573ccc6dab523d52cbd156882dd *man/figures/logo.png
77bd5b3c932e7c6c922d81e01d4f22f4 *man/figures/unconditional_interpretation.png
dfb7d2691aa5df65c196bdd538860c75 *man/fish.Rd
ed5f06e2c08127ed5b98439ac44b725f *man/format_df_adjust.Rd
3551b5b180212346989acfd2bfb14485 *man/format_order.Rd
0d3085434ec747b5f23d015056783737 *man/format_p_adjust.Rd
69fbba3afb04972dadd4f4f1c23c1a4b *man/format_parameters.Rd
87408953ffe975cc42598bde084daf76 *man/get_scores.Rd
27958ada6503ba0204fcc269f82b600d *man/model_parameters.BFBayesFactor.Rd
311d21c13df61d75ca63ca9a1a518f84 *man/model_parameters.Rd
f1aa6f2b5686ec5108182df30ff6d71d *man/model_parameters.aov.Rd
787d40b085656797e30dc4f38708a27b *man/model_parameters.befa.Rd
df2f1522c7a2d898b48ab6368e843e99 *man/model_parameters.brmsfit.Rd
6b5039d7f4d92828961669410bf5529a *man/model_parameters.cgam.Rd
3b49d3a9d5f15401be0325ac4543d0d7 *man/model_parameters.default.Rd
96d99d34e1e2d1e3e9a9096aec621cc7 *man/model_parameters.glht.Rd
5341e2e13a16a3bd90d29735f42873b6 *man/model_parameters.glimML.Rd
5de6075aec05202e416cd3eae1cf5b79 *man/model_parameters.glmmTMB.Rd
653918feabcb418537f5c2694de7f894 *man/model_parameters.hclust.Rd
16d4e6d0324787f1e8586f07ab609ef4 *man/model_parameters.htest.Rd
8a5a265acaab5fb861cd169089a9dcec *man/model_parameters.mira.Rd
c6467d5bda5dd9225be53828ce531ac3 *man/model_parameters.mlm.Rd
873dda7366ecc3f8a5fbc71f9408c2b2 *man/model_parameters.principal.Rd
bda9c1d610e7de30a5aee32c3f01c980 *man/model_parameters.rma.Rd
6263ffbfad14d845cee2c4d3a1794c46 *man/model_parameters.t1way.Rd
c7b164701d0d33baeaf9c3c3a6a83bd3 *man/model_parameters.zcpglm.Rd
3c56f2d618bb5913c5e5f7ecbc3117d6 *man/n_clusters.Rd
d691e96a7b3e5dc26e2915f7d1683451 *man/n_factors.Rd
4780eae6f9cb6ffa108cc6845be60779 *man/p_calibrate.Rd
a5d270db70f2f5e811c3f95752a77354 *man/p_direction.lm.Rd
24f10e47770ebae4e38ac9758fce5599 *man/p_function.Rd
73725666cbfc7d7d40a898da105dc443 *man/p_significance.lm.Rd
550762598c1d2eeed3e7441a33dce737 *man/p_value.Rd
92c8ada9bace97d7fda5ba54f39e86b0 *man/p_value_betwithin.Rd
8664909b16e56d31eabc8a029edaf8fd *man/p_value_kenward.Rd
a9b83928c7683397e31cec0f4bb19b3c *man/p_value_ml1.Rd
3c985d78ae9007388d8df8937bc1e21d *man/p_value_satterthwaite.Rd
51714d9c1566bbec0385be632c448e5c *man/parameters-package.Rd
fe31fb663bdf80533d7e94f995c788b2 *man/parameters_type.Rd
72209512f75f33d310008e296966c018 *man/pool_parameters.Rd
96dbea0125a5bc4271953baa9f931b18 *man/predict.parameters_clusters.Rd
a844ba30dd696cbc6553224833ba4c27 *man/principal_components.Rd
86d6fd7bf6ea7efe19179c035d1c8141 *man/print.compare_parameters.Rd
4176b80bec4fc8e44db180ecf111ad3e *man/print.parameters_model.Rd
d1e2d2ee9e66ebab0de28c9f432defb9 *man/qol_cancer.Rd
853a6a36449195197cac381737241a16 *man/random_parameters.Rd
c2593a39a43571c838c1a47fd7bd6a3b *man/reduce_parameters.Rd
4d978acca856b48c77434e9585634391 *man/reexports.Rd
f463791dabf2e57b9696645b3d24af66 *man/reshape_loadings.Rd
a5f1ce677faa5b0ff705770306a79242 *man/select_parameters.Rd
98902a418c45cf5465da2aeb23f2e0b3 *man/simulate_model.Rd
a63f1ed8dfe5adb22b04f6903d90765f *man/simulate_parameters.Rd
73e7d1ef700a874d334947bafcc09664 *man/sort_parameters.Rd
657bb866cf10058721a7bcf65a3bf54b *man/standard_error.Rd
00fd10f404b5155d2b05a38aabb8107f *man/standardize_info.Rd
8dc6c71e4bbafc3881931ae0213c15bc *man/standardize_parameters.Rd
5290644057e754afb8ed29ffbdd4b863 *tests/testthat.R
dfdb64c2f370ee431a45da2a93d5c8da *tests/testthat/_snaps/averaging.md
456dedefcd455464b63f7700f7cddd39 *tests/testthat/_snaps/bootstrap_parameters.md
5a9c09c734d1660febf25106dd40695c *tests/testthat/_snaps/brms.md
6d8fd85018b6d348b08e0bcb251b5fb9 *tests/testthat/_snaps/compare_parameters.md
b39b6f8a249af128efcd1e64c55dd1f6 *tests/testthat/_snaps/complete_separation.md
a394c1266704241f4e148b83e48afb4e *tests/testthat/_snaps/coxph.md
5b435155fc68ce3031ee153802965674 *tests/testthat/_snaps/emmGrid-df_colname.md
0ea13285426936285fcd924f920e082c *tests/testthat/_snaps/equivalence_test.md
3f03ab83f4940e69f3bb2d71773dd9b1 *tests/testthat/_snaps/equivalence_test/equivalence-test-1.svg
e9074eebd7933eb0b9a1ec74eb758cea *tests/testthat/_snaps/equivalence_test/equivalence-test-2.svg
b96a0e80f6869ad45da2a8d4b09f8929 *tests/testthat/_snaps/equivalence_test/equivalence-test-3.svg
31cae6cddcee746072b432238554c8be *tests/testthat/_snaps/equivalence_test/equivalence-test-4.svg
29f36c2e2128d1d9aa640481eb535c43 *tests/testthat/_snaps/equivalence_test/equivalence-test-5.svg
9043fce7a0212406b9fbb0c643a46322 *tests/testthat/_snaps/gam.md
0702b1bc8bb265de5cbcd3ddb9092b7f *tests/testthat/_snaps/glmer.md
e2862afab8a22fc269c7e110d53d45db *tests/testthat/_snaps/glmmTMB-profile_CI.md
59df08b60de83b1804ececd7ed6b8e17 *tests/testthat/_snaps/glmmTMB.md
8536fb170fe80f9f851ceb74a4f47f42 *tests/testthat/_snaps/include_reference.md
a08548f0989c3d14ed7049eb0571a93b *tests/testthat/_snaps/ivreg.md
41e1dbd9969d41ea1fe3bb36e3176e0c *tests/testthat/_snaps/marginaleffects.md
5923a2e6f8bc1845d41fe6adbcad9d6a *tests/testthat/_snaps/mipo.md
d9973456b7286518264e78d9ce1bbec4 *tests/testthat/_snaps/model_parameters.anova.md
7ec0f8b8725644acc744a11b5754a280 *tests/testthat/_snaps/model_parameters.fixest.md
66662cae33b53acccfc1a3f0be9b660e *tests/testthat/_snaps/model_parameters.fixest_multi.md
42f9b53b479692fbe0938ad8393019ba *tests/testthat/_snaps/model_parameters.ggeffects.md
118914b6e95b68bf0c82b1f05932498c *tests/testthat/_snaps/model_parameters.glm.md
60eb2c77d2fb7a54cfa2242c10910d7a *tests/testthat/_snaps/model_parameters.glmgee.md
5214e3da458d9aa99f248980f1b9ca8e *tests/testthat/_snaps/model_parameters.mclogit.md
920557d8e9658fd4a691d690bcdd1dd4 *tests/testthat/_snaps/model_parameters.mixed.md
a9e9ce379298245791a3e17f888e92d4 *tests/testthat/_snaps/model_parameters_ordinal.md
6f46572bab1ce75f0c81bb34f3b9ee3a *tests/testthat/_snaps/p_direction.md
624cb845f106125c820e647736a9743e *tests/testthat/_snaps/p_significance.md
a1c0230c5a5f11b54cd7ea0511a3e9c2 *tests/testthat/_snaps/panelr.md
c32ca891daab74524aa1304da107c4bc *tests/testthat/_snaps/pca.md
634bea7be744988a74e7dd2a2649b12b *tests/testthat/_snaps/plm.md
9ef01e4cae0f27abd7dcb53d3b9f7b9f *tests/testthat/_snaps/pool_parameters.md
2151758cfdbe4473bb44150e5a83655b *tests/testthat/_snaps/pretty_names.md
fd70c10e469baf092028c7b9b03a8a41 *tests/testthat/_snaps/print_AER_labels.md
099b8712881d0dac7be0145886b6226a *tests/testthat/_snaps/printing-stan.md
2569bced335bda723b6a368189cac40a *tests/testthat/_snaps/printing.md
022192a031cad98a3e6c348f7187b570 *tests/testthat/_snaps/printing2.md
24e21076c3e4d655c8c3aa55f72851e4 *tests/testthat/_snaps/serp.md
3d8e8dc14005ad5b3187e421badde282 *tests/testthat/_snaps/standardize_parameters.md
6a973b0d29360bb8bb3e62f4ef67d88f *tests/testthat/_snaps/svylme.md
de73a5646ed4de4b919d2779b6c576fe *tests/testthat/_snaps/visualisation_recipe.md
6fdf8eb244ddc086cee4f40853ff704f *tests/testthat/_snaps/weightit.md
7e5a74afb339896fdb3b1d8635da5294 *tests/testthat/_snaps/windows/model_parameters.logistf.md
a82b9b719bb1cc86061cc300b17b12a9 *tests/testthat/_snaps/windows/model_parameters.logitr.md
6d3b3fb3c94edf109bb203d4dfe39e19 *tests/testthat/test-GLMMadaptive.R
5dbb3ee03a5f518f7c8158a245e7f38f *tests/testthat/test-Hmisc.R
315816def4ab95999ca7ca12e802ea3d *tests/testthat/test-MCMCglmm.R
18339153557775cd0eb54ac37364c071 *tests/testthat/test-PMCMRplus.R
219100322f2f1374317147726d89ef30 *tests/testthat/test-averaging.R
079e987fe20981e86bb9a98d11cf96c1 *tests/testthat/test-backticks.R
9f21ee5706d3853493c8cbcef4f51663 *tests/testthat/test-base.R
158e1d4b1dce7b6ad86a50871e340f63 *tests/testthat/test-betareg.R
9b795dc14da8bbc259792efbe14394a2 *tests/testthat/test-bootstrap_emmeans.R
4cf1814e895292bcfd2de38bee43b273 *tests/testthat/test-bootstrap_parameters.R
27b2ea108f43b89c64b0856208a75243 *tests/testthat/test-bracl.R
603662354d9bbe663e0a2a6bb8fa39e0 *tests/testthat/test-brms.R
daab505765afa8b0eb8f0343cb67e70c *tests/testthat/test-car.R
bdcc53713b0231c4dd4056f937b715ee *tests/testthat/test-ci.R
733ca026aadc081445ee63377db16425 *tests/testthat/test-cluster_analysis.R
78b43c1b064cb8c2dcf159deff13cec0 *tests/testthat/test-compare_parameters.R
2da17d1fde6ebcdb7703ccf32b345654 *tests/testthat/test-complete_separation.R
2030d7ea9bb96de36e18a4b6d955c205 *tests/testthat/test-coxph.R
0ae8f50b51b31118249f0360b49b6089 *tests/testthat/test-dominance_analysis.R
e585dc41f5950f04144b7de6e763d70b *tests/testthat/test-efa.R
3ea3d4f269f435a04b12697e58413cbc *tests/testthat/test-emmGrid-df_colname.R
7a59fe8e4f03e160a5bff5196efacc9c *tests/testthat/test-equivalence_test.R
4fbec374b87f1977209322dc5aa8e5e7 *tests/testthat/test-estimatr.R
80803d664707689aa9a1b6e9412d56b2 *tests/testthat/test-format.R
dec63cbd4f3f4849ee5a5d67c3172c59 *tests/testthat/test-format_model_parameters.R
e9e9a355c815ab56453ced52fff9ce77 *tests/testthat/test-format_model_parameters2.R
6ac043255de37a0a9577c72d2a4405da *tests/testthat/test-format_p_adjust.R
a84f73d465aee8ccaf05b2931982b7ad *tests/testthat/test-format_parameters.R
4fd30b7e1520785801509d3d079ef625 *tests/testthat/test-gam.R
ae818c8191e0535c2e663917868bd04b *tests/testthat/test-gamm.R
3dca0bcc3cc2b26d62136caffb5c9c9a *tests/testthat/test-gee.R
5798145d8f4e19d9f779016a6aebfe87 *tests/testthat/test-geeglm.R
6e6313bb7961668e1ae77e2133e944a1 *tests/testthat/test-get_scores.R
744c86d4c939193757db8c039a158231 *tests/testthat/test-glmer.R
eef813622ecc022c98d82e1d01e2ef5f *tests/testthat/test-glmmTMB-2.R
a4af9d6e805201b8a6a11c1e11535063 *tests/testthat/test-glmmTMB-profile_CI.R
dd30ae72d5f84706472350c4bee29b33 *tests/testthat/test-glmmTMB.R
1bcbb7610f901a894465019cdbb1d1c3 *tests/testthat/test-gls.R
c25d2e64f5103fd09fff82f7cce5bb48 *tests/testthat/test-group_level_total.R
2c20c542b5cea26bac9cfc311d492a97 *tests/testthat/test-helper.R
7c4b129a45728ae267fe084dfecf30e6 *tests/testthat/test-include_reference.R
ccfadf4697a7fd588004a6259408afab *tests/testthat/test-ivreg.R
378d92a77c563e829df688c8f933f10a *tests/testthat/test-lavaan.R
affc0de64eb9e599cf55d8a6c96e3c93 *tests/testthat/test-lme.R
94dde5f73d12dc23905879b3174575c2 *tests/testthat/test-lmerTest.R
33f6bf8d6c276f39d2ffdb375ba9e0cb *tests/testthat/test-marginaleffects.R
b58b45bc8cdc1af80340d5c6f1cff1f1 *tests/testthat/test-mipo.R
6f6d859c2d6c26cce9514f323d853b30 *tests/testthat/test-mira.R
2314dfc155f4dd2946e6895b5e0a8946 *tests/testthat/test-mlm.R
6a202108929d57dbc276a59a0e5cfc80 *tests/testthat/test-mmrm.R
e8d30117b9baf8bec77c79340ec4b398 *tests/testthat/test-model_parameters.BFBayesFactor.R
3283009a8e100a74645141047b63b4bd *tests/testthat/test-model_parameters.MASS.R
0ea9727d1bd17d8b385c324f856e5b71 *tests/testthat/test-model_parameters.afex_aov.R
7996a27696592c56978bbd2a35e978d6 *tests/testthat/test-model_parameters.anova.R
a997e6ebc295eb0691448c890b1f6d08 *tests/testthat/test-model_parameters.aov.R
e50d26f514f628c0ad70f164ae632f54 *tests/testthat/test-model_parameters.aov_es_ci.R
073571251b3edbba2b0f973b359e74d9 *tests/testthat/test-model_parameters.blmerMod.R
677dcb88d16a2dea88110d643c21ca48 *tests/testthat/test-model_parameters.bracl.R
aa555b40a7835004afcc0935c31bed9a *tests/testthat/test-model_parameters.cgam.R
0641df459373d13df085807afe0fbb7b *tests/testthat/test-model_parameters.coxme.R
187a7f403cc39b2494d0eee5227fd7a4 *tests/testthat/test-model_parameters.cpglmm.R
a2f20461e6593a76540649c95a9aad1e *tests/testthat/test-model_parameters.efa_cfa.R
7e04bd526faa08f939f70f712773f456 *tests/testthat/test-model_parameters.epi2x2.R
f94dacede9fc3d854172faf02ae8eba5 *tests/testthat/test-model_parameters.fixest.R
884cc7ccd1e33f8dc4a6510bc5dc8be3 *tests/testthat/test-model_parameters.fixest_multi.R
440ab1ca53a5827da01354acd9ac2f9d *tests/testthat/test-model_parameters.gam.R
a885891866e4c55c672664472fb652ab *tests/testthat/test-model_parameters.ggeffects.R
36a864387a3438c6a00037eec1d39ed1 *tests/testthat/test-model_parameters.glht.R
1fe882df9fdbbca76822a1dc77fa3fc2 *tests/testthat/test-model_parameters.glm.R
d3b8eae2e6bb53fac667c8ed093bc20e *tests/testthat/test-model_parameters.glmgee.R
434a2be3fa26e27c528c1c9402174672 *tests/testthat/test-model_parameters.htest.R
75371d99fa47b84d9dcff6b792bc2438 *tests/testthat/test-model_parameters.hurdle.R
99b54414602f84c56923e38883aa3e82 *tests/testthat/test-model_parameters.lme.R
974884fb67246b446a849fad852cc73f *tests/testthat/test-model_parameters.logistf.R
520d6c72e25b50f585ce8b0fb2c57b0a *tests/testthat/test-model_parameters.logitr.R
e351cf250c300973605a89eb69ae3ed4 *tests/testthat/test-model_parameters.lqmm.R
5b84af88c0616dc21f7ae77d88f94f18 *tests/testthat/test-model_parameters.maov.R
5f72300ac3c960644feb8d2d7dc80dac *tests/testthat/test-model_parameters.mclogit.R
a586a703e26aa333efdc414df0a89ee2 *tests/testthat/test-model_parameters.mediate.R
32738a8e344a949d67d244717a83ea58 *tests/testthat/test-model_parameters.metaBMA.R
5d485be293f55a6aabf2ecf4bd8eec9d *tests/testthat/test-model_parameters.metafor.R
19dae6116410b5cf0b356411bb471c10 *tests/testthat/test-model_parameters.mfx.R
a7db8bf7f31cb532bbe0a487c7760e8e *tests/testthat/test-model_parameters.mixed.R
3866468a65a2d36e17088fb97ef9cd38 *tests/testthat/test-model_parameters.mle2.R
6feb54b53bfb2669ae33a597518636c2 *tests/testthat/test-model_parameters.nnet.R
74a1bcd1d87197721099274975daa608 *tests/testthat/test-model_parameters.pairwise.htest.R
04fdb727fae1fafa1922da65b994e292 *tests/testthat/test-model_parameters.truncreg.R
cd38a981c7ec8174cb32fe9617789ba7 *tests/testthat/test-model_parameters.vgam.R
2d84a833b48ba8b9eb894063e8a353f4 *tests/testthat/test-model_parameters_df.R
d5b35a3a1d8894248ff0adb0592c2a2a *tests/testthat/test-model_parameters_df_method.R
0c6fa6b65cf3ebf6adb702a26c631f4d *tests/testthat/test-model_parameters_labels.R
1d55a5ee1f08935aa5fa1f89f769f982 *tests/testthat/test-model_parameters_mixed_coeforder.R
5e7df36f48bb47ecbc2c357d56cf2ae6 *tests/testthat/test-model_parameters_ordinal.R
002c97429db93d2cfad3e57bf7c442f2 *tests/testthat/test-model_parameters_random_pars.R
889f27f66bb742bc1569a28406477bb8 *tests/testthat/test-model_parameters_robust.R
13284b8cbd5c933128d502f5f8e2fe56 *tests/testthat/test-model_parameters_std.R
a5fc6d89b44b3634907db07c78c940a9 *tests/testthat/test-model_parameters_std_mixed.R
26458b987225ff7cf5e8063d1d51bc5e *tests/testthat/test-n_factors.R
178bdad755a06c4c3e6670e181846a52 *tests/testthat/test-nestedLogit.R
d682889a5ab2af44cb9c10f0c2c46f5f *tests/testthat/test-ordered.R
71656cd1d702740c54c71e546213e62b *tests/testthat/test-p_adjust.R
1862202aa53fdd2a7d75715f118985ee *tests/testthat/test-p_calibrate.R
66654efe6243a9ae2d8664cd80b3d08f *tests/testthat/test-p_direction.R
e501a2a906fcaefb91c563edbf43732d *tests/testthat/test-p_function.R
68c6df2227ae13198d98ec985f5ba27d *tests/testthat/test-p_significance.R
4b0c3fa1ff0fc49818dfe95e4c5de7d2 *tests/testthat/test-p_value.R
8df1623e825478b6a5cedb8c364c18fb *tests/testthat/test-panelr.R
90d7af6119b4923fb4fc5c5c43a2c486 *tests/testthat/test-parameters_selection.R
f5ba81964037e535fda30f770014d9f8 *tests/testthat/test-parameters_table.R
58d35b25e974c09c2b3599d04c9cede6 *tests/testthat/test-parameters_type-2.R
772c95c63a8794717af82a43d0679a4c *tests/testthat/test-parameters_type.R
d34fae2edc7e0caaa044fabfc447b1db *tests/testthat/test-pca.R
05af5c5297e971349be0bd4736144e2d *tests/testthat/test-pipe.R
a86c6a34819184c43f5dbd76f6f91b7c *tests/testthat/test-plm.R
457d5e0e892915b15eb6d11ab77980f7 *tests/testthat/test-polr.R
6956eab09a17bd904866d7ee9bbb5e60 *tests/testthat/test-pool_parameters.R
0a4157367f130d5b20cc6cad1f599eb3 *tests/testthat/test-posterior.R
0fa7f46eb3b0476a9dd0bfe73f259837 *tests/testthat/test-pretty_names.R
800b314e662bdd11a1d48617540425d2 *tests/testthat/test-print_AER_labels.R
ef2a643febb4b5a816721212e6808001 *tests/testthat/test-printing-stan.R
b6dcf64138fc7d97a6303ec5715de324 *tests/testthat/test-printing.R
efa800d7fc84d3481d64f299de544bd9 *tests/testthat/test-printing2.R
4245ef6260c46b60141dbe958474db74 *tests/testthat/test-printing_reference_level.R
5fe32565c46646baf2a6b46e02524bc8 *tests/testthat/test-quantreg.R
f36dcece5001c90e086baf00caf3e864 *tests/testthat/test-random_effects_ci-glmmTMB.R
f907b59087e8cfe2b617ee77f87099b4 *tests/testthat/test-random_effects_ci.R
60d5916e69d6e075bb2308fe4a877f19 *tests/testthat/test-rank_deficienty.R
8e36bfa74c4e01b07081ba6aad8b584d *tests/testthat/test-robust.R
3a766194d1a5d933e8e066c4ecf3dd8f *tests/testthat/test-rstanarm.R
6f67e57cd8c25d65d11785a645d53adb *tests/testthat/test-serp.R
6afceb2d59443a7678ebdae942130840 *tests/testthat/test-simulate_model.R
e74028738355c993259e0717957a7bea *tests/testthat/test-simulate_parameters.R
73c25244107f5213cd167431c460b50f *tests/testthat/test-sort_parameters.R
d4c32db052fd05385daf83a5cc7675d0 *tests/testthat/test-standardize_info.R
82f4b96e4733b5543280c3f828e9f9f9 *tests/testthat/test-standardize_parameters.R
b9f53f0b2eae2bfbf416b7a53a6590d5 *tests/testthat/test-survey.R
098947ff29d64f3e280aff8c6d0992d8 *tests/testthat/test-svylme.R
1b2d2b012db8111eb2dbd4a1133949c0 *tests/testthat/test-tobit.R
47287754f5609d2933523c8b94f64c02 *tests/testthat/test-visualisation_recipe.R
08064996366c66b22e56051c918c875a *tests/testthat/test-weightit.R
f6240d909a5a534c577d09fad1878b30 *tests/testthat/test-wrs2.R
53804133b2114966510ba30647a53e83 *tests/testthat/test-zeroinfl.R
8f5d9cba18c8d2202bfe119bcf623889 *vignettes/overview_of_vignettes.Rmd
parameters/R/ 0000755 0001762 0000144 00000000000 14761600725 012626 5 ustar ligges users parameters/R/methods_coxme.R 0000644 0001762 0000144 00000001062 14716604200 015576 0 ustar ligges users #' @export
standard_error.coxme <- function(model, ...) {
beta_coef <- model$coefficients
if (length(beta_coef) > 0) {
.data_frame(
Parameter = .remove_backticks_from_string(names(beta_coef)),
SE = sqrt(diag(stats::vcov(model)))
)
}
}
## TODO add ci_method later?
#' @export
p_value.coxme <- function(model, ...) {
stat <- insight::get_statistic(model)
if (!is.null(stat)) {
.data_frame(
Parameter = stat$Parameter,
p = as.vector(1 - stats::pchisq(stat$Statistic^2, df = 1))
)
}
}
parameters/R/methods_gmnl.R 0000644 0001762 0000144 00000001712 14355245205 015427 0 ustar ligges users #' @export
standard_error.gmnl <- function(model, ...) {
cs <- summary(model)$CoefTable
se <- cs[, 2]
pv <- .data_frame(
Parameter = .remove_backticks_from_string(names(se)),
SE = as.vector(se)
)
# rename intercepts
intercepts <- grepl(":(intercept)", pv$Parameter, fixed = TRUE)
pv$Parameter[intercepts] <- sprintf(
"(Intercept: %s)",
sub(":(intercept)", replacement = "", pv$Parameter[intercepts], fixed = TRUE)
)
pv
}
#' @export
p_value.gmnl <- function(model, ...) {
cs <- summary(model)$CoefTable
p <- cs[, 4]
# se <- cs[, 2]
pv <- .data_frame(
Parameter = .remove_backticks_from_string(rownames(cs)),
p = as.vector(p)
)
# rename intercepts
intercepts <- grepl(":(intercept)", pv$Parameter, fixed = TRUE)
pv$Parameter[intercepts] <- sprintf(
"(Intercept: %s)",
sub(":(intercept)", replacement = "", pv$Parameter[intercepts], fixed = TRUE)
)
pv
}
parameters/R/format_p_adjust.R 0000644 0001762 0000144 00000010362 14736731407 016140 0 ustar ligges users #' Format the name of the p-value adjustment methods
#'
#' Format the name of the p-value adjustment methods.
#'
#' @param method Name of the method.
#'
#' @examples
#' library(parameters)
#'
#' format_p_adjust("holm")
#' format_p_adjust("bonferroni")
#' @return A string with the full surname(s) of the author(s), including year of publication, for the adjustment-method.
#' @export
format_p_adjust <- function(method) {
method <- tolower(method)
switch(method,
holm = "Holm (1979)",
hochberg = "Hochberg (1988)",
hommel = "Hommel (1988)",
bonferroni = "Bonferroni",
fdr = "Benjamini & Hochberg (1995)",
bh = "Benjamini & Hochberg (1995)",
by = "Benjamini & Yekutieli (2001)",
tukey = "Tukey",
scheffe = "Scheffe",
sidak = "Sidak",
method
)
}
.p_adjust <- function(params, p_adjust, model = NULL, verbose = TRUE) {
# check if we have any adjustment at all, and a p-column
if (!is.null(p_adjust) && "p" %in% colnames(params) && p_adjust != "none") {
## TODO add "mvt" method from emmeans
# prepare arguments
all_methods <- c(stats::p.adjust.methods, "tukey", "scheffe", "sidak")
# for interaction terms, e.g. for "by" argument in emmeans
# pairwise comparison, we have to adjust the rank resp. the
# number of estimates in a comparison family
rank_adjust <- tryCatch(
{
correction <- 1
by_vars <- model@misc$by.vars
if (!is.null(by_vars) && by_vars %in% colnames(params)) {
correction <- insight::n_unique(params[[by_vars]])
}
correction
},
error = function(e) {
1
}
)
# only proceed if valid argument-value
if (tolower(p_adjust) %in% tolower(all_methods)) {
# save old values, to check if p-adjustment worked
old_p_vals <- params$p
# find statistic column
stat_column <- match(c("F", "t", "Statistic"), colnames(params))
stat_column <- stat_column[!is.na(stat_column)]
if (tolower(p_adjust) %in% tolower(stats::p.adjust.methods)) {
# base R adjustments
params$p <- stats::p.adjust(params$p, method = p_adjust)
} else if (tolower(p_adjust) == "tukey") {
# tukey adjustment
if ("df" %in% colnames(params) && length(stat_column) > 0) {
params$p <- suppressWarnings(stats::ptukey(
sqrt(2) * abs(params[[stat_column]]),
nrow(params) / rank_adjust,
params$df,
lower.tail = FALSE
))
# for specific contrasts, ptukey might fail, and the tukey-adjustement
# could just be simple p-value calculation
if (all(is.na(params$p))) {
params$p <- 2 * stats::pt(abs(params[[stat_column]]), df = params$df, lower.tail = FALSE)
verbose <- FALSE
}
}
} else if (tolower(p_adjust) == "scheffe" && !is.null(model)) {
# scheffe adjustment
if ("df" %in% colnames(params) && length(stat_column) > 0) {
# 1st try
scheffe_ranks <- try(qr(model@linfct)$rank, silent = TRUE)
# 2nd try
if (inherits(scheffe_ranks, "try-error") || is.null(scheffe_ranks)) {
scheffe_ranks <- try(model$qr$rank, silent = TRUE)
}
if (inherits(scheffe_ranks, "try-error") || is.null(scheffe_ranks)) {
scheffe_ranks <- nrow(params)
}
scheffe_ranks <- scheffe_ranks / rank_adjust
params$p <- stats::pf(params[[stat_column]]^2 / scheffe_ranks,
df1 = scheffe_ranks,
df2 = params$df,
lower.tail = FALSE
)
}
} else if (tolower(p_adjust) == "sidak") {
# sidak adjustment
params$p <- 1 - (1 - params$p)^(nrow(params) / rank_adjust)
}
if (isTRUE(all(old_p_vals == params$p)) && !identical(p_adjust, "none") && verbose) {
insight::format_warning(paste0("Could not apply ", p_adjust, "-adjustment to p-values. Either something went wrong, or the non-adjusted p-values were already very large.")) # nolint
}
} else if (verbose) {
insight::format_alert(paste0("`p_adjust` must be one of ", toString(all_methods)))
}
}
params
}
parameters/R/dof_satterthwaite.R 0000644 0001762 0000144 00000000731 14415527270 016471 0 ustar ligges users #' @rdname p_value_satterthwaite
#' @export
dof_satterthwaite <- function(model) {
UseMethod("dof_satterthwaite")
}
#' @export
dof_satterthwaite.lmerMod <- function(model) {
insight::check_if_installed("lmerTest")
parameters <- insight::find_parameters(model, effects = "fixed", flatten = TRUE)
lmerTest_model <- lmerTest::as_lmerModLmerTest(model)
s <- summary(lmerTest_model)
stats::setNames(as.vector(s$coefficients[, 3]), parameters)
}
parameters/R/format.R 0000644 0001762 0000144 00000100601 14761570351 014240 0 ustar ligges users # usual models ---------------------------------
#' @inheritParams print.parameters_model
#' @rdname print.parameters_model
#' @export
format.parameters_model <- function(x,
pretty_names = TRUE,
split_components = TRUE,
select = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
ci_width = NULL,
ci_brackets = NULL,
zap_small = FALSE,
format = NULL,
groups = NULL,
include_reference = FALSE,
...) {
# save attributes
coef_name <- attributes(x)$coefficient_name
coef_name2 <- attributes(x)$coefficient_name2
s_value <- attributes(x)$s_value
m_class <- attributes(x)$model_class
htest_type <- attributes(x)$htest_type
mixed_model <- attributes(x)$mixed_model
random_variances <- isTRUE(attributes(x)$ran_pars)
mean_group_values <- attributes(x)$mean_group_values
# process selection of columns
style <- NULL
if (!is.null(select) &&
# glue-like syntax, so we switch to "style" argument here
length(select) == 1 &&
is.character(select) &&
(grepl("{", select, fixed = TRUE) || select %in% .style_shortcuts)) {
style <- select
select <- NULL
}
# is information about grouped parameters stored as attribute?
if (is.null(groups) && !is.null(attributes(x)$coef_groups)) {
groups <- attributes(x)$coef_groups
}
# rename random effect parameters names for stan models
if (isTRUE(random_variances) && any(c("brmsfit", "stanreg", "stanmvreg") %in% m_class)) {
x <- .format_stan_parameters(x)
}
# for the current HTML backend we use (package "gt"), we cannot change
# the column header for subtables, so we need to remove the attributes
# for the "Coefficient" column here, which else allows us to use different
# column labels for subtables by model components
if (identical(format, "html")) {
coef_name <- NULL
coef_name2 <- NULL
attr(x, "coefficient_name") <- NULL
attr(x, "coefficient_name2") <- NULL
attr(x, "zi_coefficient_name") <- NULL
}
# remove method columns for htest and friends - this should be printed as footer
if (!is.null(m_class) &&
any(m_class %in% c(
"BFBayesFactor", "htest", "rma", "t1way", "yuen",
"PMCMR", "osrt", "trendPMCMR", "anova", "afex_aov"
))) {
x$Method <- NULL
x$Alternative <- NULL
}
# remove response for mvord
if (!is.null(m_class) && any(m_class == "mvord")) {
x$Response <- NULL
}
# remove component for nestedLogit
if (!is.null(m_class) && any(m_class == "nestedLogit")) {
x$Component <- NULL
if (insight::n_unique(x$Response) == 1) {
x$Response <- NULL
}
}
# remove type for comparisons()
if (!is.null(m_class) && any(m_class == "comparisons")) {
x$Type <- NULL
}
# rename columns for t-tests
if (!is.null(htest_type) &&
htest_type == "ttest" &&
!is.null(mean_group_values) &&
all(c("Mean_Group1", "Mean_Group2") %in% colnames(x))) {
colnames(x)[which(colnames(x) == "Mean_Group1")] <- paste0(x$Group, " = ", mean_group_values[1])
colnames(x)[which(colnames(x) == "Mean_Group2")] <- paste0(x$Group, " = ", mean_group_values[2])
}
# Special print for mcp from WRS2
if (!is.null(m_class) && any(m_class %in% c("mcp1", "mcp2"))) {
x$Group1 <- paste(x$Group1, x$Group2, sep = " vs. ")
x$Group2 <- NULL
colnames(x)[1] <- "Group"
}
# check if we have mixed models with random variance parameters
# in such cases, we don't need the group-column, but we rather
# merge it with the parameter column
if (isTRUE(random_variances)) {
x <- .format_ranef_parameters(x)
}
# group parameters - this function find those parameters that should be
# grouped, reorders parameters into groups and indents lines that belong
# to one group, adding a header for each group
if (!is.null(groups)) {
x <- .parameter_groups(x, groups)
}
indent_groups <- attributes(x)$indent_groups
indent_rows <- attributes(x)$indent_rows
# prepare output, to have in shape for printing. this function removes
# empty columns, or selects only those columns that should be printed
x <- .prepare_x_for_print(x, select, coef_name, s_value)
# check whether to split table by certain factors/columns (like component, response...)
split_by <- .prepare_splitby_for_print(x)
# add p-stars, if we need this for style-argument
if (!is.null(style) && grepl("{stars}", style, fixed = TRUE)) {
x$p_stars <- insight::format_p(x[["p"]], stars = TRUE, stars_only = TRUE)
}
# format everything now...
if (split_components && !is.null(split_by) && length(split_by)) {
# this function mainly sets the appropriate column names for each
# "sub table" (i.e. we print a table for each model component, like count,
# zero-inflation, smooth, random, ...) and formats some parameter labels.
# moreover, insight::format_table() is called to do the final formatting
# and .format_model_component_header() is called to set captions for each
# "sub table".
formatted_table <- .format_columns_multiple_components(
x,
pretty_names,
split_column = split_by,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
coef_column = coef_name,
format = format,
ci_width = ci_width,
ci_brackets = ci_brackets,
zap_small = zap_small,
include_reference = include_reference,
...
)
} else {
# for tables that don't have multiple components, formatting is rather
# easy, since we don't need to split the data frame into "sub tables"
formatted_table <- .format_columns_single_component(
x,
pretty_names = pretty_names,
digits = digits,
ci_width = ci_width,
ci_brackets = ci_brackets,
ci_digits = ci_digits,
p_digits = p_digits,
format = format,
coef_name = coef_name,
zap_small = zap_small,
include_reference = include_reference,
...
)
}
# remove unique columns
if (insight::n_unique(formatted_table$Component) == 1) formatted_table$Component <- NULL
if (insight::n_unique(formatted_table$Effects) == 1) formatted_table$Effects <- NULL
if (insight::n_unique(formatted_table$Group) == 1 && isTRUE(mixed_model)) formatted_table$Group <- NULL
# no column with CI-level in output
if (!is.null(formatted_table$CI) && insight::n_unique(formatted_table$CI) == 1) {
formatted_table$CI <- NULL
}
# we also allow style-argument for model parameters. In this case, we need
# some small preparation, namely, we need the p_stars column, and we need
# to "split" the formatted table, because the glue-function needs the columns
# without the parameters-column.
if (!is.null(style)) {
if (is.data.frame(formatted_table)) {
formatted_table <- .style_formatted_table(
formatted_table,
style = style,
format = format
)
} else {
formatted_table[] <- lapply(
formatted_table,
.style_formatted_table,
style = style,
format = format
)
}
}
if (!is.null(indent_rows)) {
attr(formatted_table, "indent_rows") <- indent_rows
attr(formatted_table, "indent_groups") <- NULL
} else if (!is.null(indent_groups)) {
attr(formatted_table, "indent_groups") <- indent_groups
}
# vertical layout possible, if these have just one row
if (identical(list(...)$layout, "vertical")) {
if ("Parameter" %in% colnames(formatted_table)) {
new_colnames <- c("", formatted_table$Parameter)
formatted_table$Parameter <- NULL
} else {
new_colnames <- c("Type", paste0("Value ", seq_len(nrow(formatted_table))))
}
formatted_table <- datawizard::rownames_as_column(as.data.frame(t(formatted_table)), "Type")
colnames(formatted_table) <- new_colnames
}
formatted_table
}
#' @export
format.parameters_simulate <- format.parameters_model
#' @export
format.parameters_brms_meta <- format.parameters_model
#' @export
format.parameters_coef <- function(x, format = NULL, ...) {
insight::format_table(x, format = format, ...)
}
# Compare parameters ----------------------
#' @rdname print.compare_parameters
#' @inheritParams print.parameters_model
#' @export
format.compare_parameters <- function(x,
split_components = TRUE,
select = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
ci_width = NULL,
ci_brackets = NULL,
zap_small = FALSE,
format = NULL,
groups = NULL,
engine = NULL,
...) {
m_class <- attributes(x)$model_class
x$Method <- NULL
# remove response for mvord
if (!is.null(m_class) && any(m_class == "mvord")) {
x$Response <- NULL
}
out <- data.frame(
Parameter = x$Parameter,
Effects = x$Effects,
Component = x$Component,
stringsAsFactors = FALSE
)
# remove zi-suffix if we split components anyway
if (isTRUE(split_components)) {
out$Parameter <- insight::trim_ws(gsub(" (zi)", "", out$Parameter, fixed = TRUE))
out$Effects <- NULL
}
# save model names
models <- attributes(x)$model_names
# save model parameters attributes
parameters_attributes <- attributes(x)$all_attributes
# is information about grouped parameters stored as attribute?
if (is.null(groups) && !is.null(parameters_attributes[[1]]$coef_groups)) {
groups <- parameters_attributes[[1]]$coef_groups
}
# locate random effects rows
ran_pars <- which(x$Effects == "random")
# find all random effect groups
if (is.null(x$Group)) {
ran_groups <- NULL
ran_group_rows <- NULL
} else {
ran_groups <- unique(insight::compact_character(x$Group))
ran_group_rows <- which(nzchar(x$Group, keepNA = TRUE))
}
for (i in models) {
# each column is suffixed with ".model_name", so we extract
# columns for each model separately here
pattern <- paste0("\\.\\Q", i, "\\E$")
cols <- x[grepl(pattern, colnames(x))]
# since we now have the columns for a single model, we clean the
# column names (i.e. remove suffix), so we can use "format_table" function
colnames(cols) <- gsub(pattern, "", colnames(cols))
# find coefficient column, check which rows have non-NA values
# since we merged all models together, and we only have model-specific
# columns for estimates, CI etc. but not for Effects and Component, we
# extract "valid" rows via non-NA values in the coefficient column
coef_column <- which(colnames(cols) %in% c(.all_coefficient_types, "Coefficient"))
valid_rows <- which(!is.na(cols[[coef_column]]))
# check if we have mixed models with random variance parameters
# in such cases, we don't need the group-column, but we rather
# merge it with the parameter column
ran_pars_rows <- NULL
if (length(ran_pars) && length(ran_group_rows) && any(ran_group_rows %in% valid_rows)) {
# ran_pars has row indices for *all* models in this function -
# make sure we have only valid rows for this particular model
ran_pars_rows <- intersect(valid_rows, intersect(ran_pars, ran_group_rows))
}
if (!is.null(ran_pars_rows) && length(ran_pars_rows)) {
# find SD random parameters
stddevs <- startsWith(out$Parameter[ran_pars_rows], "SD (")
# check if we already fixed that name in a previous loop
fixed_name <- unlist(lapply(
ran_groups,
grep,
x = out$Parameter[ran_pars_rows[stddevs]],
fixed = TRUE
))
if (length(fixed_name)) {
stddevs[fixed_name] <- FALSE
}
# collapse parameter name with RE grouping factor
if (length(stddevs)) {
out$Parameter[ran_pars_rows[stddevs]] <- paste0(
gsub("(.*)\\)", "\\1", out$Parameter[ran_pars_rows[stddevs]]),
": ",
x$Group[ran_pars_rows[stddevs]],
")"
)
}
# same for correlations
corrs <- startsWith(out$Parameter[ran_pars_rows], "Cor (")
# check if we already fixed that name in a previous loop
fixed_name <- unlist(lapply(
ran_groups,
grep,
x = out$Parameter[ran_pars_rows[corrs]],
fixed = TRUE
))
if (length(fixed_name)) {
corrs[fixed_name] <- FALSE
}
# collapse parameter name with RE grouping factor
if (length(corrs)) {
out$Parameter[ran_pars_rows[corrs]] <- paste0(
gsub("(.*)\\)", "\\1", out$Parameter[ran_pars_rows[corrs]]),
": ",
x$Group[ran_pars_rows[corrs]],
")"
)
}
out$Parameter[out$Parameter == "SD (Observations: Residual)"] <- "SD (Residual)"
}
# save p-stars in extra column
cols$p_stars <- insight::format_p(cols$p, stars = TRUE, stars_only = TRUE)
cols <- insight::format_table(
cols,
digits = digits,
ci_width = ci_width,
ci_brackets = ci_brackets,
ci_digits = ci_digits,
p_digits = p_digits,
zap_small = zap_small,
...
)
out <- cbind(out, .format_output_style(cols, style = select, format, i))
}
# remove group column
out$Group <- NULL
x$Group <- NULL
# sort by effects and component
if (isFALSE(split_components)) {
out <- datawizard::data_arrange(out, c("Effects", "Component"))
}
# group parameters - this function find those parameters that should be
# grouped, reorders parameters into groups and indents lines that belong
# to one group, adding a header for each group
if (!is.null(groups) && !identical(engine, "tt")) {
out <- .parameter_groups(out, groups)
}
indent_groups <- attributes(x)$indent_groups
indent_rows <- attributes(x)$indent_rows
# check whether to split table by certain factors/columns (like component, response...)
split_by <- split_column <- .prepare_splitby_for_print(x)
if (length(split_by) > 0L && isTRUE(split_components)) {
# set up split-factor
if (length(split_column) > 1L) {
split_by <- lapply(split_column, function(i) x[[i]])
} else {
split_by <- list(x[[split_column]])
}
names(split_by) <- split_column
# make sure we have correct sorting here...
formatted_table <- split(out, f = split_by)
formatted_table <- lapply(names(formatted_table), function(tab) {
i <- formatted_table[[tab]]
# check if data frame is empty - this may happen if not all combinations
# of split_by factors are present in the data (e.g., zero-inflated mixed
# models, that have random effects for the count, but not for the zero-
# inflation component)
if (nrow(i) == 0L) {
return(NULL)
}
# remove unique columns
if (insight::n_unique(i$Component) == 1L) i$Component <- NULL
if (insight::n_unique(i$Effects) == 1L) i$Effects <- NULL
# format table captions for sub tables
table_caption <- .format_model_component_header(
x,
type = tab, split_column = tab, is_zero_inflated = FALSE,
is_ordinal_model = FALSE, is_multivariate = FALSE, ran_pars = FALSE,
formatted_table = i
)
# add as attribute, so table captions are printed
if (identical(format, "html")) {
i$Component <- table_caption$name
} else if (identical(format, "md") || identical(format, "markdown")) {
attr(i, "table_caption") <- table_caption$name
} else {
attr(i, "table_caption") <- c(paste("#", table_caption$name), "blue")
}
i
})
# remove empty tables
formatted_table <- insight::compact_list(formatted_table)
# for HTML, bind data frames
if (identical(format, "html")) {
# fix non-equal length of columns and bind data frames
formatted_table <- do.call(rbind, .fix_nonmatching_columns(formatted_table))
}
} else {
formatted_table <- out
# remove unique columns
if (insight::n_unique(formatted_table$Component) == 1L) formatted_table$Component <- NULL
if (insight::n_unique(formatted_table$Effects) == 1L) formatted_table$Effects <- NULL
# add line with info about observations
formatted_table <- .add_obs_row(formatted_table, parameters_attributes, style = select)
}
formatted_table
}
# sem-models ---------------------------------
#' @export
format.parameters_sem <- function(x,
digits = 2,
ci_digits = digits,
p_digits = 3,
format = NULL,
ci_width = NULL,
ci_brackets = TRUE,
pretty_names = TRUE,
...) {
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", 2)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", 3)
}
.format_columns_multiple_components(
x,
pretty_names = TRUE,
split_column = "Component",
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
format = format,
ci_width = ci_width,
ci_brackets = ci_brackets,
...
)
}
# helper ---------------------
.style_formatted_table <- function(formtab, style, format) {
additional_columns <- intersect(c("Effects", "Group", "Component"), colnames(formtab))
if (length(additional_columns)) {
additional_columns <- formtab[additional_columns]
}
# define column names in case the glue-pattern has multiple columns.
if (grepl("|", style, fixed = TRUE)) {
cn <- NULL
} else {
cn <- .style_pattern_to_name(style)
}
formtab <- cbind(
formtab[1],
.format_output_style(
formtab[2:ncol(formtab)],
style = style,
format = format,
modelname = cn
)
)
if (!insight::is_empty_object(additional_columns)) {
formtab <- cbind(formtab, additional_columns)
}
formtab
}
# footer functions ------------------
.format_footer <- function(x,
digits = 3,
verbose = TRUE,
show_sigma = FALSE,
show_formula = FALSE,
show_r2 = FALSE,
show_rmse = FALSE,
format = "text") {
# prepare footer
footer <- NULL
type <- tolower(format)
sigma_value <- attributes(x)$sigma
r2 <- attributes(x)$r2
rmse <- attributes(x)$rmse
residual_df <- attributes(x)$residual_df
p_adjust <- attributes(x)$p_adjust
model_formula <- attributes(x)$model_formula
anova_test <- attributes(x)$anova_test
anova_type <- attributes(x)$anova_type
prediction_type <- attributes(x)$prediction_type
footer_text <- attributes(x)$footer_text
text_alternative <- attributes(x)$text_alternative
n_obs <- attributes(x)$n_obs
is_ggeffects <- isTRUE(attributes(x)$is_ggeffects)
# footer: model formula
if (isTRUE(show_formula)) {
footer <- .add_footer_formula(footer, model_formula, n_obs, type)
}
# footer: residual standard deviation
if (isTRUE(show_sigma)) {
footer <- .add_footer_sigma(footer, digits, sigma_value, residual_df, type)
}
# footer: r-squared
if (isTRUE(show_rmse)) {
footer <- .add_footer_values(footer, digits, value = rmse, text = "RMSE ", type)
}
# footer: r-squared
if (isTRUE(show_r2)) {
footer <- .add_footer_r2(footer, digits, r2, type)
}
# footer: p-adjustment
if ("p" %in% colnames(x) && isTRUE(verbose) && !is.null(p_adjust) && p_adjust != "none") {
footer <- .add_footer_text(footer, text = paste("p-value adjustment method:", format_p_adjust(p_adjust)))
}
# footer: anova test
if (!is.null(anova_test)) {
footer <- .add_footer_text(footer, text = sprintf("%s test statistic", anova_test))
}
# footer: anova type
if (!is.null(anova_type)) {
footer <- .add_footer_text(footer, text = sprintf("Anova Table (Type %s tests)", anova_type))
}
# footer: marginaleffects::comparisons()
if (!is.null(prediction_type)) {
footer <- .add_footer_text(footer, text = sprintf("Prediction type: %s", prediction_type))
}
# footer: htest alternative
if (!is.null(text_alternative)) {
footer <- .add_footer_text(footer, text = text_alternative)
}
# footer: generic text
if (!is.null(footer_text)) {
footer <- .add_footer_text(footer, footer_text, type, is_ggeffects)
}
# if we have two trailing newlines, remove one
if (identical(type, "text") && !is.null(footer) && endsWith(footer[1], "\n\n")) {
footer[1] <- substr(footer[1], 0, nchar(x) - 1)
}
# finally, for ggeffects and HTML, remove *
if (is_ggeffects && type == "html") {
footer <- gsub("*", "", footer, fixed = TRUE)
footer <- gsub(":;", ":", footer, fixed = TRUE)
}
footer
}
# footer: generic text
.add_footer_text <- function(footer = NULL, text = NULL, type = "text", is_ggeffects = FALSE) {
if (!is.null(text) && length(text)) {
if (type == "text" || type == "markdown") {
if (is.null(footer)) {
fill <- "\n"
} else {
fill <- ""
}
footer <- paste0(footer, sprintf("%s%s\n", fill, text))
} else if (type == "html") {
replacement <- ifelse(is_ggeffects, ";", "")
footer <- c(footer, gsub("\n", replacement, text, fixed = TRUE))
}
}
footer
}
# footer: generic values
.add_footer_values <- function(footer = NULL,
digits = 3,
value = NULL,
text = NULL,
type = "text") {
if (!is.null(value) && !is.null(text)) {
string <- sprintf("%s: %s", text, insight::format_value(value, digits = digits))
if (type == "text" || type == "markdown") {
if (is.null(footer)) {
fill <- "\n"
} else {
fill <- ""
}
footer <- paste0(footer, fill, string, "\n")
} else if (type == "html") {
footer <- c(footer, string)
}
}
footer
}
# footer: residual standard deviation
.add_footer_sigma <- function(footer = NULL, digits = 3, sigma = NULL, residual_df = NULL, type = "text") {
if (!is.null(sigma)) {
# format residual df
if (is.null(residual_df)) {
res_df <- ""
} else {
res_df <- paste0(" (df = ", residual_df, ")")
}
if (type == "text" || type == "markdown") {
if (is.null(footer)) {
fill <- "\n"
} else {
fill <- ""
}
footer <- paste0(footer, sprintf("%sSigma: %.*f%s\n", fill, digits, sigma, res_df))
} else if (type == "html") {
footer <- c(footer, insight::trim_ws(sprintf("Sigma: %.*f%s", digits, sigma, res_df)))
}
}
footer
}
# footer: r-squared
.add_footer_r2 <- function(footer = NULL, digits = 3, r2 = NULL, type = "text") {
if (!is.null(r2)) {
rsq <- .safe(paste(unlist(lapply(r2, function(i) {
paste0(attributes(i)$names, ": ", insight::format_value(i, digits = digits))
})), collapse = "; "))
if (!is.null(rsq)) {
if (type == "text" || type == "markdown") {
if (is.null(footer)) {
fill <- "\n"
} else {
fill <- ""
}
footer <- paste0(footer, fill, rsq, "\n")
} else if (type == "html") {
footer <- c(footer, rsq)
}
}
}
footer
}
# footer: model formula
.add_footer_formula <- function(footer = NULL, model_formula = NULL, n_obs = NULL, type = "text") {
if (!is.null(model_formula)) {
# format n of observations
if (is.null(n_obs)) {
n <- ""
} else {
n <- paste0(" (", n_obs, " Observations)")
}
if (type == "text" || type == "markdown") {
if (is.null(footer)) {
fill <- "\n"
} else {
fill <- ""
}
footer <- paste0(footer, fill, "Model: ", model_formula, n, "\n")
} else if (type == "html") {
footer <- c(footer, insight::trim_ws(paste0("Model: ", model_formula, n)))
}
}
footer
}
# footer: type of uncertainty interval
.print_footer_cimethod <- function(x) {
if (isTRUE(getOption("parameters_cimethod", TRUE))) {
# get attributes
ci_method <- .additional_arguments(x, "ci_method", NULL)
test_statistic <- .additional_arguments(x, "test_statistic", NULL)
bootstrap <- .additional_arguments(x, "bootstrap", FALSE)
is_bayesian <- .additional_arguments(x, "is_bayesian", FALSE)
simulated <- .additional_arguments(x, "simulated", FALSE)
residual_df <- .additional_arguments(x, "residual_df", NULL)
random_variances <- .additional_arguments(x, "ran_pars", FALSE)
model_class <- .additional_arguments(x, "model_class", NULL)
# prepare strings
if (!is.null(ci_method)) {
# only random effects? no message for fixed effects ci-approximation
if (!is.null(x$Effects) && all(x$Effects == "random")) {
msg <- "\n"
string_method <- ""
# here we have fixed effects only, or fixed and random effects
} else {
# since `.format_ci_method_name()` changes the CI method names to have a
# mix of cases, standardize them by converting to lower case
ci_method <- tolower(ci_method)
# in case of glm's that have df.residual(), and where residual df where requested
is_test_statistic_t <- ci_method == "residual" &&
test_statistic == "z-statistic" &&
!is.null(residual_df) &&
!is.infinite(residual_df) && !is.na(residual_df)
if (is_test_statistic_t) {
test_statistic <- "t-statistic"
}
string_tailed <- switch(ci_method,
hdi = "highest-density",
uniroot = ,
profile = "profile-likelihood",
"equal-tailed"
)
# sampling method
if (isTRUE(bootstrap)) {
sampling_method <- ifelse(isTRUE(.unicode_symbols()), "na\u0131ve bootstrap", "naive bootstrap")
} else if (isTRUE(simulated)) {
sampling_method <- "simulated multivariate normal"
} else {
sampling_method <- "MCMC"
}
string_method <- switch(ci_method,
bci = ,
bcai = "bias-corrected accelerated bootstrap",
si = ,
ci = ,
quantile = ,
eti = ,
hdi = sampling_method,
normal = "Wald normal",
boot = "parametric bootstrap",
"Wald"
)
if (toupper(ci_method) %in% c("KENWARD", "KR", "KENWARD-ROGER", "KENWARD-ROGERS", "SATTERTHWAITE")) {
string_approx <- paste0("with ", format_df_adjust(ci_method, approx_string = "", dof_string = ""), " ")
} else {
string_approx <- ""
}
if (!is.null(test_statistic) && ci_method != "normal" && !isTRUE(bootstrap)) {
string_statistic <- switch(tolower(test_statistic),
`t-statistic` = "t",
`chi-squared statistic` = ,
`z-statistic` = "z",
""
)
string_method <- paste0(string_method, " ", string_statistic, "-")
} else {
string_method <- paste0(string_method, " ")
}
# bootstrapped intervals
if (isTRUE(bootstrap)) {
msg <- paste0("\nUncertainty intervals (", string_tailed, ") are ", string_method, "intervals.")
} else if (isTRUE(is_bayesian)) {
msg <- paste0("\nUncertainty intervals (", string_tailed, ") computed using a ", string_method, "distribution ", string_approx, "approximation.") # nolint
} else {
msg <- paste0("\nUncertainty intervals (", string_tailed, ") and p-values (two-tailed) computed using a ", string_method, "distribution ", string_approx, "approximation.") # nolint
}
}
# do we have random effect variances from lme4/glmmTMB?
# must be glmmTMB
show_re_msg <- (identical(model_class, "glmmTMB") &&
# and not Wald-/normalCIs
(!string_method %in% c("Wald z-", "Wald normal") || !ci_method %in% c("wald", "normal"))) ||
# OR must be merMod
((identical(model_class, "lmerMod") || identical(model_class, "glmerMod")) &&
# and not Wald CIs
!ci_method %in% c("wald", "normal", "profile", "boot"))
if (show_re_msg && isTRUE(random_variances) && !is.null(x$Effects) && "random" %in% x$Effects) {
msg <- paste(msg, "Uncertainty intervals for random effect variances computed using a Wald z-distribution approximation.") # nolint
}
insight::format_alert(insight::color_text(msg, "yellow"))
}
}
}
.print_footer_exp <- function(x) {
# we need this to check whether we have extremely large cofficients
if (isTRUE(getOption("parameters_exponentiate", TRUE))) {
msg <- NULL
# try to find out the name of the coefficient column
coef_column <- intersect(colnames(x), .all_coefficient_names)
if (length(coef_column) && "Parameter" %in% colnames(x)) {
spurious_coefficients <- abs(x[[coef_column[1]]][!.in_intercepts(x$Parameter)])
} else {
spurious_coefficients <- NULL
}
exponentiate <- .additional_arguments(x, "exponentiate", FALSE)
if (!.is_valid_exponentiate_argument(exponentiate)) {
if (isTRUE(.additional_arguments(x, "log_link", FALSE))) {
msg <- "The model has a log- or logit-link. Consider using `exponentiate = TRUE` to interpret coefficients as ratios." # nolint
# we only check for exp(coef), so exp() here since coefficients are on logit-scale
if (!is.null(spurious_coefficients)) {
spurious_coefficients <- exp(spurious_coefficients)
}
} else if (isTRUE(.additional_arguments(x, "log_response", FALSE))) {
msg <- "The model has a log-transformed response variable. Consider using `exponentiate = TRUE` to interpret coefficients as ratios." # nolint
# don't show warning about complete separation
spurious_coefficients <- NULL
}
} else if (.is_valid_exponentiate_argument(exponentiate) && isTRUE(.additional_arguments(x, "log_response", FALSE))) { # nolint
# don't show warning about complete separation
spurious_coefficients <- NULL
}
# following check only for models with logit-link
logit_model <- isTRUE(.additional_arguments(x, "logit_link", FALSE)) ||
isTRUE(attributes(x)$coefficient_name %in% c("Log-Odds", "Odds Ratio"))
# remove NA and infinite values from spurios coefficients
if (!is.null(spurious_coefficients)) {
spurious_coefficients <- spurious_coefficients[!is.na(spurious_coefficients) & !is.infinite(spurious_coefficients)] # nolint
}
# check for complete separation coefficients or possible issues with
# too few data points
if (!is.null(spurious_coefficients) && length(spurious_coefficients) && logit_model) {
if (any(spurious_coefficients > 50)) {
msg <- c(msg, "Some coefficients are very large, which may indicate issues with complete separation.") # nolint
} else if (any(spurious_coefficients > 15)) {
msg <- c(msg, "Some coefficients seem to be rather large, which may indicate issues with (quasi) complete separation. Consider using bias-corrected or penalized regression models.") # nolint
}
}
if (!is.null(msg) && isTRUE(getOption("parameters_warning_exponentiate", TRUE))) {
insight::format_alert(paste0("\n", msg))
# set flag, so message only displayed once per session
options(parameters_warning_exponentiate = FALSE)
}
}
}
parameters/R/methods_cplm.R 0000644 0001762 0000144 00000024526 14761570351 015441 0 ustar ligges users # classes: .cpglm, .bcpglm, .zcpglm, .cpglmm
########## .zcpglm ---------------
#' @title Parameters from Zero-Inflated Models
#' @name model_parameters.zcpglm
#'
#' @description
#' Parameters from zero-inflated models (from packages like **pscl**,
#' **cplm** or **countreg**).
#'
#' @param model A model with zero-inflation component.
#' @inheritParams model_parameters.default
#' @inheritParams simulate_model
#'
#' @seealso [insight::standardize_names()] to rename
#' columns into a consistent, standardized naming scheme.
#'
#' @section Model components:
#' Possible values for the `component` argument depend on the model class.
#' Following are valid options:
#' - `"all"`: returns all model components, applies to all models, but will only
#' have an effect for models with more than just the conditional model component.
#' - `"conditional"`: only returns the conditional component, i.e. "fixed effects"
#' terms from the model. Will only have an effect for models with more than
#' just the conditional model component.
#' - `"smooth_terms"`: returns smooth terms, only applies to GAMs (or similar
#' models that may contain smooth terms).
#' - `"zero_inflated"` (or `"zi"`): returns the zero-inflation component.
#' - `"dispersion"`: returns the dispersion model component. This is common
#' for models with zero-inflation or that can model the dispersion parameter.
#' - `"instruments"`: for instrumental-variable or some fixed effects regression,
#' returns the instruments.
#' - `"nonlinear"`: for non-linear models (like models of class `nlmerMod` or
#' `nls`), returns staring estimates for the nonlinear parameters.
#' - `"correlation"`: for models with correlation-component, like `gls`, the
#' variables used to describe the correlation structure are returned.
#'
#' **Special models**
#'
#' Some model classes also allow rather uncommon options. These are:
#' - **mhurdle**: `"infrequent_purchase"`, `"ip"`, and `"auxiliary"`
#' - **BGGM**: `"correlation"` and `"intercept"`
#' - **BFBayesFactor**, **glmx**: `"extra"`
#' - **averaging**:`"conditional"` and `"full"`
#' - **mjoint**: `"survival"`
#' - **mfx**: `"precision"`, `"marginal"`
#' - **betareg**, **DirichletRegModel**: `"precision"`
#' - **mvord**: `"thresholds"` and `"correlation"`
#' - **clm2**: `"scale"`
#' - **selection**: `"selection"`, `"outcome"`, and `"auxiliary"`
#' - **lavaan**: One or more of `"regression"`, `"correlation"`, `"loading"`,
#' `"variance"`, `"defined"`, or `"mean"`. Can also be `"all"` to include
#' all components.
#'
#' For models of class `brmsfit` (package **brms**), even more options are
#' possible for the `component` argument, which are not all documented in detail
#' here.
#'
#' @examplesIf require("pscl")
#' data("bioChemists", package = "pscl")
#' model <- pscl::zeroinfl(
#' art ~ fem + mar + kid5 + ment | kid5 + phd,
#' data = bioChemists
#' )
#' model_parameters(model)
#' @return A data frame of indices related to the model's parameters.
#' @export
model_parameters.zcpglm <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "all",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(component, c("all", "conditional", "zi", "zero_inflated"))
# fix argument, if model has no zi-part
if (!insight::model_info(model, verbose = FALSE)$is_zero_inflated && component != "conditional") {
component <- "conditional"
}
# Processing
if (bootstrap) {
params <- bootstrap_parameters(model, iterations = iterations, ci = ci, ...)
} else {
params <- .extract_parameters_generic(
model,
ci = ci,
component = component,
standardize = standardize,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
}
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(
params,
model,
ci,
exponentiate,
p_adjust = p_adjust,
include_info = include_info,
verbose = verbose,
...
)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
standard_error.zcpglm <- function(model, component = "all", ...) {
insight::check_if_installed("cplm")
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated")
)
junk <- utils::capture.output(stats <- cplm::summary(model)$coefficients) # nolint
params <- insight::get_parameters(model)
tweedie <- .data_frame(
Parameter = params$Parameter[params$Component == "conditional"],
SE = as.vector(stats$tweedie[, "Std. Error"]),
Component = "conditional"
)
zero <- .data_frame(
Parameter = params$Parameter[params$Component == "zero_inflated"],
SE = as.vector(stats$zero[, "Std. Error"]),
Component = "zero_inflated"
)
out <- .filter_component(rbind(tweedie, zero), component)
out
}
#' @export
p_value.zcpglm <- function(model, component = "all", ...) {
insight::check_if_installed("cplm")
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated")
)
junk <- utils::capture.output(stats <- cplm::summary(model)$coefficients) # nolint
params <- insight::get_parameters(model)
tweedie <- .data_frame(
Parameter = params$Parameter[params$Component == "conditional"],
p = as.vector(stats$tweedie[, "Pr(>|z|)"]),
Component = "conditional"
)
zero <- .data_frame(
Parameter = params$Parameter[params$Component == "zero_inflated"],
p = as.vector(stats$zero[, "Pr(>|z|)"]),
Component = "zero_inflated"
)
out <- .filter_component(rbind(tweedie, zero), component)
out
}
########## .bcpglm ---------------
#' @export
model_parameters.bcplm <- model_parameters.bayesQR
#' @export
p_value.bcplm <- p_value.brmsfit
########## .cpglm ---------------
#' @export
p_value.cpglm <- function(model, ...) {
insight::check_if_installed("cplm")
junk <- utils::capture.output(stats <- cplm::summary(model)$coefficients) # nolint
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
p = as.vector(stats[, "Pr(>|t|)"])
)
}
#' @export
standard_error.cpglm <- function(model, ...) {
insight::check_if_installed("cplm")
junk <- utils::capture.output(stats <- cplm::summary(model)$coefficients) # nolint
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
SE = as.vector(stats[, "Std. Error"])
)
}
########## .cpglmm ---------------
#' @export
model_parameters.cpglmm <- function(model,
ci = 0.95,
ci_method = NULL,
ci_random = NULL,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
effects = "all",
group_level = FALSE,
exponentiate = FALSE,
p_adjust = NULL,
include_sigma = FALSE,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# p-values, CI and se might be based on different df-methods
ci_method <- .check_df_method(ci_method)
effects <- insight::validate_argument(effects, c("fixed", "random", "all"))
# standardize only works for fixed effects...
if (!is.null(standardize) && standardize != "refit") {
if (!missing(effects) && effects != "fixed" && verbose) {
insight::format_alert("Standardizing coefficients only works for fixed effects of the mixed model.")
}
effects <- "fixed"
}
params <- .mixed_model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = "Parameter",
standardize = standardize,
exponentiate = exponentiate,
effects = effects,
p_adjust = p_adjust,
group_level = group_level,
ci_method = ci_method,
include_sigma = include_sigma,
ci_random = ci_random,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", "data.frame")
params
}
#' @export
p_value.cpglmm <- function(model, method = "wald", ...) {
p_value.default(model, method = method, ...)
}
#' @export
standard_error.cpglmm <- function(model, ...) {
insight::check_if_installed("cplm")
stats <- cplm::summary(model)$coefs
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
SE = as.vector(stats[, "Std. Error"])
)
}
# tools --------------------
.check_df_method <- function(df_method) {
if (!is.null(df_method)) {
df_method <- tolower(df_method)
if (df_method %in% c("satterthwaite", "kenward", "kr")) {
insight::format_alert("Satterthwaite or Kenward-Rogers approximation of degrees of freedom is only available for linear mixed models.")
df_method <- "wald"
}
df_method <- insight::validate_argument(
df_method,
c(
"wald", "normal", "residual", "ml1", "betwithin", "profile",
"boot", "uniroot"
)
)
}
df_method
}
parameters/R/n_parameters.R 0000644 0001762 0000144 00000000110 14037763760 015426 0 ustar ligges users #' @importFrom insight n_parameters
#' @export
insight::n_parameters
parameters/R/methods_BayesFM.R 0000644 0001762 0000144 00000011073 14736731407 015770 0 ustar ligges users #' Parameters from Bayesian Exploratory Factor Analysis
#'
#' Format Bayesian Exploratory Factor Analysis objects from the BayesFM package.
#'
#' @param model Bayesian EFA created by the `BayesFM::befa`.
#' @inheritParams principal_components
#' @inheritParams bayestestR::describe_posterior
#' @inheritParams model_parameters.default
#' @param ... Arguments passed to or from other methods.
#'
#' @examples
#' library(parameters)
#' \donttest{
#' if (require("BayesFM")) {
#' efa <- BayesFM::befa(mtcars, iter = 1000)
#' results <- model_parameters(efa, sort = TRUE, verbose = FALSE)
#' results
#' efa_to_cfa(results, verbose = FALSE)
#' }
#' }
#' @return A data frame of loadings.
#' @export
model_parameters.befa <- function(model,
sort = FALSE,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = NULL,
verbose = TRUE,
...) {
if (!attr(model, "post.column.switch") || !attr(model, "post.sign.switch")) {
insight::check_if_installed("BayesFM")
if (!attr(model, "post.column.switch")) model <- BayesFM::post.column.switch(model)
if (!attr(model, "post.sign.switch")) model <- BayesFM::post.sign.switch(model)
}
factor_loadings <- as.data.frame(model$alpha)
names(factor_loadings) <- gsub("alpha:", "", names(factor_loadings), fixed = TRUE)
factor_loadings <- stats::reshape(
factor_loadings,
direction = "long",
varying = list(names(factor_loadings)),
sep = "_",
timevar = "Variable",
v.names = "Loading",
idvar = "Draw",
times = names(factor_loadings)
)
components <- as.data.frame(model$dedic)
names(components) <- gsub("dedic:", "", names(components), fixed = TRUE)
components <- stats::reshape(
components,
direction = "long",
varying = list(names(components)),
sep = "_",
timevar = "Variable",
v.names = "Component",
idvar = "Draw",
times = names(components)
)
factor_loadings <- merge(components, factor_loadings)
# Compute posterior by dedic
long_loadings <- data.frame()
for (var in unique(factor_loadings$Variable)) {
for (comp in unique(factor_loadings$Component)) {
chunk <- factor_loadings[factor_loadings$Variable == var & factor_loadings$Component == comp, ] # nolint
if (nrow(chunk) == 0) {
rez <-
bayestestR::describe_posterior(
factor_loadings$Loading,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
verbose = verbose,
...
)
rez[1, ] <- NA
} else {
rez <-
bayestestR::describe_posterior(
chunk$Loading,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
verbose = verbose,
...
)
}
long_loadings <- rbind(
long_loadings,
cbind(data.frame(Component = comp, Variable = var), rez)
)
}
}
long_loadings$Component <- paste0("F", long_loadings$Component)
# Clean
long_loadings$Parameter <- NULL
if ("CI" %in% names(long_loadings) && insight::n_unique(long_loadings$CI) == 1) {
long_loadings$CI <- NULL
}
long_loadings <- long_loadings[long_loadings$Component != 0, ]
factor_loadings <- .wide_loadings(
long_loadings,
loadings_columns = names(long_loadings)[3],
component_column = "Component",
variable_column = "Variable"
)
# Add attributes
attr(factor_loadings, "model") <- model
attr(factor_loadings, "additional_arguments") <- list(...)
attr(factor_loadings, "n") <- insight::n_unique(long_loadings$Component)
attr(factor_loadings, "loadings_columns") <- names(factor_loadings)[2:ncol(factor_loadings)]
attr(factor_loadings, "ci") <- ci
# Sorting
if (isTRUE(sort)) {
factor_loadings <- .sort_loadings(factor_loadings)
}
# Add some more attributes
long_loadings <- stats::na.omit(long_loadings)
row.names(long_loadings) <- NULL
attr(factor_loadings, "loadings_long") <- long_loadings
# add class-attribute for printing
class(factor_loadings) <- c("parameters_efa", class(factor_loadings))
factor_loadings
}
parameters/R/plot.R 0000644 0001762 0000144 00000002751 14351060774 013733 0 ustar ligges users #' @export
plot.parameters_sem <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.parameters_model <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.compare_parameters <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.parameters_simulate <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.parameters_brms_meta <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.n_factors <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.parameters_distribution <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.n_clusters <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.parameters_pca <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @export
plot.parameters_efa <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
#' @importFrom graphics plot
#' @export
plot.cluster_analysis <- function(x, ...) {
insight::check_if_installed("see")
plot(datawizard::visualisation_recipe(x, ...))
}
#' @export
plot.cluster_analysis_summary <- function(x, ...) {
insight::check_if_installed("see")
plot(datawizard::visualisation_recipe(x, ...))
}
parameters/R/methods_fixest.R 0000644 0001762 0000144 00000015562 14761570351 016010 0 ustar ligges users # .fixest -----------------------
#' @export
model_parameters.fixest <- function(model,
ci = 0.95,
ci_method = NULL,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
vcov = NULL,
vcov_args = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# default ci-method, based on statistic
if (is.null(ci_method)) {
if (identical(insight::find_statistic(model), "t-statistic")) {
ci_method <- "wald"
} else {
ci_method <- "normal"
}
}
# extract model parameters table, as data frame
out <- .model_parameters_generic(
model = model,
ci = ci,
ci_method = ci_method,
bootstrap = bootstrap,
iterations = iterations,
merge_by = "Parameter",
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
include_info = include_info,
keep_parameters = keep,
drop_parameters = drop,
vcov = vcov,
vcov_args = vcov_args,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.fixest <- function(model, vcov = NULL, vcov_args = NULL, ...) {
params <- insight::get_parameters(model)
if (is.null(vcov)) {
# get standard errors from summary
# see https://github.com/easystats/parameters/issues/1039
stats <- summary(model)
SE <- stats$coeftable[, "Std. Error"]
} else {
# we don't want to wrap this in a tryCatch because the `fixest` error is
# informative when `vcov` is wrong.
V <- insight::get_varcov(model, vcov = vcov, vcov_args = vcov_args)
SE <- sqrt(diag(V))
}
# remove .theta parameter
if (".theta" %in% names(SE)) {
SE <- SE[names(SE) != ".theta"]
}
.data_frame(
Parameter = params$Parameter,
SE = as.vector(SE)
)
}
# .feglm -----------------------
#' @export
model_parameters.feglm <- model_parameters.fixest
#' @export
standard_error.feglm <- function(model, ...) {
stats <- stats::coef(summary(model))
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
SE = as.vector(stats[, "Std. error"])
)
}
## TODO add ci_method later?
#' @export
p_value.feglm <- function(model, ...) {
stats <- stats::coef(summary(model))
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
p = as.vector(stats[, 4])
)
}
# .fixest_multi -----------------------------------
#' @export
model_parameters.fixest_multi <- function(model,
ci = 0.95,
ci_method = NULL,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
vcov = NULL,
vcov_args = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# iterate over responses
out <- lapply(
model,
model_parameters.default,
ci = ci,
ci_method = ci_method,
bootstrap = bootstrap,
iterations = iterations,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
include_info = include_info,
keep = keep,
drop = drop,
verbose = verbose,
vcov = vcov,
vcov_args = vcov_args,
...
)
# bind lists together to one data frame, save attributes
att <- attributes(out[[1]])
params <- do.call(rbind, out)
# add response and group columns
id_columns <- .get_fixest_multi_columns(model)
params$Response <- id_columns$Response
params$Group <- id_columns$Group
attributes(params) <- utils::modifyList(att, attributes(params))
attr(params, "model_class") <- "fixest_multi"
params
}
#' @export
ci.fixest_multi <- function(x, ...) {
out <- do.call(rbind, lapply(x, ci, ...))
# add response and group columns
id_columns <- .get_fixest_multi_columns(x)
# add response column
out$Response <- id_columns$Response
out$Group <- id_columns$Group
row.names(out) <- NULL
out
}
#' @export
standard_error.fixest_multi <- function(model, ...) {
out <- do.call(rbind, lapply(model, standard_error, ...))
# add response and group columns
id_columns <- .get_fixest_multi_columns(model)
# add response column
out$Response <- id_columns$Response
out$Group <- id_columns$Group
row.names(out) <- NULL
out
}
#' @export
p_value.fixest_multi <- function(model, ...) {
out <- do.call(rbind, lapply(model, p_value, ...))
# add response and group columns
id_columns <- .get_fixest_multi_columns(model)
# add response column
out$Response <- id_columns$Response
out$Group <- id_columns$Group
row.names(out) <- NULL
out
}
#' @export
simulate_model.fixest_multi <- function(model, ...) {
lapply(model, simulate_model, ...)
}
# helper ---------------------------------
.get_fixest_multi_columns <- function(model) {
# add response and group columns
s <- summary(model)
l <- lengths(lapply(s, stats::coef))
parts <- strsplit(names(l), ";", fixed = TRUE)
id_columns <- Map(function(i, j) {
if (length(j) == 1 && startsWith(j, "rhs")) {
data.frame(
Group = rep(insight::trim_ws(sub("rhs:", "", j, fixed = TRUE)), i),
stringsAsFactors = FALSE
)
} else if (length(j) == 1 && startsWith(j, "lhs")) {
data.frame(
Response = rep(insight::trim_ws(sub("lhs:", "", j, fixed = TRUE)), i),
stringsAsFactors = FALSE
)
} else {
data.frame(
Response = rep(insight::trim_ws(sub("lhs:", "", j[1], fixed = TRUE)), i),
Group = rep(insight::trim_ws(sub("rhs:", "", j[2], fixed = TRUE)), i),
stringsAsFactors = FALSE
)
}
}, unname(l), parts)
do.call(rbind, id_columns)
}
parameters/R/p_direction.R 0000644 0001762 0000144 00000013714 14716604200 015246 0 ustar ligges users #' @importFrom bayestestR p_direction
#' @export
bayestestR::p_direction
#' @title Probability of Direction (pd)
#' @name p_direction.lm
#'
#' @description Compute the **Probability of Direction** (*pd*, also known as
#' the Maximum Probability of Effect - *MPE*). This can be interpreted as the
#' probability that a parameter (described by its full confidence, or
#' "compatibility" interval) is strictly positive or negative (whichever is the
#' most probable). Although differently expressed, this index is fairly similar
#' (i.e., is strongly correlated) to the frequentist *p-value* (see 'Details').
#'
#' @param x A statistical model.
#' @inheritParams bayestestR::p_direction
#' @inheritParams model_parameters.default
#' @param ... Arguments passed to other methods, e.g. `ci()`. Arguments like
#' `vcov` or `vcov_args` can be used to compute confidence intervals using a
#' specific variance-covariance matrix for the standard errors.
#'
#' @seealso See also [`equivalence_test()`], [`p_function()`] and
#' [`p_significance()`] for functions related to checking effect existence and
#' significance.
#'
#' @inheritSection bayestestR::p_direction What is the *pd*?
#'
#' @inheritSection bayestestR::p_direction Relationship with the p-value
#'
#' @inheritSection bayestestR::p_direction Possible Range of Values
#'
#' @inheritSection model_parameters Statistical inference - how to quantify evidence
#'
#' @references
#'
#' - Amrhein, V., Korner-Nievergelt, F., and Roth, T. (2017). The earth is
#' flat (p > 0.05): Significance thresholds and the crisis of unreplicable
#' research. PeerJ, 5, e3544. \doi{10.7717/peerj.3544}
#'
#' - Greenland S, Rafi Z, Matthews R, Higgs M. To Aid Scientific Inference,
#' Emphasize Unconditional Compatibility Descriptions of Statistics. (2022)
#' https://arxiv.org/abs/1909.08583v7 (Accessed November 10, 2022)
#'
#' - Lakens, D. (2024). Improving Your Statistical Inferences (Version v1.5.1).
#' Retrieved from https://lakens.github.io/statistical_inferences/.
#' \doi{10.5281/ZENODO.6409077}
#'
#' - Lakens, D., Scheel, A. M., and Isager, P. M. (2018). Equivalence Testing
#' for Psychological Research: A Tutorial. Advances in Methods and Practices
#' in Psychological Science, 1(2), 259–269. \doi{10.1177/2515245918770963}
#'
#' - Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and Lüdecke, D. (2019).
#' Indices of Effect Existence and Significance in the Bayesian Framework.
#' Frontiers in Psychology, 10, 2767. \doi{10.3389/fpsyg.2019.02767}
#'
#' - Rafi Z, Greenland S. Semantic and cognitive tools to aid statistical
#' science: replace confidence and significance by compatibility and surprise.
#' BMC Medical Research Methodology (2020) 20:244.
#'
#' - Schweder T. Confidence is epistemic probability for empirical science.
#' Journal of Statistical Planning and Inference (2018) 195:116–125.
#' \doi{10.1016/j.jspi.2017.09.016}
#'
#' - Schweder T, Hjort NL. Frequentist analogues of priors and posteriors.
#' In Stigum, B. (ed.), Econometrics and the Philosophy of Economics: Theory
#' Data Confrontation in Economics, pp. 285-217. Princeton University Press,
#' Princeton, NJ, 2003
#'
#' - Vos P, Holbert D. Frequentist statistical inference without repeated sampling.
#' Synthese 200, 89 (2022). \doi{10.1007/s11229-022-03560-x}
#'
#' @return A data frame.
#'
#' @examplesIf requireNamespace("bayestestR") && require("see", quietly = TRUE) && requireNamespace("sandwich")
#' data(qol_cancer)
#' model <- lm(QoL ~ time + age + education, data = qol_cancer)
#' p_direction(model)
#'
#' # based on heteroscedasticity-robust standard errors
#' p_direction(model, vcov = "HC3")
#'
#' result <- p_direction(model)
#' plot(result)
#' @export
p_direction.lm <- function(x,
ci = 0.95,
method = "direct",
null = 0,
vcov = NULL,
vcov_args = NULL,
...) {
# generate normal distribution based on CI range
result <- .posterior_ci(x, ci, vcov = vcov, vcov_args = vcov_args, ...)
# copy
out <- result$out
posterior <- result$posterior
# add pd
out$pd <- as.numeric(bayestestR::p_direction(
posterior,
method = method,
null = null,
...
))
# reorder
out <- out[intersect(c("Parameter", "CI", "CI_low", "CI_high", "pd", "Effects", "Component"), colnames(out))]
attr(out, "data") <- posterior
attr(out, "null") <- null
class(out) <- c("p_direction_lm", "p_direction", "see_p_direction", "data.frame")
out
}
# methods ---------------------------------------------------------------------
#' @export
print.p_direction_lm <- function(x, digits = 2, p_digits = 3, ...) {
null <- attributes(x)$null
caption <- sprintf(
"Probability of Direction (null: %s)",
insight::format_value(null, digits = digits, protect_integer = TRUE)
)
x <- insight::format_table(x, digits = digits, p_digits = p_digits)
cat(insight::export_table(x, title = caption, ...))
}
# other classes --------------------------------------------------------------
#' @export
p_direction.glm <- p_direction.lm
#' @export
p_direction.coxph <- p_direction.lm
#' @export
p_direction.svyglm <- p_direction.lm
#' @export
p_direction.glmmTMB <- p_direction.lm
#' @export
p_direction.merMod <- p_direction.lm
#' @export
p_direction.wbm <- p_direction.lm
#' @export
p_direction.lme <- p_direction.lm
#' @export
p_direction.gee <- p_direction.lm
#' @export
p_direction.gls <- p_direction.lm
#' @export
p_direction.feis <- p_direction.lm
#' @export
p_direction.felm <- p_direction.lm
#' @export
p_direction.mixed <- p_direction.lm
#' @export
p_direction.hurdle <- p_direction.lm
#' @export
p_direction.zeroinfl <- p_direction.lm
#' @export
p_direction.rma <- p_direction.lm
parameters/R/methods_stats4.R 0000644 0001762 0000144 00000000227 14507235543 015717 0 ustar ligges users #' @export
ci.mle <- ci.glm
#' @export
standard_error.mle <- standard_error.mle2
#' @export
model_parameters.mle <- model_parameters.glm
parameters/R/methods_glmx.R 0000644 0001762 0000144 00000004451 14736731407 015453 0 ustar ligges users #' @export
model_parameters.glmx <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "all",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(component, c("all", "conditional", "extra"))
if (component == "all") {
merge_by <- c("Parameter", "Component")
} else {
merge_by <- "Parameter"
}
out <- .model_parameters_generic(
model = model,
ci = ci,
component = component,
bootstrap = bootstrap,
iterations = iterations,
merge_by = merge_by,
standardize = standardize,
exponentiate = exponentiate,
keep_parameters = keep,
drop_parameters = drop,
p_adjust = p_adjust,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.glmx <- function(model, ...) {
stats <- stats::coef(summary(model))
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
SE = c(as.vector(stats$glm[, "Std. Error"]), as.vector(stats$extra[, "Std. Error"])),
Component = params$Component
)
}
#' @export
p_value.glmx <- function(model, ...) {
stats <- stats::coef(summary(model))
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
p = c(as.vector(stats$glm[, "Pr(>|z|)"]), as.vector(stats$extra[, "Pr(>|z|)"])),
Component = params$Component
)
}
#' @export
simulate_model.glmx <- function(model, iterations = 1000, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "extra")
)
out <- .simulate_model(model, iterations, component = component, ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
parameters/R/methods_mixed.R 0000644 0001762 0000144 00000000100 14717111737 015572 0 ustar ligges users #' @export
model_parameters.mixed <- model_parameters.glmmTMB
parameters/R/methods_car.R 0000644 0001762 0000144 00000004615 14716604200 015237 0 ustar ligges users #' @export
model_parameters.deltaMethod <- function(model, p_adjust = NULL, verbose = TRUE, ...) {
dots <- list(...)
if ("ci" %in% names(dots)) {
insight::format_warning(
"The `ci` argument is not supported by `model_parameters` for objects of this class. Use the `level` argument of the `deltaMethod` function instead." # nolint
)
dots[["ci"]] <- NULL
}
# tweak column names
params <- insight::standardize_names(datawizard::rownames_as_column(model, "Parameter"))
# find CIs
ci_cols <- endsWith(colnames(params), "%")
cis <- as.numeric(gsub("%", "", colnames(params)[ci_cols], fixed = TRUE)) / 100
ci <- diff(cis)
# rename CI columns
colnames(params)[ci_cols] <- c("CI_low", "CI_high")
# check if statistic is available
if (is.null(params$Statistic)) {
params <- merge(params, insight::get_statistic(model), by = "Parameter", sort = FALSE)
}
# check if statistic is available
if (is.null(params$p)) {
params$p <- as.vector(2 * stats::pnorm(abs(params$Statistic), lower.tail = FALSE))
}
# rename statistic column
names(params) <- gsub("Statistic", "z", names(params), fixed = TRUE)
# adjust p?
if (!is.null(p_adjust)) {
params <- .p_adjust(params, p_adjust, model, verbose)
}
fun_args <- list(
params,
model,
ci = ci,
exponentiate = FALSE,
bootstrap = FALSE,
iterations = NULL,
ci_method = "residual",
p_adjust = p_adjust,
include_info = FALSE,
verbose = verbose
)
fun_args <- c(fun_args, dots)
params <- do.call(".add_model_parameters_attributes", fun_args)
class(params) <- c("parameters_model", "see_parameters_model", class(params))
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(params, "no_caption") <- TRUE
params
}
#' @export
ci.deltaMethod <- function(x, ...) {
params <- model_parameters(x, ...)
ci <- attributes(params)$ci
params$CI <- ci
as.data.frame(params[c("Parameter", "CI", "CI_low", "CI_high")])
}
#' @export
standard_error.deltaMethod <- function(model, ...) {
params <- model_parameters(model, ...)
as.data.frame(params[c("Parameter", "SE")])
}
#' @export
p_value.deltaMethod <- function(model, ...) {
params <- model_parameters(model, ...)
if (is.null(params[["p"]])) {
return(NULL)
}
as.data.frame(params[c("Parameter", "p")])
}
parameters/R/methods_truncreg.R 0000644 0001762 0000144 00000000216 14716604200 016314 0 ustar ligges users # classes: .truncreg
#' @export
standard_error.truncreg <- standard_error.default
#' @export
p_value.truncreg <- p_value.default
parameters/R/methods_betareg.R 0000644 0001762 0000144 00000010340 14761570351 016104 0 ustar ligges users ## TODO add ci_method later?
#' @export
model_parameters.betareg <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "conditional",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(model)[1],
verbose = verbose
)
component <- insight::validate_argument(component, c("conditional", "precision", "all"))
if (component == "all") {
merge_by <- c("Parameter", "Component")
} else {
merge_by <- "Parameter"
}
## TODO check merge by
fun_args <- list(
model,
ci = ci,
component = component,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Component"),
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
include_info = include_info,
vcov = NULL,
vcov_args = NULL
)
fun_args <- c(fun_args, dot_args)
out <- do.call(".model_parameters_generic", fun_args)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
ci.betareg <- function(x, ci = 0.95, component = "all", verbose = TRUE, ...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(x)[1],
function_name = "ci",
verbose = verbose
)
component <- match.arg(component, choices = c("all", "conditional", "precision"))
.ci_generic(model = x, ci = ci, dof = Inf, component = component, verbose = verbose)
}
#' @export
standard_error.betareg <- function(model, component = "all", verbose = TRUE, ...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(model)[1],
function_name = "standard_error",
verbose = verbose
)
component <- match.arg(component, choices = c("all", "conditional", "precision"))
params <- insight::get_parameters(model)
cs <- do.call(rbind, stats::coef(summary(model)))
se <- cs[, 2]
out <- .data_frame(
Parameter = .remove_backticks_from_string(names(se)),
Component = params$Component,
SE = as.vector(se)
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
p_value.betareg <- function(model, component = "all", verbose = TRUE, ...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(model)[1],
function_name = "p_value",
verbose = verbose
)
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
params <- insight::get_parameters(model)
cs <- do.call(rbind, stats::coef(summary(model)))
p <- cs[, 4]
out <- .data_frame(
Parameter = params$Parameter,
Component = params$Component,
p = as.vector(p)
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
simulate_model.betareg <- function(model, iterations = 1000, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
out <- .simulate_model(model, iterations, component = component, ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
parameters/R/n_factors.R 0000644 0001762 0000144 00000066100 14736731407 014736 0 ustar ligges users #' Number of components/factors to retain in PCA/FA
#'
#' This function runs many existing procedures for determining how many factors
#' to retain/extract from factor analysis (FA) or dimension reduction (PCA). It
#' returns the number of factors based on the maximum consensus between methods.
#' In case of ties, it will keep the simplest model and select the solution
#' with the fewer factors.
#'
#' @param x A data frame.
#' @param type Can be `"FA"` or `"PCA"`, depending on what you want to do.
#' @param rotation Only used for VSS (Very Simple Structure criterion, see
#' [psych::VSS()]). The rotation to apply. Can be `"none"`, `"varimax"`,
#' `"quartimax"`, `"bentlerT"`, `"equamax"`, `"varimin"`, `"geominT"` and
#' `"bifactor"` for orthogonal rotations, and `"promax"`, `"oblimin"`,
#' `"simplimax"`, `"bentlerQ"`, `"geominQ"`, `"biquartimin"` and `"cluster"`
#' for oblique transformations.
#' @param algorithm Factoring method used by VSS. Can be `"pa"` for Principal
#' Axis Factor Analysis, `"minres"` for minimum residual (OLS) factoring,
#' `"mle"` for Maximum Likelihood FA and `"pc"` for Principal Components.
#' `"default"` will select `"minres"` if `type = "FA"` and `"pc"` if
#' `type = "PCA"`.
#' @param package Package from which respective methods are used. Can be
#' `"all"` or a vector containing `"nFactors"`, `"psych"`, `"PCDimension"`,
#' `"fit"` or `"EGAnet"`. Note that `"fit"` (which actually also relies on the
#' `psych` package) and `"EGAnet"` can be very slow for bigger datasets. Thus,
#' the default is `c("nFactors", "psych")`. You must have the respective
#' packages installed for the methods to be used.
#' @param safe If `TRUE`, the function will run all the procedures in try
#' blocks, and will only return those that work and silently skip the ones
#' that may fail.
#' @param cor An optional correlation matrix that can be used (note that the
#' data must still be passed as the first argument). If `NULL`, will
#' compute it by running `cor()` on the passed data.
#' @param n_max If set to a value (e.g., `10`), will drop from the results all
#' methods that suggest a higher number of components. The interpretation becomes
#' 'from all the methods that suggested a number lower than n_max, the results
#' are ...'.
#' @param ... Arguments passed to or from other methods.
#'
#' @details `n_components()` is actually an alias for `n_factors()`, with
#' different defaults for the function arguments.
#'
#' @note There is also a
#' [`plot()`-method](https://easystats.github.io/see/articles/parameters.html)
#' implemented in the [**see**-package](https://easystats.github.io/see/).
#' `n_components()` is a convenient short-cut for `n_factors(type = "PCA")`.
#'
#' @examplesIf require("PCDimension", quietly = TRUE) && require("nFactors", quietly = TRUE) && require("EGAnet", quietly = TRUE) && require("psych", quietly = TRUE)
#' library(parameters)
#' n_factors(mtcars, type = "PCA")
#'
#' result <- n_factors(mtcars[1:5], type = "FA")
#' as.data.frame(result)
#' summary(result)
#' \donttest{
#' # Setting package = 'all' will increase the number of methods (but is slow)
#' n_factors(mtcars, type = "PCA", package = "all")
#' n_factors(mtcars, type = "FA", algorithm = "mle", package = "all")
#' }
#'
#' @return A data frame.
#'
#' @references
#'
#' - Bartlett, M. S. (1950). Tests of significance in factor analysis.
#' British Journal of statistical psychology, 3(2), 77-85.
#'
#' - Bentler, P. M., & Yuan, K. H. (1996). Test of linear trend in
#' eigenvalues of a covariance matrix with application to data analysis.
#' British Journal of Mathematical and Statistical Psychology, 49(2), 299-312.
#'
#' - Cattell, R. B. (1966). The scree test for the number of factors.
#' Multivariate behavioral research, 1(2), 245-276.
#'
#' - Finch, W. H. (2019). Using Fit Statistic Differences to Determine the
#' Optimal Number of Factors to Retain in an Exploratory Factor Analysis.
#' Educational and Psychological Measurement.
#'
#' - Zoski, K. W., & Jurs, S. (1996). An objective counterpart to the
#' visual scree test for factor analysis: The standard error scree.
#' Educational and Psychological Measurement, 56(3), 443-451.
#'
#' - Zoski, K., & Jurs, S. (1993). Using multiple regression to determine
#' the number of factors to retain in factor analysis. Multiple Linear
#' Regression Viewpoints, 20(1), 5-9.
#'
#' - Nasser, F., Benson, J., & Wisenbaker, J. (2002). The performance of
#' regression-based variations of the visual scree for determining the number
#' of common factors. Educational and psychological measurement, 62(3),
#' 397-419.
#'
#' - Golino, H., Shi, D., Garrido, L. E., Christensen, A. P., Nieto, M.
#' D., Sadana, R., & Thiyagarajan, J. A. (2018). Investigating the performance
#' of Exploratory Graph Analysis and traditional techniques to identify the
#' number of latent factors: A simulation and tutorial.
#'
#' - Golino, H. F., & Epskamp, S. (2017). Exploratory graph analysis: A
#' new approach for estimating the number of dimensions in psychological
#' research. PloS one, 12(6), e0174035.
#'
#' - Revelle, W., & Rocklin, T. (1979). Very simple structure: An
#' alternative procedure for estimating the optimal number of interpretable
#' factors. Multivariate Behavioral Research, 14(4), 403-414.
#'
#' - Velicer, W. F. (1976). Determining the number of components from the
#' matrix of partial correlations. Psychometrika, 41(3), 321-327.
#'
#' @export
n_factors <- function(x,
type = "FA",
rotation = "varimax",
algorithm = "default",
package = c("nFactors", "psych"),
cor = NULL,
safe = TRUE,
n_max = NULL,
...) {
if (all(package == "all")) {
package <- c("nFactors", "EGAnet", "psych", "fit", "pcdimension")
}
# Get number of observations
if (is.data.frame(x)) {
n_obs <- nrow(x)
} else if (is.numeric(x) && !is.null(cor)) {
n_obs <- x
package <- package[!package %in% c("pcdimension", "PCDimension")]
} else if (is.matrix(x) || inherits(x, "easycormatrix")) {
insight::format_error(
"Please input the correlation matrix via the `cor` argument and the number of rows / observations via the first argument." # nolint
)
}
# Get only numeric
numerics <- vapply(x, is.numeric, TRUE)
if (!all(numerics)) {
insight::format_warning(paste0(
"Some variables are not numeric (",
toString(names(x)[!numerics]),
"). Dropping them."
))
}
x <- x[numerics]
# Correlation matrix
if (is.null(cor)) {
cor <- stats::cor(x, use = "pairwise.complete.obs", ...)
}
eigen_values <- eigen(cor)$values
# Smooth matrix if negative eigen values
if (any(eigen_values < 0)) {
insight::check_if_installed("psych")
cor <- psych::cor.smooth(cor, ...)
eigen_values <- eigen(cor)$values
}
# Initialize dataframe
out <- data.frame()
# nFactors -------------------------------------------
if ("nFactors" %in% package) {
insight::check_if_installed("nFactors")
# Model
if (tolower(type) %in% c("fa", "factor", "efa")) {
model <- "factors"
} else {
model <- "components"
}
# Compute all
if (safe) {
out <- rbind(
out,
tryCatch(.n_factors_bartlett(eigen_values, model, n_obs),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
out <- rbind(
out,
tryCatch(.n_factors_bentler(eigen_values, model, n_obs),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
out <- rbind(
out,
tryCatch(.n_factors_cng(eigen_values, model),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
out <- rbind(
out,
tryCatch(.n_factors_mreg(eigen_values, model),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
out <- rbind(
out,
tryCatch(.n_factors_scree(eigen_values, model),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
out <- rbind(
out,
tryCatch(.n_factors_sescree(eigen_values, model),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
} else {
out <- rbind(
out,
.n_factors_bartlett(eigen_values, model, n_obs)
)
out <- rbind(
out,
.n_factors_bentler(eigen_values, model, n_obs)
)
out <- rbind(
out,
.n_factors_cng(eigen_values, model)
)
out <- rbind(
out,
.n_factors_mreg(eigen_values, model)
)
out <- rbind(
out,
.n_factors_scree(eigen_values, model)
)
out <- rbind(
out,
.n_factors_sescree(eigen_values, model)
)
}
}
# EGAnet -------------------------------------------
if ("EGAnet" %in% package) {
insight::check_if_installed("EGAnet")
if (safe) {
out <- rbind(
out,
tryCatch(.n_factors_ega(x, cor, n_obs, eigen_values, type),
# warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
} else {
out <- rbind(
out,
.n_factors_ega(x, cor, n_obs, eigen_values, type)
)
}
}
# psych -------------------------------------------
if ("psych" %in% package) {
insight::check_if_installed("psych")
if (safe) {
out <- rbind(
out,
tryCatch(.n_factors_vss(x, cor, n_obs, type, rotation, algorithm),
# warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
} else {
out <- rbind(
out,
.n_factors_vss(x, cor, n_obs, type, rotation, algorithm)
)
}
}
# fit -------------------------------------------
if ("fit" %in% package) {
insight::check_if_installed("psych")
if (safe) {
out <- rbind(
out,
tryCatch(.n_factors_fit(x, cor, n_obs, type, rotation, algorithm),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
} else {
out <- rbind(
out,
.n_factors_fit(x, cor, n_obs, type, rotation, algorithm)
)
}
}
# pcdimension -------------------------------------------
if ("pcdimension" %in% tolower(package)) {
insight::check_if_installed("PCDimension")
if (safe) {
out <- rbind(
out,
tryCatch(.n_factors_PCDimension(x, type),
warning = function(w) data.frame(),
error = function(e) data.frame()
)
)
} else {
out <- rbind(
out,
.n_factors_PCDimension(x, type)
)
}
}
# OUTPUT ----------------------------------------------
# TODO created weighted composite score
out <- out[!is.na(out$n_Factors), ] # Remove empty methods
out <- out[order(out$n_Factors), ] # Arrange by n factors
row.names(out) <- NULL # Reset row index
if (!is.null(n_max)) {
out <- out[out$n_Factors <= n_max, ]
}
# Add summary
by_factors <- .data_frame(
n_Factors = as.numeric(unique(out$n_Factors)),
n_Methods = as.numeric(by(out, as.factor(out$n_Factors), function(out) n <- nrow(out)))
)
# Add cumulative percentage of variance explained
fa <- factor_analysis(x, cor = cor, n = max(by_factors$n_Factors)) # Get it from our fa:: wrapper (TODO: that's probably not the most efficient)
varex <- attributes(fa)$summary
# Extract number of factors from EFA output (usually MR1, ML1, etc.)
varex$n_Factors <- as.numeric(gsub("[^\\d]+", "", varex$Component, perl = TRUE))
# Merge (and like that filter out empty methods)
by_factors <- merge(by_factors, varex[, c("n_Factors", "Variance_Cumulative")], by = "n_Factors")
attr(out, "Variance_Explained") <- varex # We add all the variance explained (for plotting)
attr(out, "summary") <- by_factors
attr(out, "n") <- min(as.numeric(as.character(
by_factors[by_factors$n_Methods == max(by_factors$n_Methods), "n_Factors"]
)))
class(out) <- c("n_factors", "see_n_factors", class(out))
out
}
#' @rdname n_factors
#' @export
n_components <- function(x,
type = "PCA",
rotation = "varimax",
algorithm = "default",
package = c("nFactors", "psych"),
cor = NULL,
safe = TRUE,
...) {
n_factors(
x,
type = type,
rotation = rotation,
algorithm = algorithm,
package = package,
cor = cor,
safe = safe,
...
)
}
#' @export
print.n_factors <- function(x, ...) {
results <- attributes(x)$summary
# Extract info
max_methods <- max(results$n_Methods)
best_n <- attributes(x)$n
# Extract methods
if ("n_Factors" %in% names(x)) {
type <- "factor"
methods_text <- toString(as.character(x[x$n_Factors == best_n, "Method"]))
} else {
type <- "cluster"
methods_text <- toString(as.character(x[x$n_Clusters == best_n, "Method"]))
}
# Text
msg_text <- paste0(
"The choice of ",
as.character(best_n),
ifelse(type == "factor", " dimensions ", " clusters "),
"is supported by ",
max_methods,
" (",
sprintf("%.2f", max_methods / nrow(x) * 100),
"%) methods out of ",
nrow(x),
" (",
methods_text,
").\n"
)
insight::print_color("# Method Agreement Procedure:\n\n", "blue")
cat(msg_text)
invisible(x)
}
#' @export
summary.n_factors <- function(object, ...) {
attributes(object)$summary
}
#' @export
as.numeric.n_factors <- function(x, ...) {
attributes(x)$n
}
#' @export
as.double.n_factors <- as.numeric.n_factors
#' @export
summary.n_clusters <- summary.n_factors
#' @export
as.numeric.n_clusters <- as.numeric.n_factors
#' @export
as.double.n_clusters <- as.double.n_factors
#' @export
print.n_clusters <- print.n_factors
# Methods -----------------------------------------------------------------
#' Bartlett, Anderson and Lawley Procedures
#' @keywords internal
.n_factors_bartlett <- function(eigen_values = NULL, model = "factors", nobs = NULL) {
nfac <- nFactors::nBartlett(
eigen_values,
N = nobs,
cor = TRUE,
alpha = 0.05,
details = FALSE
)$nFactors
.data_frame(
n_Factors = as.numeric(nfac),
Method = insight::format_capitalize(names(nfac)),
Family = "Barlett"
)
}
#' Bentler and Yuan's Procedure
#' @keywords internal
.n_factors_bentler <- function(eigen_values = NULL, model = "factors", nobs = NULL) {
nfac <- .nBentler(
x = eigen_values,
N = nobs,
model = model,
alpha = 0.05,
details = FALSE
)$nFactors
.data_frame(
n_Factors = as.numeric(nfac),
Method = "Bentler",
Family = "Bentler"
)
}
#' Cattell-Nelson-Gorsuch CNG Indices
#' @keywords internal
.n_factors_cng <- function(eigen_values = NULL, model = "factors") {
if (length(eigen_values) < 6) {
nfac <- NA
} else {
nfac <- nFactors::nCng(x = eigen_values, cor = TRUE, model = model)$nFactors
}
.data_frame(
n_Factors = as.numeric(nfac),
Method = "CNG",
Family = "CNG"
)
}
#' Multiple Regression Procedure
#' @keywords internal
.n_factors_mreg <- function(eigen_values = NULL, model = "factors") {
if (length(eigen_values) < 6) {
nfac <- NA
} else {
nfac <- nFactors::nMreg(x = eigen_values, cor = TRUE, model = model)$nFactors
}
.data_frame(
n_Factors = as.numeric(nfac),
Method = c("beta", "t", "p"),
Family = "Multiple_regression"
)
}
#' Non Graphical Cattell's Scree Test
#' @keywords internal
.n_factors_scree <- function(eigen_values = NULL, model = "factors") {
nfac <- unlist(nFactors::nScree(x = eigen_values, cor = TRUE, model = model)$Components)
.data_frame(
n_Factors = as.numeric(nfac),
Method = c("Optimal coordinates", "Acceleration factor", "Parallel analysis", "Kaiser criterion"),
Family = "Scree"
)
}
#' Standard Error Scree and Coefficient of Determination Procedures
#' @keywords internal
.n_factors_sescree <- function(eigen_values = NULL, model = "factors") {
nfac <- nFactors::nSeScree(x = eigen_values, cor = TRUE, model = model)$nFactors
.data_frame(
n_Factors = as.numeric(nfac),
Method = c("Scree (SE)", "Scree (R2)"),
Family = "Scree_SE"
)
}
# EGAnet ------------------------
.n_factors_ega <- function(x = NULL,
cor = NULL,
nobs = NULL,
eigen_values = NULL,
type = "FA") {
# Replace with own correlation matrix
junk <- utils::capture.output(suppressWarnings(suppressMessages(
nfac_glasso <- EGAnet::EGA(cor, n = nobs, model = "glasso", plot.EGA = FALSE)$n.dim # nolint
)))
junk <- utils::capture.output(suppressWarnings(suppressMessages(
nfac_TMFG <- .safe(EGAnet::EGA(cor, n = nobs, model = "TMFG", plot.EGA = FALSE)$n.dim, NA) # nolint
)))
.data_frame(
n_Factors = as.numeric(c(nfac_glasso, nfac_TMFG)),
Method = c("EGA (glasso)", "EGA (TMFG)"),
Family = "EGA"
)
}
# psych ------------------------
#' @keywords internal
.n_factors_parallel <- function(x = NULL,
cor = NULL,
nobs = NULL,
type = "FA") {
# Altnerative version of parralel analysis
# Not used because already included in nFactors
if (tolower(type) %in% c("fa", "factor", "efa")) {
fa <- "fa"
} else {
fa <- "pc"
}
insight::check_if_installed("psych")
out <- psych::fa.parallel(cor, n.obs = nobs, fa = fa, plot = FALSE, fm = "ml")
.data_frame(
n_Factors = as.numeric(stats::na.omit(c(out$nfact, out$ncomp))),
Method = "Parallel",
Family = "psych"
)
}
#' @keywords internal
.n_factors_vss <- function(x = NULL,
cor = NULL,
nobs = NULL,
type = "FA",
rotation = "varimax",
algorithm = "default") {
if (algorithm == "default") {
if (tolower(type) %in% c("fa", "factor", "efa")) {
algorithm <- "minres"
} else {
algorithm <- "pc"
}
}
insight::check_if_installed("psych")
# Compute VSS
vss <- psych::VSS(
cor,
n = ncol(x) - 1,
n.obs = nobs,
rotate = rotation,
fm = algorithm,
plot = FALSE
)
# Format results
stats <- vss$vss.stats
stats$map <- vss$map
stats$n_Factors <- seq_len(nrow(stats))
names(stats) <- gsub("cfit.", "VSS_Complexity_", names(stats))
# Indices
vss_1 <- which.max(stats$VSS_Complexity_1)
vss_2 <- which.max(stats$VSS_Complexity_2)
velicer_MAP <- which.min(stats$map)
BIC_reg <- which.min(stats$BIC)
BIC_adj <- which.min(stats$SABIC)
BIC_reg <- ifelse(length(BIC_reg) == 0, NA, BIC_reg)
BIC_adj <- ifelse(length(BIC_adj) == 0, NA, BIC_adj)
.data_frame(
n_Factors = as.numeric(c(vss_1, vss_2, velicer_MAP, BIC_reg, BIC_adj)),
Method = c("VSS complexity 1", "VSS complexity 2", "Velicer's MAP", "BIC", "BIC (adjusted)"),
Family = c("VSS", "VSS", "Velicers_MAP", "BIC", "BIC")
)
}
#' @keywords internal
.n_factors_fit <- function(x = NULL,
cor = NULL,
nobs = NULL,
type = "FA",
rotation = "varimax",
algorithm = "default",
threshold = 0.1) {
if (algorithm == "default") {
if (tolower(type) %in% c("fa", "factor", "efa")) {
algorithm <- "minres"
} else {
algorithm <- "pc"
}
}
insight::check_if_installed("psych")
rez <- data.frame()
for (n in 1:(ncol(cor) - 1)) {
if (tolower(type) %in% c("fa", "factor", "efa")) {
factors <- tryCatch(
suppressWarnings(
psych::fa(
cor,
nfactors = n,
n.obs = nobs,
rotate = rotation,
fm = algorithm
)
),
error = function(e) NA
)
} else {
factors <- tryCatch(
suppressWarnings(
psych::pca(
cor,
nfactors = n,
n.obs = nobs,
rotate = rotation
)
),
error = function(e) NA
)
}
if (all(is.na(factors))) {
next
}
rmsea <- ifelse(is.null(factors$RMSEA), NA, factors$RMSEA[1])
rmsr <- ifelse(is.null(factors$rms), NA, factors$rms)
crms <- ifelse(is.null(factors$crms), NA, factors$crms)
bic <- ifelse(is.null(factors$BIC), NA, factors$BIC)
tli <- ifelse(is.null(factors$TLI), NA, factors$TLI)
rez <- rbind(
rez,
.data_frame(
n = n,
Fit = factors$fit.off,
TLI = tli,
RMSEA = rmsea,
RMSR = rmsr,
CRMS = crms,
BIC = bic
)
)
}
# For fit indices that constantly increase / decrease, we need to find
# an "elbow"/"knee". Here we take the first value that reaches 90 percent
# of the range between the max and the min (when 'threshold = 0.1').
# Fit
if (all(is.na(rez$Fit))) {
fit_off <- NA
} else {
target <- max(rez$Fit, na.rm = TRUE) - threshold * diff(range(rez$Fit, na.rm = TRUE))
fit_off <- rez[!is.na(rez$Fit) & rez$Fit >= target, "n"][1]
}
# TLI
if (all(is.na(rez$TLI))) {
TLI <- NA
} else {
target <- max(rez$TLI, na.rm = TRUE) - threshold * diff(range(rez$TLI, na.rm = TRUE))
TLI <- rez[!is.na(rez$TLI) & rez$TLI >= target, "n"][1]
}
# RMSEA
if (all(is.na(rez$RMSEA))) {
RMSEA <- NA
} else {
target <- min(rez$RMSEA, na.rm = TRUE) + threshold * diff(range(rez$RMSEA, na.rm = TRUE))
RMSEA <- rez[!is.na(rez$RMSEA) & rez$RMSEA <= target, "n"][1]
}
# RMSR
if (all(is.na(rez$RMSR))) {
RMSR <- NA
} else {
target <- min(rez$RMSR, na.rm = TRUE) + threshold * diff(range(rez$RMSR, na.rm = TRUE))
RMSR <- rez[!is.na(rez$RMSR) & rez$RMSR <= target, "n"][1]
}
# CRMS
if (all(is.na(rez$CRMS))) {
CRMS <- NA
} else {
target <- min(rez$CRMS, na.rm = TRUE) + threshold * diff(range(rez$CRMS, na.rm = TRUE))
CRMS <- rez[!is.na(rez$CRMS) & rez$CRMS <= target, "n"][1]
}
# BIC (this is a penalized method so we can just take the one that minimizes it)
BayIC <- ifelse(all(is.na(rez$BIC)), NA, rez[!is.na(rez$BIC) & rez$BIC == min(rez$BIC, na.rm = TRUE), "n"])
.data_frame(
n_Factors = c(fit_off, TLI, RMSEA, RMSR, CRMS, BayIC),
Method = c("Fit_off", "TLI", "RMSEA", "RMSR", "CRMS", "BIC"),
Family = c("Fit", "Fit", "Fit", "Fit", "Fit", "Fit")
)
}
# PCDimension ------------------------
#' @keywords internal
.n_factors_PCDimension <- function(x = NULL, type = "PCA") {
# This package is a strict dependency of PCDimension so if users have the
# former they should have it
insight::check_if_installed(c("ClassDiscovery", "PCDimension"))
# Only applies to PCA with full data
if (tolower(type) %in% c("fa", "factor", "efa") || !is.data.frame(x)) {
return(data.frame())
}
# Randomization-Based Methods
rez_rnd <- PCDimension::rndLambdaF(x)
# Broken-Stick
spca <- ClassDiscovery::SamplePCA(t(x))
lambda <- spca@variances[1:(ncol(x) - 1)]
rez_bokenstick <- PCDimension::bsDimension(lambda)
# Auer-Gervini
ag <- PCDimension::AuerGervini(spca)
agfuns <- list(
twice = PCDimension::agDimTwiceMean,
specc = PCDimension::agDimSpectral,
km = PCDimension::agDimKmeans,
km3 = PCDimension::agDimKmeans3,
# tt=PCDimension::agDimTtest, # known to overestimate
# cpm=PCDimension::makeAgCpmFun("Exponential"), # known to overestimate
tt2 = PCDimension::agDimTtest2,
cpt = PCDimension::agDimCPT
)
rez_ag <- PCDimension::compareAgDimMethods(ag, agfuns)
.data_frame(
n_Factors = as.numeric(c(rez_rnd, rez_bokenstick, rez_ag)),
Method = c(
"Random (lambda)", "Random (F)", "Broken-Stick", "Auer-Gervini (twice)",
"Auer-Gervini (spectral)", "Auer-Gervini (kmeans-2)", "AuerGervini (kmeans-3)",
"Auer-Gervini (T)", "AuerGervini (CPT)"
),
Family = "PCDimension"
)
}
# Re-implementation of nBentler in nFactors ------------------------
#' @keywords internal
.nBentler <- function(x,
N,
model = model,
log = TRUE,
alpha = 0.05,
cor = TRUE,
details = TRUE,
...) {
insight::check_if_installed("nFactors")
lambda <- nFactors::eigenComputes(x, cor = cor, model = model, ...)
if (any(lambda < 0)) {
insight::format_error(
"These indices are only valid with a principal component solution. So, only positive eigenvalues are permitted."
)
}
minPar <- c(min(lambda) - abs(min(lambda)) + 0.001, 0.001)
maxPar <- c(max(lambda), stats::lm(lambda ~ I(rev(seq_along(lambda))))$coef[2])
n <- N
significance <- alpha
min.k <- 3
LRT <- .data_frame(
q = numeric(length(lambda) - min.k), k = numeric(length(lambda) - min.k),
LRT = numeric(length(lambda) - min.k), a = numeric(length(lambda) - min.k),
b = numeric(length(lambda) - min.k),
p = numeric(length(lambda) - min.k),
convergence = numeric(length(lambda) - min.k)
)
bentler.n <- 0
for (i in 1:(length(lambda) - min.k)) {
temp <-
nFactors::bentlerParameters(
x = lambda,
N = n,
nFactors = i,
log = log,
cor = cor,
minPar = minPar,
maxPar = maxPar,
graphic = FALSE
)
LRT[i, 3] <- temp$lrt
LRT[i, 4] <- ifelse(is.null(temp$coef[1]), NA, temp$coef[1])
LRT[i, 5] <- ifelse(is.null(temp$coef[2]), NA, temp$coef[2])
LRT[i, 6] <- ifelse(is.null(temp$p.value), NA, temp$p.value)
LRT[i, 7] <- ifelse(is.null(temp$convergence), NA, temp$convergence)
LRT[i, 2] <- i
LRT[i, 1] <- length(lambda) - i
}
# LRT <- LRT[order(LRT[,1],decreasing = TRUE),]
for (i in 1:(length(lambda) - min.k)) {
if (i == 1) bentler.n <- bentler.n + as.numeric(LRT$p[i] <= significance)
if (i > 1 && LRT$p[i - 1] <= 0.05) {
bentler.n <- bentler.n + as.numeric(LRT$p[i] <= significance)
}
}
if (bentler.n == 0) {
bentler.n <- length(lambda)
}
if (isTRUE(details)) {
details <- LRT
} else {
details <- NULL
}
res <- list(detail = details, nFactors = bentler.n)
class(res) <- c("nFactors", "list")
res
}
parameters/R/bootstrap_model-emmeans.R 0000644 0001762 0000144 00000002353 14317274256 017577 0 ustar ligges users #' @keywords emmeans_methods
emm_basis.bootstrap_model <- function(object, trms, xlev, grid, ...) {
insight::check_if_installed("emmeans")
model <- attr(object, "original_model")
emb <- emmeans::emm_basis(model, trms, xlev, grid, ...)
if (ncol(object) != ncol(emb$V) || !all(colnames(object) == colnames(emb$V))) {
insight::format_error(
"Oops! Cannot create the reference grid. Please open an issue at {.url https://github.com/easystats/parameters/issues}."
)
}
emb$post.beta <- as.matrix(object)
emb$misc$is_boot <- TRUE
emb
}
#' @keywords emmeans_methods
recover_data.bootstrap_model <- function(object, ...) {
insight::check_if_installed("emmeans")
model <- attr(object, "original_model")
emmeans::recover_data(model, ...)
}
#' @keywords emmeans_methods
emm_basis.bootstrap_parameters <- function(object, trms, xlev, grid, ...) {
insight::check_if_installed("emmeans")
model <- attr(object, "boot_samples")
emmeans::emm_basis(model, trms, xlev, grid, ...)
}
#' @keywords emmeans_methods
recover_data.bootstrap_parameters <- function(object, ...) {
insight::check_if_installed("emmeans")
model <- attr(object, "boot_samples")
emmeans::recover_data(model, ...)
}
parameters/R/methods_cgam.R 0000644 0001762 0000144 00000012671 14717111737 015413 0 ustar ligges users #' @title Parameters from Generalized Additive (Mixed) Models
#' @name model_parameters.cgam
#'
#' @description Extract and compute indices and measures to describe parameters
#' of generalized additive models (GAM(M)s).
#'
#' @param model A gam/gamm model.
#' @inheritParams model_parameters.default
#'
#' @seealso [insight::standardize_names()] to rename
#' columns into a consistent, standardized naming scheme.
#'
#' @details The reporting of degrees of freedom *for the spline terms*
#' slightly differs from the output of `summary(model)`, for example in the
#' case of `mgcv::gam()`. The *estimated degrees of freedom*, column
#' `edf` in the summary-output, is named `df` in the returned data
#' frame, while the column `df_error` in the returned data frame refers to
#' the residual degrees of freedom that are returned by `df.residual()`.
#' Hence, the values in the the column `df_error` differ from the column
#' `Ref.df` from the summary, which is intentional, as these reference
#' degrees of freedom \dQuote{is not very interpretable}
#' ([web](https://stat.ethz.ch/pipermail/r-help/2019-March/462135.html)).
#'
#' @return A data frame of indices related to the model's parameters.
#'
#' @examples
#' library(parameters)
#' if (require("mgcv")) {
#' dat <- gamSim(1, n = 400, dist = "normal", scale = 2)
#' model <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat)
#' model_parameters(model)
#' }
#' @export
model_parameters.cgam <- function(model,
ci = 0.95,
ci_method = "residual",
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args", "component"),
class(model)[1],
verbose = verbose
)
# Processing
if (bootstrap) {
params <- bootstrap_parameters(
model,
iterations = iterations,
ci = ci,
...
)
} else {
fun_args <- list(
model,
ci = ci,
ci_method = ci_method,
component = "all",
merge_by = c("Parameter", "Component"),
standardize = standardize,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
vcov = NULL,
vcov_args = NULL
)
fun_args <- c(fun_args, dot_args)
params <- do.call(".extract_parameters_generic", fun_args)
}
# fix statistic column
if ("t" %in% names(params) && !is.null(params$Component) && "smooth_terms" %in% params$Component) {
names(params)[names(params) == "t"] <- "t / F"
}
# fix estimated df column
if (inherits(model, c("gam", "cgam", "scam", "rqss")) && "smooth_terms" %in% params$Component && !("df" %in% names(params))) { # nolint
params$df <- params$Coefficient
params$df[params$Component != "smooth_terms"] <- NA
params$df_error[params$Component == "smooth_terms"] <- NA
params$Coefficient[params$Component == "smooth_terms"] <- NA
# reorder
insert_column <- which(names(params) == "df_error")
if (!length(insert_column)) {
insert_column <- which(names(params) == "p")
}
if (length(insert_column)) {
n_col <- ncol(params)
params <- params[c(1:(insert_column - 1), n_col, insert_column:(n_col - 1))]
}
} else if (all(c("df", "df_error") %in% names(params)) && "smooth_terms" %in% params$Component) {
params$df_error[params$Component == "smooth_terms"] <- NA
}
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(
params,
model,
ci,
exponentiate,
p_adjust = p_adjust,
verbose = verbose,
...
)
if ("CI" %in% colnames(params)) {
params$CI[is.na(params$CI_low)] <- NA
}
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
p_value.cgam <- function(model, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "smooth_terms")
)
params <- insight::get_parameters(model, component = "all")
cs <- summary(model)
p <- as.vector(cs$coefficients[, 4])
if (!is.null(cs$coefficients2)) p <- c(p, as.vector(cs$coefficients2[, "p.value"]))
out <- .data_frame(
Parameter = params$Parameter,
Component = params$Component,
p = as.vector(p)
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
standard_error.cgam <- function(model, ...) {
sc <- summary(model)
se <- as.vector(sc$coefficients[, "StdErr"])
params <- insight::get_parameters(model, component = "all")
if (!is.null(sc$coefficients2)) se <- c(se, rep(NA, nrow(sc$coefficients2)))
.data_frame(
Parameter = params$Parameter,
SE = se,
Component = params$Component
)
}
parameters/R/standardize_posteriors.R 0000644 0001762 0000144 00000006321 14716604200 017544 0 ustar ligges users #' @rdname standardize_parameters
#' @export
#' @aliases standardise_posteriors
standardize_posteriors <- function(model,
method = "refit",
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
object_name <- insight::safe_deparse_symbol(substitute(model))
m_info <- .get_model_info(model, ...)
include_response <- include_response && .safe_to_standardize_response(m_info, verbose = verbose)
if (method == "refit") {
model <- datawizard::standardize(
model,
robust = robust,
two_sd = two_sd,
include_response = include_response,
verbose = verbose,
m_info = m_info
)
}
pars <- insight::get_parameters(model)
if (method %in% c("posthoc", "smart", "basic", "classic", "pseudo")) {
pars <- .standardize_posteriors_posthoc(pars, method, model, m_info, robust, two_sd, include_response, verbose)
method <- attr(pars, "std_method")
robust <- attr(pars, "robust")
}
## attributes
attr(pars, "std_method") <- method
attr(pars, "two_sd") <- two_sd
attr(pars, "robust") <- robust
attr(pars, "include_response") <- include_response
attr(pars, "object_name") <- object_name
class(pars) <- c("parameters_standardized", class(pars))
pars
}
#' @export
standardise_posteriors <- standardize_posteriors
#' @keywords internal
.standardize_posteriors_posthoc <- function(pars, method, model, mi, robust, two_sd, include_response, verbose) {
# validation check for "pseudo"
method <- .should_pseudo(method, model)
method <- .cant_smart_or_posthoc(method, model, mi, pars$Parameter)
if (robust && method == "pseudo") {
insight::format_alert("`robust` standardization not available for `pseudo` method.")
robust <- FALSE
}
## Get scaling factors
deviations <- standardize_info(
model,
robust = robust,
include_pseudo = method == "pseudo",
two_sd = two_sd,
model_info = mi
)
i <- match(deviations$Parameter, colnames(pars))
pars <- pars[, i]
if (method == "basic") { # nolint
col_dev_resp <- "Deviation_Response_Basic"
col_dev_pred <- "Deviation_Basic"
} else if (method == "posthoc") {
col_dev_resp <- "Deviation_Response_Basic"
col_dev_pred <- "Deviation_Smart"
} else if (method == "smart") {
col_dev_resp <- "Deviation_Response_Smart"
col_dev_pred <- "Deviation_Smart"
} else if (method == "pseudo") {
col_dev_resp <- "Deviation_Response_Pseudo"
col_dev_pred <- "Deviation_Pseudo"
} else {
insight::format_error("`method` must be one of \"basic\", \"posthoc\", \"smart\" or \"pseudo\".")
}
.dev_pred <- deviations[[col_dev_pred]]
.dev_resp <- deviations[[col_dev_resp]]
if (!include_response) .dev_resp <- 1
.dev_factor <- .dev_pred / .dev_resp
# Sapply standardization
pars <- t(t(pars) * .dev_factor)
pars <- as.data.frame(pars)
attr(pars, "std_method") <- method
attr(pars, "two_sd") <- two_sd
attr(pars, "robust") <- robust
pars
}
parameters/R/ci_profile_boot.R 0000644 0001762 0000144 00000011436 14736731407 016120 0 ustar ligges users .ci_profiled <- function(model, ci) {
glm_ci <- tryCatch(
{
out <- as.data.frame(
suppressWarnings(stats::confint(model, level = ci)),
stringsAsFactors = FALSE
)
names(out) <- c("CI_low", "CI_high")
out$CI <- ci
out$Parameter <- insight::get_parameters(model,
effects = "fixed",
component = "conditional",
verbose = FALSE
)$Parameter
out <- out[c("Parameter", "CI", "CI_low", "CI_high")]
rownames(out) <- NULL
out
},
error = function(e) {
NULL
}
)
if (is.null(glm_ci)) {
glm_ci <- .ci_generic(model, ci = ci)
}
glm_ci
}
# we need this function for models where confint and get_parameters return
# different length (e.g. as for "polr" models)
.ci_profiled2 <- function(model, ci) {
glm_ci <- tryCatch(
{
out <- as.data.frame(stats::confint(model, level = ci), stringsAsFactors = FALSE)
names(out) <- c("CI_low", "CI_high")
out$CI <- ci
out$Parameter <- .remove_backticks_from_string(rownames(out))
out <- out[c("Parameter", "CI", "CI_low", "CI_high")]
rownames(out) <- NULL
out
},
error = function(e) {
NULL
}
)
if (is.null(glm_ci)) {
glm_ci <- .ci_generic(model, ci = ci)
}
glm_ci
}
#' @keywords internal
.ci_profile_merMod <- function(x, ci, profiled, ...) {
out <- as.data.frame(suppressWarnings(stats::confint(profiled, level = ci, ...)))
rownames(out) <- gsub("`", "", rownames(out), fixed = TRUE)
out <- out[rownames(out) %in% insight::find_parameters(x, effects = "fixed")$conditional, ]
names(out) <- c("CI_low", "CI_high")
# Clean up
out$Parameter <- row.names(out)
out$CI <- ci
out <- out[c("Parameter", "CI", "CI_low", "CI_high")]
row.names(out) <- NULL
out
}
#' @keywords internal
.ci_profile_glmmTMB <- function(x, ci, profiled, component, ...) {
# make sure "..." doesn't pass invalid arguments to package TMB
dot_args <- .check_profile_uniroot_args(...)
if (is.null(profiled)) {
fun_args <- list(x, method = "profile", level = ci, dot_args)
out <- as.data.frame(do.call(stats::confint, fun_args))
} else {
fun_args <- list(profiled, level = ci, dot_args)
out <- .safe(as.data.frame(do.call(stats::confint, fun_args)))
if (is.null(out)) {
fun_args <- list(x, method = "profile", level = ci, dot_args)
out <- as.data.frame(do.call(stats::confint, fun_args))
}
}
.process_glmmTMB_CI(x, out, ci, component)
}
#' @keywords internal
.ci_uniroot_glmmTMB <- function(x, ci, component, ...) {
# make sure "..." doesn't pass invalid arguments to package TMB
dot_args <- .check_profile_uniroot_args(...)
fun_args <- list(x, level = ci, method = "uniroot", dot_args)
out <- as.data.frame(do.call(stats::confint, fun_args))
.process_glmmTMB_CI(x, out, ci, component)
}
.check_profile_uniroot_args <- function(...) {
.profile_formals <- c(
"cl", "fitted", "h", "level_max", "lincomb", "maxit", "name",
"ncpus", "npts", "obj", "parallel", "parm", "parm.range", "slice",
"stderr", "stepfac", "trace", "ystep", "ytol"
)
dots <- list(...)
dot_args <- intersect(names(dots), .profile_formals)
out <- dots[dot_args]
if (!length(out)) {
return(NULL)
}
out
}
.process_glmmTMB_CI <- function(x, out, ci, component) {
rownames(out) <- gsub("`", "", rownames(out), fixed = TRUE)
pars <- insight::get_parameters(x,
effects = "fixed",
component = component,
verbose = FALSE
)
param_names <- switch(component,
conditional = pars$Parameter,
zi = ,
zero_inflated = paste0("zi~", pars$Parameter),
c(
pars$Parameter[pars$Component == "conditional"],
paste0("zi~", pars$Parameter[pars$Component == "zero_inflated"])
)
)
out <- out[rownames(out) %in% param_names, ]
names(out) <- c("CI_low", "CI_high")
# Clean up
out$Parameter <- pars$Parameter
out$CI <- ci
out <- out[c("Parameter", "CI", "CI_low", "CI_high")]
out$Component <- pars$Component
row.names(out) <- NULL
out
}
#' @keywords internal
.ci_boot_merMod <- function(x, ci, iterations = 500, effects = "fixed", ...) {
insight::check_if_installed("lme4")
# Compute
out <- suppressWarnings(suppressMessages(as.data.frame(
lme4::confint.merMod(x, level = ci, method = "boot", nsim = iterations, ...)
)))
rownames(out) <- gsub("`", "", rownames(out), fixed = TRUE)
out <- out[rownames(out) %in% insight::find_parameters(x, effects = "fixed")$conditional, ]
names(out) <- c("CI_low", "CI_high")
# Clean up
out$Parameter <- row.names(out)
out$CI <- ci
out <- out[c("Parameter", "CI", "CI_low", "CI_high")]
row.names(out) <- NULL
out
}
parameters/R/methods_model_fit.R 0000644 0001762 0000144 00000003261 14736731407 016444 0 ustar ligges users ## tidymodels (.model_fit)
# model parameters ---------------------
#' @export
model_parameters.model_fit <- function(model,
ci = 0.95,
effects = "fixed",
component = "conditional",
ci_method = "profile",
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
verbose = TRUE,
...) {
model_parameters(
model$fit,
ci = ci,
effects = effects,
component = component,
ci_method = ci_method,
bootstrap = bootstrap,
iterations = iterations,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
verbose = verbose,
...
)
}
# ci ------------------
#' @export
ci.model_fit <- function(x, ci = 0.95, method = NULL, ...) {
ci(x$fit, ci = ci, method = method, ...)
}
# standard error ------------------
#' @export
standard_error.model_fit <- function(model, ...) {
standard_error(model$fit, ...)
}
# p values ------------------
#' @export
p_value.model_fit <- function(model, ...) {
p_value(model$fit, ...)
}
# simulate model ------------------
#' @export
simulate_model.model_fit <- function(model, iterations = 1000, ...) {
simulate_model(model$fit, iterations = iterations, ...)
}
parameters/R/methods_speedglm.R 0000644 0001762 0000144 00000000320 14355513424 016265 0 ustar ligges users #' @export
p_value.speedlm <- function(model, ...) {
p <- p_value.default(model, ...)
if (!is.numeric(p$p)) {
p$p <- tryCatch(as.numeric(as.character(p$p)), error = function(e) p$p)
}
p
}
parameters/R/methods_eflm.R 0000644 0001762 0000144 00000000424 14030655331 015407 0 ustar ligges users # eflm (.eglm) -----------------
#' @export
p_value.eglm <- function(model, ...) {
stats <- stats::coef(summary(model))
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
p = as.numeric(as.vector(stats[, 4]))
)
}
parameters/R/sort_parameters.R 0000644 0001762 0000144 00000002756 14477616760 016207 0 ustar ligges users #' Sort parameters by coefficient values
#'
#' @param x A data frame or a `parameters_model` object.
#' @param ... Arguments passed to or from other methods.
#'
#' @examples
#' # creating object to sort (can also be a regular data frame)
#' mod <- model_parameters(stats::lm(wt ~ am * cyl, data = mtcars))
#'
#' # original output
#' mod
#'
#' # sorted outputs
#' sort_parameters(mod, sort = "ascending")
#' sort_parameters(mod, sort = "descending")
#'
#' @return A sorted data frame or original object.
#'
#' @export
sort_parameters <- function(x, ...) {
UseMethod("sort_parameters")
}
#' @rdname sort_parameters
#'
#' @param sort If `"none"` (default) do not sort, `"ascending"` sort by
#' increasing coefficient value, or `"descending"` sort by decreasing
#' coefficient value.
#' @param column The column containing model parameter estimates. This will be
#' `"Coefficient"` (default) in *easystats* packages, `"estimate"` in *broom*
#' package, etc.
#'
#' @export
sort_parameters.default <- function(x, sort = "none", column = "Coefficient", ...) {
sort <- match.arg(tolower(sort), choices = c("none", "ascending", "descending"))
if (sort == "none") {
return(x)
}
# new row indices to use for sorting
new_row_order <- switch(sort,
ascending = order(x[[column]], decreasing = FALSE),
descending = order(x[[column]], decreasing = TRUE)
)
x[new_row_order, ]
}
#' @export
sort_parameters.data.frame <- sort_parameters.default
parameters/R/methods_logistf.R 0000644 0001762 0000144 00000002127 14716604200 016135 0 ustar ligges users # model_parameters --------------------
#' @export
model_parameters.logistf <- model_parameters.glm
#' @export
model_parameters.flic <- model_parameters.glm
#' @export
model_parameters.flac <- model_parameters.glm
# ci --------------------
#' @export
ci.logistf <- ci.glm
#' @export
ci.flic <- ci.glm
#' @export
ci.flac <- ci.glm
# SE --------------------
#' @export
standard_error.logistf <- function(model, ...) {
vc <- insight::get_varcov(model, ...)
se <- sqrt(diag(vc))
.data_frame(
Parameter = .remove_backticks_from_string(names(se)),
SE = as.vector(se)
)
}
#' @export
standard_error.flic <- standard_error.logistf
#' @export
standard_error.flac <- standard_error.logistf
# p --------------------
#' @export
p_value.logistf <- function(model, ...) {
utils::capture.output(s <- summary(model)) # nolint
.data_frame(
Parameter = .remove_backticks_from_string(names(s$coefficients)),
p = as.vector(s$prob)
)
}
#' @export
p_value.flic <- p_value.logistf
#' @export
p_value.flac <- p_value.logistf
parameters/R/methods_mlm.R 0000644 0001762 0000144 00000016676 14717111737 015302 0 ustar ligges users # classes: .mlm
#################### .mlm
#' Parameters from multinomial or cumulative link models
#'
#' Parameters from multinomial or cumulative link models
#'
#' @param model A model with multinomial or categorical response value.
#' @inheritParams model_parameters.default
#' @inheritParams simulate_model
#'
#' @details Multinomial or cumulative link models, i.e. models where the
#' response value (dependent variable) is categorical and has more than two
#' levels, usually return coefficients for each response level. Hence, the
#' output from `model_parameters()` will split the coefficient tables
#' by the different levels of the model's response.
#'
#' @seealso [insight::standardize_names()] to rename
#' columns into a consistent, standardized naming scheme.
#'
#' @inheritSection model_parameters.zcpglm Model components
#'
#' @examplesIf require("brglm2", quietly = TRUE)
#' data("stemcell", package = "brglm2")
#' model <- brglm2::bracl(
#' research ~ as.numeric(religion) + gender,
#' weights = frequency,
#' data = stemcell,
#' type = "ML"
#' )
#' model_parameters(model)
#' @return A data frame of indices related to the model's parameters.
#' @inheritParams simulate_model
#' @export
model_parameters.mlm <- function(model,
ci = 0.95,
vcov = NULL,
vcov_args = NULL,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
out <- .model_parameters_generic(
model = model,
ci = ci,
vcov = vcov,
vcov_args = vcov_args,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Response"),
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.mlm <- function(model,
vcov = NULL,
vcov_args = NULL,
...) {
se <- standard_error.default(model, vcov = vcov, vcov_args = vcov_args, ...)
est <- insight::get_parameters(model, ...)
# assumes se and est are sorted the same way
if (isTRUE(nrow(se) == nrow(est)) && "Parameter" %in% colnames(est) && "Response" %in% colnames(est)) {
se$Parameter <- est$Parameter
se$Response <- est$Response
return(se)
} else {
# manually
if (!is.null(vcov)) {
insight::format_warning(
"Unable to extract the variance-covariance matrix requested in `vcov`."
)
}
cs <- stats::coef(summary(model))
se <- lapply(names(cs), function(x) {
params <- cs[[x]]
.data_frame(
Parameter = rownames(params),
SE = params[, "Std. Error"],
Response = gsub("^Response (.*)", "\\1", x)
)
})
se <- insight::text_remove_backticks(do.call(rbind, se), verbose = FALSE)
return(se)
}
}
#' @export
p_value.mlm <- function(model, vcov = NULL, vcov_args = NULL, ...) {
out <- p_value.default(model, vcov = vcov, vcov_args = vcov_args, ...)
est <- insight::get_parameters(model, ...)
# assumes out and est are sorted the same way
if (isTRUE(nrow(out) == nrow(est)) && "Parameter" %in% colnames(est) && "Response" %in% colnames(est)) {
out$Parameter <- est$Parameter
out$Response <- est$Response
# manually
} else {
if (!is.null(vcov)) {
insight::format_warning(
"Unable to extract the variance-covariance matrix requested in `vcov`."
)
}
cs <- stats::coef(summary(model))
p <- lapply(names(cs), function(x) {
params <- cs[[x]]
.data_frame(
Parameter = rownames(params),
p = params[, "Pr(>|t|)"],
Response = gsub("^Response (.*)", "\\1", x)
)
})
out <- insight::text_remove_backticks(do.call(rbind, p), verbose = FALSE)
}
return(out)
}
#' @export
ci.mlm <- function(x,
vcov = NULL,
vcov_args = NULL,
ci = 0.95, ...) {
# .ci_generic may not handle weights properly (not sure)
if (is.null(insight::find_weights(x)) && is.null(vcov)) {
out <- lapply(ci, function(i) {
.ci <- stats::confint(x, level = i, ...)
rn <- rownames(.ci)
.data_frame(
Parameter = gsub("([^\\:]+)(\\:)(.*)", "\\3", rn),
CI = i,
CI_low = .ci[, 1],
CI_high = .ci[, 2],
Response = gsub("([^\\:]+)(\\:)(.*)", "\\1", rn)
)
})
out <- insight::text_remove_backticks(do.call(rbind, out), verbose = FALSE)
# .ci_generic does handle `vcov` correctly.
} else {
out <- .data_frame(
.ci_generic(
x,
ci = ci,
vcov = vcov,
vcov_args = vcov_args,
...
)
)
resp <- insight::get_parameters(x)$Response
if (!"Response" %in% colnames(out) && nrow(out) == length(resp)) {
out[["Response"]] <- resp
} else if (!isTRUE(all(out$Response == resp))) {
insight::format_error(
"Unable to assign labels to the model's parameters.",
"Please report this problem to the {.pkg parameters} issue tracker:",
"{.url https://github.com/easystats/parameters/issues}"
)
}
}
out
}
#' @export
simulate_model.mlm <- function(model, iterations = 1000, ...) {
responses <- insight::find_response(model, combine = FALSE)
out <- .simulate_model(model, iterations, component = "conditional", effects = "fixed", ...)
cn <- paste0(colnames(out), rep(responses, each = length(colnames(out)) / length(responses)))
colnames(out) <- cn
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
simulate_parameters.mlm <- function(model,
iterations = 1000,
centrality = "median",
ci = 0.95,
ci_method = "quantile",
test = "p-value",
...) {
sim_data <- simulate_model(model, iterations = iterations, ...)
out <-
.summary_bootstrap(
data = sim_data,
test = test,
centrality = centrality,
ci = ci,
ci_method = ci_method,
...
)
out$Response <- NA
responses <- insight::find_response(model, combine = FALSE)
for (i in responses) {
out$Response[grepl(paste0(i, "$"), out$Parameter)] <- i
out$Parameter <- gsub(paste0(i, "$"), "", out$Parameter)
}
class(out) <- c("parameters_simulate", "see_parameters_simulate", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(out, "object_class") <- class(model)
attr(out, "iterations") <- iterations
attr(out, "ci") <- ci
attr(out, "ci_method") <- ci_method
attr(out, "centrality") <- centrality
out
}
parameters/R/methods_mixmod.R 0000644 0001762 0000144 00000004320 14717111737 015771 0 ustar ligges users #' @export
model_parameters.MixMod <- model_parameters.glmmTMB
#' @export
ci.MixMod <- function(x,
ci = 0.95,
component = c("all", "conditional", "zi", "zero_inflated"),
verbose = TRUE,
...) {
component <- match.arg(component)
if (is.null(.check_component(x, component, verbose = verbose))) {
return(NULL)
}
.ci_generic(
model = x,
ci = ci,
dof = Inf,
component = component,
...
)
}
#' @export
standard_error.MixMod <- function(model,
effects = "fixed",
component = "all",
verbose = TRUE,
...) {
component <- match.arg(component, choices = c("all", "conditional", "zi", "zero_inflated"))
effects <- match.arg(effects, choices = c("fixed", "random"))
if (effects == "random") {
insight::check_if_installed("lme4")
rand.se <- lme4::ranef(model, post_vars = TRUE)
vars.m <- attr(rand.se, "post_vars")
all_names <- attributes(rand.se)$dimnames
if (dim(vars.m[[1]])[1] == 1) {
rand.se <- sqrt(unlist(vars.m))
} else {
rand.se <- do.call(
rbind,
lapply(vars.m, function(.x) t(as.data.frame(sqrt(diag(.x)))))
)
rownames(rand.se) <- all_names[[1]]
colnames(rand.se) <- all_names[[2]]
rand.se <- list(rand.se)
names(rand.se) <- insight::find_random(model, flatten = TRUE)
}
rand.se
} else {
if (is.null(.check_component(model, component, verbose = verbose))) {
return(NULL)
}
vc <- insight::get_varcov(model, effects = "fixed", component = "all", ...)
se <- sqrt(diag(vc))
x <- .data_frame(
Parameter = names(se),
SE = as.vector(se),
Component = "conditional"
)
zi_parms <- startsWith(x$Parameter, "zi_")
if (any(zi_parms)) {
x$Component[zi_parms] <- "zero_inflated"
x$Parameter[zi_parms] <- gsub("^zi_(.*)", "\\1", x$Parameter[zi_parms])
}
.filter_component(x, component)
}
}
#' @export
simulate_model.MixMod <- simulate_model.glmmTMB
parameters/R/extract_parameters.R 0000644 0001762 0000144 00000076317 14741213247 016661 0 ustar ligges users # generic function ------------------------------------------------------
#' @keywords internal
.extract_parameters_generic <- function(model,
ci,
component,
merge_by = c("Parameter", "Component"),
standardize = NULL,
effects = "fixed",
ci_method = NULL,
p_adjust = NULL,
wb_component = FALSE,
verbose = TRUE,
keep_component_column = FALSE,
keep_parameters = NULL,
drop_parameters = NULL,
include_sigma = TRUE,
include_info = FALSE,
vcov = NULL,
vcov_args = NULL,
...) {
dots <- list(...)
# ==== check if standardization is required and package available
if (isTRUE(standardize)) {
if (verbose) {
insight::format_alert(
"`standardize` must be on of \"refit\", \"posthoc\", \"basic\", \"smart\" or \"pseudo\"."
)
}
standardize <- NULL
}
# ==== model exceptions
if (inherits(model, c("crq", "crqs"))) {
merge_by <- c("Parameter", "Component")
}
# ==== for refit, we completely refit the model, than extract parameters, ci etc. as usual
if (isTRUE(standardize == "refit")) {
fun_args <- c(list(model, verbose = FALSE), dots)
# argument name conflict with deprecated `robust`
fun_args[["robust"]] <- NULL
fun <- datawizard::standardize
model <- do.call(fun, fun_args)
}
parameters <- insight::get_parameters(model,
effects = effects,
component = component,
verbose = FALSE
)
statistic <- insight::get_statistic(model, component = component)
# check if all estimates are non-NA
parameters <- .check_rank_deficiency(model, parameters)
# ==== check if we really have a component column
if (!("Component" %in% names(parameters)) && "Component" %in% merge_by) {
merge_by <- setdiff(merge_by, "Component")
}
# ==== check Degrees of freedom
if (!.dof_method_ok(model, ci_method, type = "ci_method")) {
ci_method <- NULL
}
# ==== for ordinal models, first, clean parameter names and then indicate
# intercepts (alpha-coefficients) in the component column
if (inherits(model, "polr")) {
intercept_groups <- grep("Intercept:", parameters$Parameter, fixed = TRUE)
parameters$Parameter <- gsub("Intercept: ", "", parameters$Parameter, fixed = TRUE)
} else if (inherits(model, "clm") && !is.null(model$alpha)) {
intercept_groups <- rep(
c("intercept", "location", "scale"),
lengths(model[c("alpha", "beta", "zeta")])
)
} else if (inherits(model, "clm2") && !is.null(model$Alpha)) {
intercept_groups <- rep(
c("intercept", "location", "scale"),
lengths(model[c("Alpha", "beta", "zeta")])
)
} else if (inherits(model, "ordinal_weightit")) {
intercept_groups <- rep("conditional", nrow(parameters))
intercept_groups[grep("|", parameters$Parameter, fixed = TRUE)] <- "intercept"
} else {
intercept_groups <- NULL
}
original_order <- parameters$.id <- seq_len(nrow(parameters))
# column name for coefficients, non-standardized
coef_col <- "Coefficient"
# ==== CI - only if we don't already have CI for std. parameters
ci_cols <- NULL
if (!is.null(ci)) {
# set up arguments for CI function
fun_args <- list(model,
ci = ci,
component = component,
vcov = vcov,
vcov_args = vcov_args,
verbose = verbose
)
fun_args <- c(fun_args, dots)
# add method argument if provided
if (!is.null(ci_method)) {
fun_args[["method"]] <- ci_method
}
ci_df <- suppressMessages(do.call("ci", fun_args))
# success? merge CI into parameters
if (!is.null(ci_df)) {
# for multiple CI columns, reshape CI-dataframe to match parameters df
if (length(ci) > 1) {
ci_df <- datawizard::reshape_ci(ci_df)
}
# remember names of CI columns, used for later sorting of columns
ci_cols <- names(ci_df)[!names(ci_df) %in% c("CI", merge_by)]
parameters <- merge(parameters, ci_df, by = merge_by, sort = FALSE)
}
}
# ==== p value
fun_args <- list(model,
method = ci_method,
effects = effects,
verbose = verbose,
component = component,
vcov = vcov,
vcov_args = vcov_args
)
fun_args <- c(fun_args, dots)
pval <- do.call("p_value", fun_args)
# success? merge p-values into parameters
if (!is.null(pval)) {
parameters <- merge(parameters, pval, by = merge_by, sort = FALSE)
}
# ==== standard error - only if we don't already have SE for std. parameters
std_err <- NULL
fun_args <- list(model,
effects = effects,
component = component,
verbose = verbose,
vcov = vcov,
vcov_args = vcov_args
)
fun_args <- c(fun_args, dots)
if (!is.null(ci_method)) {
fun_args[["method"]] <- ci_method
}
std_err <- do.call("standard_error", fun_args)
# success? merge SE into parameters
if (!is.null(std_err)) {
parameters <- merge(parameters, std_err, by = merge_by, sort = FALSE)
}
# ==== test statistic - fix values for robust vcov
if (!is.null(vcov)) {
parameters$Statistic <- parameters$Estimate / parameters$SE
} else if (!is.null(statistic)) {
parameters <- merge(parameters, statistic, by = merge_by, sort = FALSE)
}
# ==== degrees of freedom
if (is.null(ci_method)) {
df_error <- insight::get_df(x = model, type = "wald", verbose = FALSE)
} else {
df_error <- insight::get_df(x = model, type = ci_method, verbose = FALSE)
}
if (!is.null(df_error) && (length(df_error) == 1 || length(df_error) == nrow(parameters))) {
if (length(df_error) == 1) {
parameters$df_error <- df_error
} else {
# order may have changed due to merging, so make sure
# df are in correct order.
parameters$df_error <- df_error[order(parameters$.id)]
}
}
# ==== Rematch order after merging
parameters <- parameters[match(original_order, parameters$.id), ]
# ==== Renaming
if ("Statistic" %in% names(parameters)) {
stat_type <- attr(statistic, "statistic", exact = TRUE)
if (!is.null(stat_type)) {
names(parameters) <- gsub("Statistic", gsub("(-|\\s)statistic", "", stat_type), names(parameters), fixed = TRUE)
names(parameters) <- gsub("chi-squared", "Chi2", names(parameters), fixed = TRUE)
}
}
names(parameters) <- gsub("(c|C)hisq", "Chi2", names(parameters))
names(parameters) <- gsub("Estimate", "Coefficient", names(parameters), fixed = TRUE)
# ==== add intercept groups for ordinal models
if (inherits(model, "polr") && !is.null(intercept_groups)) {
parameters$Component <- "beta"
parameters$Component[intercept_groups] <- "alpha"
} else if (inherits(model, c("clm", "clm2", "ordinal_weightit")) && !is.null(intercept_groups)) {
parameters$Component <- intercept_groups
}
# ==== remove Component column if not needed
if (!is.null(parameters$Component) && insight::n_unique(parameters$Component) == 1 && !keep_component_column) parameters$Component <- NULL # nolint
if ((!is.null(parameters$Effects) && insight::n_unique(parameters$Effects) == 1) || effects == "fixed") parameters$Effects <- NULL # nolint
# ==== filter parameters, if requested
if (!is.null(keep_parameters) || !is.null(drop_parameters)) {
parameters <- .filter_parameters(parameters,
keep = keep_parameters,
drop = drop_parameters,
verbose = verbose
)
}
# ==== adjust p-values?
if (!is.null(p_adjust)) {
parameters <- .p_adjust(parameters, p_adjust, model, verbose)
}
# ==== remove all complete-missing cases
parameters <- parameters[apply(parameters, 1, function(i) !all(is.na(i))), ]
# ==== add within/between attributes
if (inherits(model, c("glmmTMB", "MixMod")) && isTRUE(wb_component)) {
parameters <- .add_within_between_effects(model, parameters)
}
# ==== Std Coefficients for other methods than "refit"
if (!is.null(standardize) && !isTRUE(standardize == "refit")) {
# give minimal attributes required for standardization
temp_pars <- parameters
class(temp_pars) <- c("parameters_model", class(temp_pars))
attr(temp_pars, "ci") <- ci
attr(temp_pars, "object_name") <- model # pass the model as is (this is a cheat - teehee!)
std_parms <- standardize_parameters(temp_pars, method = standardize)
parameters$Std_Coefficient <- std_parms$Std_Coefficient
parameters$SE <- attr(std_parms, "standard_error")
if (!is.null(ci)) {
parameters$CI_low <- std_parms$CI_low
parameters$CI_high <- std_parms$CI_high
}
coef_col <- "Std_Coefficient"
}
# ==== Reorder
col_order <- c(
"Parameter", coef_col, "SE", ci_cols, "t", "z", "t / F", "t/F",
"z / Chisq", "z/Chisq", "z / Chi2", "z/Chi2", "F", "Chi2",
"chisq", "chi-squared", "Statistic", "df", "df_error", "p",
"Component", "Response", "Effects"
)
parameters <- parameters[col_order[col_order %in% names(parameters)]]
# ==== add sigma and residual df
if (isTRUE(include_sigma) || isTRUE(include_info)) {
parameters <- .add_sigma_residual_df(parameters, model)
}
rownames(parameters) <- NULL
parameters
}
# helper ----------------
.add_sigma_residual_df <- function(params, model) {
if (is.null(params$Component) || !"sigma" %in% params$Component) {
sig <- .safe(suppressWarnings(insight::get_sigma(model, ci = NULL, verbose = FALSE)))
attr(params, "sigma") <- as.numeric(sig)
resdf <- .safe(suppressWarnings(insight::get_df(x = model, type = "residual")))
attr(params, "residual_df") <- as.numeric(resdf)
}
params
}
.filter_parameters <- function(params, keep = NULL, drop = NULL, verbose = TRUE) {
if (!is.null(keep) && is.list(keep)) {
for (i in names(keep)) {
params <- .filter_parameters_vector(params,
keep[[i]],
drop = NULL,
column = i,
verbose = verbose
)
}
} else {
params <- .filter_parameters_vector(params,
keep,
drop,
column = NULL,
verbose = verbose
)
}
params
}
.filter_parameters_vector <- function(params,
keep = NULL,
drop = NULL,
column = NULL,
verbose = TRUE) {
# check pattern
if (!is.null(keep) && length(keep) > 1) {
keep <- paste0("(", paste(keep, collapse = "|"), ")")
if (verbose) {
insight::format_alert(
sprintf("The `keep` argument has more than 1 element. Merging into following regular expression: `%s`.", keep)
)
}
}
# check pattern
if (!is.null(drop) && length(drop) > 1) {
drop <- paste0("(", paste(drop, collapse = "|"), ")")
if (verbose) {
insight::format_alert(
sprintf("The `drop` argument has more than 1 element. Merging into following regular expression: `%s`.", drop)
)
}
}
if (is.null(column) || !column %in% colnames(params)) {
if ("Parameter" %in% colnames(params)) {
column <- "Parameter"
} else {
column <- 1
}
}
# row to keep and drop
if (is.null(keep)) {
rows_to_keep <- rep_len(TRUE, nrow(params))
} else {
rows_to_keep <- grepl(keep, params[[column]], perl = TRUE)
}
if (is.null(drop)) {
rows_to_drop <- rep_len(TRUE, nrow(params))
} else {
rows_to_drop <- !grepl(drop, params[[column]], perl = TRUE)
}
out <- params[rows_to_keep & rows_to_drop, ]
if (nrow(out) == 0) {
if (verbose) {
insight::format_alert(
"The pattern defined in the `keep` (and `drop`) arguments would remove all parameters from the output. Thus, selecting specific parameters will be ignored." # nolint
)
}
return(params)
}
out
}
# mixed models function ------------------------------------------------------
#' @keywords internal
.extract_parameters_mixed <- function(model,
ci = 0.95,
ci_method = "wald",
standardize = NULL,
p_adjust = NULL,
wb_component = FALSE,
keep_parameters = NULL,
drop_parameters = NULL,
include_sigma = FALSE,
include_info = FALSE,
vcov = NULL,
vcov_args = NULL,
verbose = TRUE,
...) {
dots <- list(...)
special_ci_methods <- c("betwithin", "satterthwaite", "ml1", "kenward", "kr")
# get parameters and statistic
parameters <- insight::get_parameters(model, effects = "fixed", component = "all", verbose = FALSE)
statistic <- insight::get_statistic(model, component = "all")
# check if all estimates are non-NA
parameters <- .check_rank_deficiency(model, parameters)
# sometimes, due to merge(), row-order messes up, so we save this here
original_order <- parameters$.id <- seq_len(nrow(parameters))
# remove SE column
parameters <- datawizard::data_remove(parameters, c("SE", "Std. Error"), verbose = FALSE)
# column name for coefficients, non-standardized
coef_col <- "Coefficient"
# Degrees of freedom
if (.dof_method_ok(model, ci_method)) {
dof <- insight::get_df(x = model, type = ci_method, verbose = FALSE)
} else {
dof <- Inf
}
df_error <- data.frame(
Parameter = parameters$Parameter,
df_error = as.vector(dof),
stringsAsFactors = FALSE
)
# for KR-dof, we have the SE as well, to save computation time
df_error$SE <- attr(dof, "se", exact = TRUE)
# CI - only if we don't already have CI for std. parameters
ci_cols <- NULL
if (!is.null(ci)) {
# robust (current or deprecated)
if (!is.null(vcov) || isTRUE(list(...)[["robust"]])) {
fun_args <- list(model,
ci = ci,
vcov = vcov,
vcov_args = vcov_args,
verbose = verbose
)
fun_args <- c(fun_args, dots)
ci_df <- suppressMessages(do.call("ci", fun_args))
} else if (ci_method %in% c("kenward", "kr")) {
# special handling for KR-CIs, where we already have computed SE
ci_df <- .ci_kenward_dof(model, ci = ci, df_kr = df_error)
} else {
ci_df <- ci(model, ci = ci, method = ci_method, effects = "fixed")
}
if (length(ci) > 1) {
ci_df <- datawizard::reshape_ci(ci_df)
}
ci_cols <- names(ci_df)[!names(ci_df) %in% c("CI", "Parameter")]
parameters <- merge(parameters, ci_df, by = "Parameter", sort = FALSE)
}
# standard error - only if we don't already have SE for std. parameters
if (!"SE" %in% colnames(parameters)) {
if (!is.null(vcov) || isTRUE(dots[["robust"]])) {
fun_args <- list(model,
vcov = vcov,
vcov_args = vcov_args,
verbose = verbose
)
fun_args <- c(fun_args, dots)
parameters <- merge(parameters, do.call("standard_error", fun_args), by = "Parameter", sort = FALSE)
# special handling for KR-SEs, which we already have computed from dof
} else if ("SE" %in% colnames(df_error)) {
se_kr <- df_error
se_kr$df_error <- NULL
parameters <- merge(parameters, se_kr, by = "Parameter", sort = FALSE)
} else {
parameters <- merge(
parameters,
standard_error(model, method = ci_method, effects = "fixed"),
by = "Parameter",
sort = FALSE
)
}
}
# p value
if (!is.null(vcov) || isTRUE(list(...)[["robust"]])) {
fun_args <- list(model,
vcov = vcov,
vcov_args = vcov_args,
verbose = verbose
)
fun_args <- c(fun_args, dots)
parameters <- merge(parameters, do.call("p_value", fun_args), by = "Parameter", sort = FALSE)
} else if ("Pr(>|z|)" %in% names(parameters)) {
names(parameters)[grepl("Pr(>|z|)", names(parameters), fixed = TRUE)] <- "p"
} else if (ci_method %in% special_ci_methods) {
# special handling for KR-p, which we already have computed from dof
# parameters <- merge(parameters, .p_value_dof_kr(model, params = parameters, dof = df_error), by = "Parameter")
parameters <- merge(
parameters,
.p_value_dof(model, dof = df_error$df_error, method = ci_method, se = df_error$SE),
by = "Parameter",
sort = FALSE
)
} else {
parameters <- merge(
parameters,
p_value(model, dof = dof, effects = "fixed"),
by = "Parameter",
sort = FALSE
)
}
# adjust standard errors and test-statistic as well
if ((!is.null(vcov) || ci_method %in% special_ci_methods) ||
# deprecated argument
isTRUE(list(...)[["robust"]])) {
parameters$Statistic <- parameters$Estimate / parameters$SE
} else {
parameters <- merge(parameters, statistic, by = "Parameter", sort = FALSE)
}
# dof
if (!"df" %in% names(parameters)) {
if (!ci_method %in% special_ci_methods) {
df_error <- data.frame(
Parameter = parameters$Parameter,
df_error = insight::get_df(x = model, type = "wald"),
stringsAsFactors = FALSE
)
}
if (!is.null(df_error) && nrow(df_error) == nrow(parameters)) {
if ("SE" %in% colnames(df_error)) {
df_error$SE <- NULL
}
parameters <- merge(parameters, df_error, by = "Parameter", sort = FALSE)
}
}
# Rematch order after merging
parameters <- parameters[match(original_order, parameters$.id), ]
# Renaming
names(parameters) <- gsub(
"Statistic",
gsub("-statistic", "", attr(statistic, "statistic", exact = TRUE), fixed = TRUE),
names(parameters),
fixed = TRUE
)
names(parameters) <- gsub("Std. Error", "SE", names(parameters), fixed = TRUE)
names(parameters) <- gsub("Estimate", "Coefficient", names(parameters), fixed = TRUE)
names(parameters) <- gsub("t value", "t", names(parameters), fixed = TRUE)
names(parameters) <- gsub("z value", "z", names(parameters), fixed = TRUE)
# filter parameters, if requested
if (!is.null(keep_parameters) || !is.null(drop_parameters)) {
parameters <- .filter_parameters(parameters,
keep = keep_parameters,
drop = drop_parameters,
verbose = verbose
)
}
# adjust p-values?
if (!is.null(p_adjust)) {
parameters <- .p_adjust(parameters, p_adjust, model, verbose)
}
# if we have within/between effects (from demean()), we can add a component
# column for nicer printing...
if (isTRUE(wb_component)) {
parameters <- .add_within_between_effects(model, parameters)
}
# Std Coefficients for other methods than "refit"
if (!is.null(standardize)) {
temp_pars <- parameters
class(temp_pars) <- c("parameters_model", class(temp_pars))
attr(temp_pars, "ci") <- ci
attr(temp_pars, "object_name") <- model # pass the model as is (this is a cheat - teehee!)
std_parms <- standardize_parameters(temp_pars, method = standardize)
parameters$Std_Coefficient <- std_parms$Std_Coefficient
parameters$SE <- attr(std_parms, "standard_error")
if (!is.null(ci)) {
parameters$CI_low <- std_parms$CI_low
parameters$CI_high <- std_parms$CI_high
}
coef_col <- "Std_Coefficient"
}
# Reorder
col_order <- c("Parameter", coef_col, "SE", ci_cols, "t", "z", "df", "df_error", "p", "Component")
parameters <- parameters[col_order[col_order %in% names(parameters)]]
# add sigma
if (isTRUE(include_sigma) || isTRUE(include_info)) {
parameters <- .add_sigma_residual_df(parameters, model)
}
rownames(parameters) <- NULL
parameters
}
.add_within_between_effects <- function(model, parameters) {
# This function checks whether the model contains predictors that were
# "demeaned" using the "demean()" function. If so, these columns have an
# attribute indicating the within or between effect, and in such cases,
# this effect is used as "Component" value. by this, we get a nicer print
# for model parameters...
# extract attributes that indicate within and between effects
within_effects <- .find_within_between(model, "within-effect")
between_effects <- .find_within_between(model, "between-effect")
# if there are no attributes, return
if (is.null(within_effects) && is.null(between_effects)) {
return(parameters)
}
if (is.null(parameters$Component)) {
parameters$Component <- "rewb-contextual"
}
if (!is.null(within_effects)) {
index <- unique(unlist(sapply(
within_effects,
grep,
x = parameters$Parameter,
fixed = TRUE
), use.names = FALSE))
parameters$Component[index] <- "within"
}
if (!is.null(between_effects)) {
index <- unique(unlist(sapply(
between_effects,
grep,
x = parameters$Parameter,
fixed = TRUE
), use.names = FALSE))
parameters$Component[index] <- "between"
}
interactions <- grep(":", parameters$Parameter, fixed = TRUE)
if (length(interactions)) {
parameters$Component[interactions] <- "interactions"
}
if (((!all(c("within", "between") %in% parameters$Component)) && inherits(model, "merMod")) ||
all(parameters$Component == "rewb-contextual")) {
parameters$Component <- NULL
}
parameters
}
.find_within_between <- function(model, which_effect) {
mf <- stats::model.frame(model)
unlist(sapply(names(mf), function(i) {
if (!is.null(attr(mf[[i]], which_effect, exact = TRUE))) {
i
}
}), use.names = FALSE)
}
# Bayes function ------------------------------------------------------
#' @keywords internal
.extract_parameters_bayesian <- function(model,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
bf_prior = NULL,
diagnostic = c("ESS", "Rhat"),
priors = FALSE,
standardize = NULL,
keep_parameters = NULL,
drop_parameters = NULL,
verbose = TRUE,
...) {
# no ROPE for multi-response models
if (insight::is_multivariate(model) && any(c("rope", "p_rope") %in% test)) {
test <- setdiff(test, c("rope", "p_rope"))
if (verbose) {
insight::format_alert(
"Multivariate response models are not yet supported for tests `rope` and `p_rope`."
)
}
}
# MCMCglmm need special handling
if (inherits(model, "MCMCglmm")) {
parameters <- bayestestR::describe_posterior(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
diagnostic = "ESS",
verbose = verbose,
...
)
} else if (is.null(standardize)) {
parameters <- bayestestR::describe_posterior(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = bf_prior,
diagnostic = diagnostic,
priors = priors,
verbose = verbose,
...
)
} else {
parameters <- bayestestR::describe_posterior(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = bf_prior,
diagnostic = diagnostic,
priors = priors,
verbose = verbose,
...
)
# Don't test BF on standardized params
test_no_BF <- test[!test %in% c("bf", "bayesfactor", "bayes_factor")]
if (length(test_no_BF) == 0) test_no_BF <- NULL
std_post <- standardize_posteriors(model, method = standardize)
std_parameters <- bayestestR::describe_posterior(
std_post,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test_no_BF,
rope_range = rope_range,
rope_ci = rope_ci,
verbose = verbose,
...
)
parameters <- merge(
std_parameters,
parameters[c("Parameter", setdiff(colnames(parameters), colnames(std_parameters)))],
sort = FALSE
)
}
if (length(ci) > 1) {
parameters <- datawizard::reshape_ci(parameters)
}
# Remove unnecessary columns
if ("CI" %in% names(parameters) && insight::n_unique(parameters$CI) == 1) {
parameters$CI <- NULL
}
if ("ROPE_CI" %in% names(parameters) && insight::n_unique(parameters$ROPE_CI) == 1) {
parameters$ROPE_CI <- NULL
}
if ("ROPE_low" %in% names(parameters) && "ROPE_high" %in% names(parameters)) {
parameters$ROPE_low <- NULL
parameters$ROPE_high <- NULL
}
# filter parameters, if requested
if (!is.null(keep_parameters) || !is.null(drop_parameters)) {
parameters <- .filter_parameters(parameters,
keep = keep_parameters,
drop = drop_parameters,
verbose = verbose
)
}
rownames(parameters) <- NULL
# indicate it's a Bayesian model
attr(parameters, "is_bayesian") <- TRUE
parameters
}
# SEM function ------------------------------------------------------
#' @keywords internal
.extract_parameters_lavaan <- function(model,
ci = 0.95,
standardize = FALSE,
keep_parameters = NULL,
drop_parameters = NULL,
verbose = TRUE,
...) {
insight::check_if_installed("lavaan")
# lavaan::parameterEstimates does not accept NULL `level`, but a lot of our
# other methods do. It is often useful to pass `NULL` to speed things up,
# but it doesn't work here.
if (is.null(ci)) {
ci <- 0.95
}
# set proper default
if (is.null(standardize)) {
standardize <- FALSE
}
# check for valid parameters
valid_std_options <- c("all", "std.all", "latent", "std.lv", "no_exogenous", "std.nox")
if (!is.logical(standardize) && !(standardize %in% valid_std_options)) {
if (verbose) {
insight::format_alert(
"`standardize` should be one of `TRUE`, \"all\", \"std.all\", \"latent\", \"std.lv\", \"no_exogenous\" or \"std.nox\".", # nolint
"Returning unstandardized solution."
)
}
standardize <- FALSE
}
# CI
if (length(ci) > 1L) {
ci <- ci[1]
if (verbose) {
insight::format_alert(
paste0("lavaan models only accept one level of CI. Keeping the first one: `ci = ", ci, "`.")
)
}
}
# collect dots
dot_args <- list(...)
# list all argument names from the `lavaan` function
dot_args <- dot_args[names(dot_args) %in% c(
"zstat",
"pvalue",
"standardized",
"fmi",
"level",
"boot.ci.type",
"cov.std",
"fmi.options",
"rsquare",
"remove.system.eq",
"remove.eq",
"remove.ineq",
"remove.def",
"remove.nonfree",
"add.attributes",
"output",
"header"
)]
# Get estimates
sem_data <- do.call(
lavaan::parameterEstimates,
c(
list(object = model, se = TRUE, ci = TRUE, level = ci),
dot_args
)
)
label <- sem_data$label
# check if standardized estimates are requested, and if so, which type
if (isTRUE(standardize) || !is.logical(standardize)) {
if (is.logical(standardize)) {
standardize <- "all"
}
type <- switch(standardize,
all = ,
std.all = "std.all",
latent = ,
std.lv = "std.lv",
no_exogenous = ,
std.nox = "std.nox",
"std.all"
)
# this function errors on unknown arguments
valid <- names(formals(lavaan::standardizedsolution))
dots <- list(...)
dots <- dots[names(dots) %in% valid]
fun_args <- c(list(model, se = TRUE, level = ci, type = type), dots)
f <- utils::getFromNamespace("standardizedsolution", "lavaan")
sem_data <- do.call("f", fun_args)
names(sem_data)[names(sem_data) == "est.std"] <- "est"
}
params <- data.frame(
To = sem_data$lhs,
Operator = sem_data$op,
From = sem_data$rhs,
Coefficient = sem_data$est,
SE = sem_data$se,
CI_low = sem_data$ci.lower,
CI_high = sem_data$ci.upper,
z = sem_data$z,
p = sem_data$pvalue,
stringsAsFactors = FALSE
)
if (!is.null(label)) {
params$Label <- label
}
params$Component <- NA_character_
params$Component[params$Operator == "=~"] <- "Loading"
params$Component[params$Operator == "~"] <- "Regression"
params$Component[params$Operator == "~~"] <- "Correlation"
params$Component[params$Operator == ":="] <- "Defined"
params$Component[params$Operator == "~1"] <- "Mean"
params$Component[as.character(params$From) == as.character(params$To)] <- "Variance"
if ("p" %in% colnames(params)) {
params$p[is.na(params$p)] <- 0
}
if ("group" %in% names(sem_data)) {
params$Group <- sem_data$group
}
# filter parameters, if requested
if (!is.null(keep_parameters) || !is.null(drop_parameters)) {
params <- .filter_parameters(params,
keep = keep_parameters,
drop = drop_parameters,
verbose = verbose
)
}
params
}
# tools -------------------------
.check_rank_deficiency <- function(model, p, verbose = TRUE) {
# for cox-panel models, we have non-linear parameters with NA coefficient,
# but test statistic and p-value - don't check for NA estimates in this case
if (!is.null(model) && inherits(model, "coxph.penal")) {
return(p)
}
if (anyNA(p$Estimate)) {
if (isTRUE(verbose)) {
insight::format_alert(
sprintf(
"Model matrix is rank deficient. Parameters `%s` were not estimable.",
toString(p$Parameter[is.na(p$Estimate)])
)
)
}
p <- p[!is.na(p$Estimate), ]
}
p
}
parameters/R/methods_mvord.R 0000644 0001762 0000144 00000006217 14761570351 015632 0 ustar ligges users # classes: .mvord
#################### .mvord
#' @export
model_parameters.mvord <- function(model,
ci = 0.95,
component = "all",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(component, c("all", "conditional", "thresholds", "correlation"))
out <- .model_parameters_generic(
model = model,
ci = ci,
component = component,
bootstrap = FALSE,
iterations = 10,
merge_by = c("Parameter", "Component", "Response"),
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
include_info = include_info,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.mvord <- function(model, component = c("all", "conditional", "thresholds", "correlation"), ...) {
component <- match.arg(component)
params <- insight::get_parameters(model, component = "all")
junk <- utils::capture.output({
s <- summary(model)
})
params$SE <- c(
unname(s$thresholds[, "Std. Error"]),
unname(s$coefficients[, "Std. Error"]),
unname(s$error.structure[, "Std. Error"])
)
params <- params[c("Parameter", "SE", "Component", "Response")]
if (insight::n_unique(params$Response) == 1) {
params$Response <- NULL
}
if (component != "all") {
params <- params[params$Component == component, , drop = FALSE]
}
insight::text_remove_backticks(params, verbose = FALSE)
}
#' @export
p_value.mvord <- function(model, component = c("all", "conditional", "thresholds", "correlation"), ...) {
component <- match.arg(component)
params <- insight::get_parameters(model, component = "all")
junk <- utils::capture.output({
s <- summary(model)
})
params$p <- c(
unname(s$thresholds[, "Pr(>|z|)"]),
unname(s$coefficients[, "Pr(>|z|)"]),
unname(s$error.structure[, "Pr(>|z|)"])
)
params <- params[c("Parameter", "p", "Component", "Response")]
if (insight::n_unique(params$Response) == 1) {
params$Response <- NULL
}
if (component != "all") {
params <- params[params$Component == component, , drop = FALSE]
}
insight::text_remove_backticks(params, verbose = FALSE)
}
#' @export
simulate_model.mvord <- function(model, iterations = 1000, component = c("all", "conditional", "thresholds", "correlation"), ...) {
component <- match.arg(component)
out <- .simulate_model(model, iterations, component = component, ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
parameters/R/utils_format.R 0000644 0001762 0000144 00000133410 14736731407 015467 0 ustar ligges users # output-format helper -------------------------
# this function does the main composition of columns for the output.
# it's used by "compare_parameters()", where users can choose between
# different pre-sets of "print-layouts"
.format_output_style <- function(x, style, format, modelname) {
if (identical(format, "html")) {
linesep <- "
"
} else {
linesep <- " "
}
if (!is.null(style) && style %in% c("se", "ci")) {
x$p_stars <- ""
}
# find columns
coef_column <- colnames(x)[1]
ci_column <- colnames(x)[endsWith(colnames(x), " CI") | colnames(x) == "CI"]
# make sure we have a glue-like syntax
style <- .convert_to_glue_syntax(style, linesep)
# "|" indicates cell split
style <- unlist(strsplit(style, split = "|", fixed = TRUE))
# define column names
if (length(style) == 1) {
column_names <- modelname
} else {
column_names <- .style_pattern_to_name(style)
}
# paste glue together
formatted_columns <- lapply(seq_along(style), function(i) {
.format_glue_output(x, coef_column, ci_column, style[i], format, column_names[i])
})
out <- do.call(cbind, formatted_columns)
# add modelname to column names; for single column layout per model, we just
# need the column name. If the layout contains more than one column per model,
# add modelname in parenthesis.
if (!is.null(modelname) && nzchar(modelname, keepNA = TRUE)) {
if (ncol(out) > 1) {
colnames(out) <- paste0(colnames(out), " (", modelname, ")")
} else {
colnames(out) <- modelname
}
}
# remove empty parenthesis
out[] <- lapply(out, function(i) {
# here we either have "
" or " " as line breaks, followed by empty "()"
i <- gsub("
()", "", i, fixed = TRUE)
i <- gsub(" ()", "", i, fixed = TRUE)
i <- gsub("
(, )", "", i, fixed = TRUE)
i <- gsub(" (, )", "", i, fixed = TRUE)
i[i == "()"] <- ""
i[i == "(, )"] <- ""
# remove other non-matched patterns
i <- gsub("{stars}", "", i, fixed = TRUE)
i <- gsub("{rhat}", "", i, fixed = TRUE)
i <- gsub("{ess}", "", i, fixed = TRUE)
i <- gsub("{pd}", "", i, fixed = TRUE)
i <- gsub("{rope}", "", i, fixed = TRUE)
i
})
out
}
.convert_to_glue_syntax <- function(style, linesep = NULL) {
# set default
if (is.null(linesep)) {
linesep <- " "
}
# default
if (is.null(style)) {
style <- paste0("{estimate}", linesep, "({ci})|{p}")
# style: estimate and CI, p-value in separate column (currently identical to "ci_p2")
} else if (style %in% c("minimal", "ci_p2")) {
style <- paste0("{estimate}", linesep, "({ci})|{p}")
# style: estimate and CI, no p
} else if (style == "ci") {
style <- paste0("{estimate}", linesep, "({ci})")
# style: estimate, p-stars and CI
} else if (style == "ci_p") {
style <- paste0("{estimate}{stars}", linesep, "({ci})")
# style: estimate and SE, no p
} else if (style == "se") {
style <- paste0("{estimate}", linesep, "({se})")
# style: estimate, p-stars and SE
} else if (style == "se_p") {
style <- paste0("{estimate}{stars}", linesep, "({se})")
# style: estimate and SE, p-value in separate column
} else if (style %in% c("short", "se_p2")) {
style <- paste0("{estimate}", linesep, "({se})|{p}")
# style: only estimate
} else if (style %in% c("est", "coef")) {
style <- "{estimate}"
}
# replace \n for now with default line-separators
gsub("\n", linesep, style, fixed = TRUE)
}
.format_glue_output <- function(x, coef_column, ci_column, style, format, column_names) {
# separate CI columns, for custom layout
ci <- ci_low <- ci_high <- NULL
if (!insight::is_empty_object(ci_column)) {
ci <- x[[ci_column[1]]]
ci_low <- insight::trim_ws(gsub("(\\(|\\[)(.*),(.*)(\\)|\\])", "\\2", ci))
ci_high <- insight::trim_ws(gsub("(\\(|\\[)(.*),(.*)(\\)|\\])", "\\3", ci))
}
# fix p-layout
if ("p" %in% colnames(x)) {
x[["p"]] <- insight::trim_ws(x[["p"]])
x[["p"]] <- gsub("< .", "<0.", x[["p"]], fixed = TRUE)
}
# handle aliases
style <- tolower(style)
style <- gsub("{coef}", "{estimate}", style, fixed = TRUE)
style <- gsub("{coefficient}", "{estimate}", style, fixed = TRUE)
style <- gsub("{std.error}", "{se}", style, fixed = TRUE)
style <- gsub("{standard error}", "{se}", style, fixed = TRUE)
style <- gsub("{pval}", "{p}", style, fixed = TRUE)
style <- gsub("{p.value}", "{p}", style, fixed = TRUE)
style <- gsub("{ci}", "{ci_low}, {ci_high}", style, fixed = TRUE)
# align columns width for text format
.align_values <- function(i) {
if (!is.null(i)) {
non_empty <- !is.na(i) & nzchar(i, keepNA = TRUE)
i[non_empty] <- format(insight::trim_ws(i[non_empty]), justify = "right")
}
i
}
# we put all elements (coefficient, SE, CI, p, ...) in one column.
# for text format, where columns are not center aligned, this can result in
# misaligned columns, which looks ugly. So we try to ensure that each element
# is formatted and justified to the same width
if (identical(format, "text") || is.null(format)) {
x[[coef_column]] <- .align_values(x[[coef_column]])
x$SE <- .align_values(x$SE)
x[["p"]] <- .align_values(x[["p"]])
x$p_stars <- .align_values(x$p_stars)
ci_low <- .align_values(ci_low)
ci_high <- .align_values(ci_high)
x$pd <- .align_values(x$pd)
x$Rhat <- .align_values(x$Rhat)
x$ESS <- .align_values(x$ESS)
x$ROPE_Percentage <- .align_values(x$ROPE_Percentage)
}
# create new string
table_row <- rep(style, times = nrow(x))
for (r in seq_along(table_row)) {
table_row[r] <- gsub("{estimate}", x[[coef_column]][r], table_row[r], fixed = TRUE)
if (!is.null(ci_low) && !is.null(ci_high)) {
table_row[r] <- gsub("{ci_low}", ci_low[r], table_row[r], fixed = TRUE)
table_row[r] <- gsub("{ci_high}", ci_high[r], table_row[r], fixed = TRUE)
}
if ("SE" %in% colnames(x)) {
table_row[r] <- gsub("{se}", x[["SE"]][r], table_row[r], fixed = TRUE)
}
if ("p" %in% colnames(x)) {
table_row[r] <- gsub("{p}", x[["p"]][r], table_row[r], fixed = TRUE)
}
if ("p_stars" %in% colnames(x)) {
table_row[r] <- gsub("{stars}", x[["p_stars"]][r], table_row[r], fixed = TRUE)
}
if ("pd" %in% colnames(x)) {
table_row[r] <- gsub("{pd}", x[["pd"]][r], table_row[r], fixed = TRUE)
}
if ("Rhat" %in% colnames(x)) {
table_row[r] <- gsub("{rhat}", x[["Rhat"]][r], table_row[r], fixed = TRUE)
}
if ("ESS" %in% colnames(x)) {
table_row[r] <- gsub("{ess}", x[["ESS"]][r], table_row[r], fixed = TRUE)
}
if ("ROPE_Percentage" %in% colnames(x)) {
table_row[r] <- gsub("{rope}", x[["ROPE_Percentage"]][r], table_row[r], fixed = TRUE)
}
}
# some cleaning: columns w/o coefficient are empty
table_row[x[[coef_column]] == "" | is.na(x[[coef_column]])] <- "" # nolint
# fix some p-value stuff, e.g. if pattern is "p={p]}",
# we may have "p= <0.001", which we want to be "p<0.001"
table_row <- gsub("=<", "<", table_row, fixed = TRUE)
table_row <- gsub("= <", "<", table_row, fixed = TRUE)
table_row <- gsub("= ", "=", table_row, fixed = TRUE)
# final output
x <- data.frame(table_row)
colnames(x) <- column_names
x
}
.style_pattern_to_name <- function(style) {
column_names <- tolower(style)
# completely remove these patterns
column_names <- gsub("{stars}", "", column_names, fixed = TRUE)
# remove curlys
column_names <- gsub("{", "", column_names, fixed = TRUE)
column_names <- gsub("}", "", column_names, fixed = TRUE)
# manual renaming
column_names <- gsub("\\Qrope\\E", "% in ROPE", column_names)
column_names <- gsub("(estimate|coefficient|coef)", "Estimate", column_names)
column_names <- gsub("\\Qse\\E", "SE", column_names)
column_names <- gsub("
", "", column_names, fixed = TRUE)
column_names
}
# global definition of valid "style" shortcuts
.style_shortcuts <- c("ci_p2", "ci", "ci_p", "se", "se_p", "se_p2", "est", "coef")
.select_shortcuts <- c("minimal", "short")
.add_obs_row <- function(x, att, style) {
observations <- unlist(lapply(att, function(i) {
if (is.null(i$n_obs)) {
NA
} else {
i$n_obs
}
}))
weighted_observations <- unlist(lapply(att, function(i) {
if (is.null(i$weighted_nobs)) {
NA
} else {
i$weighted_nobs
}
}))
# check if model had weights, and if due to missing values n of weighted
# observations differs from "raw" observations
if (!all(is.na(weighted_observations)) && !all(is.na(observations))) {
if (!isTRUE(all.equal(as.vector(weighted_observations), as.vector(observations)))) {
insight::format_alert("Number of weighted observations differs from number of unweighted observations.")
}
observations <- weighted_observations
}
if (!all(is.na(observations))) {
# add empty row, as separator
empty_row <- do.call(data.frame, as.list(rep(NA, ncol(x))))
colnames(empty_row) <- colnames(x)
x <- rbind(x, empty_row)
# add observations
steps <- (ncol(x) - 1) / length(observations)
empty_row[[1]] <- "Observations"
insert_at <- seq(2, ncol(x), by = steps)
for (i in seq_along(insert_at)) {
empty_row[[insert_at[i]]] <- observations[i]
}
x <- rbind(x, empty_row)
}
x
}
# other helper ------------------------
.format_columns_single_component <- function(x,
pretty_names,
digits = 2,
ci_digits = digits,
p_digits = 3,
ci_width = "auto",
ci_brackets = TRUE,
format = NULL,
coef_name = NULL,
zap_small = FALSE,
include_reference = FALSE,
...) {
# default brackets are parenthesis for HTML / MD
if ((is.null(ci_brackets) || isTRUE(ci_brackets)) && (identical(format, "html") || identical(format, "markdown"))) {
brackets <- c("(", ")")
} else if (is.null(ci_brackets) || isTRUE(ci_brackets)) {
brackets <- c("[", "]")
} else {
brackets <- ci_brackets
}
# fix coefficient column name for random effects
if (!is.null(x$Effects) && all(x$Effects == "random") && any(colnames(x) %in% .all_coefficient_types)) {
colnames(x)[colnames(x) %in% .all_coefficient_types] <- "Coefficient"
}
# fix coefficient column name for mixed count and zi pars
if (!is.null(x$Component) &&
sum(c("conditional", "zero_inflated", "dispersion") %in% x$Component) >= 2 &&
any(colnames(x) %in% .all_coefficient_types)) {
colnames(x)[colnames(x) %in% .all_coefficient_types] <- "Coefficient"
}
# random pars with level? combine into parameter column
if (all(c("Parameter", "Level") %in% colnames(x))) {
x$Parameter <- paste0(x$Parameter, " ", brackets[1], x$Level, brackets[2])
x$Level <- NULL
}
# add the coefficient for the base-(reference)-level of factors?
if (include_reference) {
x <- .add_reference_level(x)
}
insight::format_table(
x,
pretty_names = pretty_names,
digits = digits,
ci_width = ci_width,
ci_brackets = ci_brackets,
ci_digits = ci_digits,
p_digits = p_digits,
zap_small = zap_small,
...
)
}
.format_ranef_parameters <- function(x) {
if (!is.null(x$Group) && !is.null(x$Effects)) {
ran_pars <- which(x$Effects == "random")
stddevs <- startsWith(x$Parameter[ran_pars], "SD (")
x$Parameter[ran_pars[stddevs]] <- paste0(
gsub("(.*)\\)", "\\1", x$Parameter[ran_pars[stddevs]]),
": ",
x$Group[ran_pars[stddevs]],
")"
)
corrs <- startsWith(x$Parameter[ran_pars], "Cor (")
x$Parameter[ran_pars[corrs]] <- paste0(
gsub("(.*)\\)", "\\1", x$Parameter[ran_pars[corrs]]),
": ",
x$Group[ran_pars[corrs]],
")"
)
x$Parameter[x$Parameter == "SD (Observations: Residual)"] <- "SD (Residual)"
x$Group <- NULL
}
x
}
.add_reference_level <- function(params, model = NULL) {
if (is.null(model)) {
# check if we have a model object, if not provided by user
model <- .get_object(params)
}
# no model object provided? Try to get data from model call
if (is.null(model)) {
# get data from model call
model_data <- .safe(eval(attributes(params)$model_call$data))
} else {
# get data from model object
model_data <- insight::get_data(model, verbose = FALSE)
}
# check if we have model data, else return parameter table
if (is.null(model_data)) {
return(params)
}
# find factors and factor levels and check if we have any factors in the data
factors <- .find_factor_levels(model_data, model, model_call = attributes(params)$model_call)
if (!length(factors)) {
# in case of "on-the-fly" factors, e.g.:
# m <- lm(mpg ~ cut(wt, c(0, 2.5, 3, 5)), data = mtcars)
# we need to receive the data from the model frame, in order to find factors
model_data <- insight::get_data(model, source = "mf", verbose = FALSE)
if (!is.null(model_data)) {
factors <- .find_factor_levels(model_data, model, model_call = attributes(params)$model_call)
}
# if we still didn't find anything, quit...
if (!length(factors)) {
return(params)
}
}
# next, check contrasts of factors. including the reference level makes
# only sense if there are contrasts that are all zeros, which means that
# the reference level is not included in the model matrix
remove_contrasts <- .remove_reference_contrasts(model)
# keep only factors with valid contrasts
if (!is.null(remove_contrasts) && length(remove_contrasts)) {
factors <- factors[setdiff(names(factors), remove_contrasts)]
}
# we need some more information about prettified labels etc.
pretty_names <- attributes(params)$pretty_names
coef_name <- attributes(params)$coefficient_name
if (is.null(coef_name)) {
coef_name <- "Coefficient"
}
zi_coef_name <- attributes(params)$zi_coefficient_name
if (is.null(zi_coef_name)) {
zi_coef_name <- "Coefficient"
}
# copy object, so we save original data
out <- params
# sanity check - is pretty_names NULL? If so, use Parameters as pretty_names
if (is.null(pretty_names)) {
pretty_names <- stats::setNames(params$Parameter, params$Parameter)
}
# if we use "include_reference" and set "pretty_names = FALSE", pretty_names
# is no named vector. So we need to make sure we have a named vector
if (is.null(names(pretty_names))) {
pretty_names <- stats::setNames(pretty_names, params$Parameter)
}
# if we use "keep" or "drop", we have less parameters in our data frame,
# so we need to make sure we only have those pretty_names, which names match
# the parameters in the data frame
pretty_names <- pretty_names[names(pretty_names) %in% params$Parameter]
# iterate all factors in the data and check if any factor was used in the model
for (fn in names(factors)) {
f <- factors[[fn]]
# "f" contains all combinations of factor name and levels from the data,
# which we can match with the names of the pretty_names vector
found <- which(names(pretty_names) %in% f)
# if we have a match, we add the reference level to the pretty_names vector
if (length(found)) {
# the reference level is *not* in the pretty names yet
reference_level <- f[!f %in% names(pretty_names)]
# for on-the-fly conversion of factors, the names of the factors can
# can also contain "factor()" or "as.factor()" - we need to remove these
if (any(grepl("(as\\.factor|factor|as\\.character)", fn))) {
fn_clean <- gsub("(as\\.factor|factor|as\\.character)\\((.*)\\)", "\\2", fn)
} else {
fn_clean <- fn
}
# create a pretty level for the reference category
pretty_level <- paste0(fn_clean, " [", sub(fn, "", reference_level, fixed = TRUE), "]")
pretty_level <- gsub("_", " ", pretty_level, fixed = TRUE)
# special handling for "cut()"
pattern_cut_right <- "(.*)\\((.*),(.*)\\]\\]$"
pattern_cut_left <- "(.*)\\[(.*),(.*)\\)\\]$"
if (all(grepl(pattern_cut_right, pretty_level))) {
lower_bounds <- gsub(pattern_cut_right, "\\2", pretty_level)
upper_bounds <- gsub(pattern_cut_right, "\\3", pretty_level)
pretty_level <- gsub(pattern_cut_right, paste0("\\1>", as.numeric(lower_bounds), "-", upper_bounds, "]"), pretty_level)
} else if (all(grepl(pattern_cut_left, pretty_level))) {
lower_bounds <- gsub(pattern_cut_left, "\\2", pretty_level)
upper_bounds <- gsub(pattern_cut_left, "\\3", pretty_level)
pretty_level <- gsub(pattern_cut_left, paste0("\\1", as.numeric(lower_bounds), "-<", upper_bounds, "]"), pretty_level)
}
# insert new pretty level at the correct position in "pretty_names"
pretty_names <- .insert_element_at(
pretty_names,
stats::setNames(pretty_level, reference_level),
min(found)
)
# now we need to update the data as well (i.e. the parameters table)
row_data <- data.frame(
Parameter = reference_level,
Coefficient = as.numeric(attributes(params)$exponentiate),
stringsAsFactors = FALSE
)
# coefficient name can also be "Odds Ratio" etc., so make sure we
# have the correct column name in the data row we want to insert
if (coef_name %in% colnames(out)) {
colnames(row_data)[2] <- coef_name
} else if (zi_coef_name %in% colnames(out)) {
colnames(row_data)[2] <- zi_coef_name
}
out <- .insert_row_at(out, row_data, min(found))
}
}
# update pretty_names attribute
attr(out, "pretty_names") <- pretty_names
# update pretty_labels attribute
pretty_names[match(names(attr(out, "pretty_labels")), names(pretty_names))] <- attr(out, "pretty_labels")
attr(out, "pretty_labels") <- pretty_names
out
}
# The coefficient column in the printed output is renamed, based on the model.
# But for instance, for random effects, however, which are on a different scale,
# we want a different name for this column. Since print.parameters_model() splits
# components into different tables, we change the column name for those "tables"
# that contain the random effects or zero-inflation parameters
.all_coefficient_types <- c(
"Odds Ratio", "Risk Ratio", "Prevalence Ratio", "IRR", "Log-Odds",
"Log-Mean", "Log-Ratio", "Log-Prevalence", "Probability", "Marginal Means",
"Estimated Counts", "Ratio"
)
.all_coefficient_names <- c("Coefficient", "Std_Coefficient", "Estimate", "Median", "Mean", "MAP")
.format_stan_parameters <- function(out) {
has_component <- !is.null(out$Component)
# brms random intercepts or random slope variances
ran_sd <- startsWith(out$Parameter, "sd_") & out$Effects == "random"
if (any(ran_sd)) {
out$Parameter[ran_sd] <- gsub("^sd_(.*?)__(.*)", "SD \\(\\2\\)", out$Parameter[ran_sd])
if (has_component) {
ran_zi_sd <- ran_sd & out$Component == "zero_inflated"
if (any(ran_zi_sd)) {
out$Parameter[ran_zi_sd] <- gsub("zi_", "", out$Parameter[ran_zi_sd], fixed = TRUE)
}
}
}
# brms random slope-intercepts correlation
ran_cor <- startsWith(out$Parameter, "cor_") & out$Effects == "random"
if (any(ran_cor)) {
out$Parameter[ran_cor] <- gsub("^cor_(.*?)__(.*)__(.*)", "Cor \\(\\2~\\3\\)", out$Parameter[ran_cor])
if (has_component) {
ran_zi_cor <- ran_cor & out$Component == "zero_inflated"
if (any(ran_zi_cor)) {
out$Parameter[ran_zi_cor] <- gsub("zi_", "", out$Parameter[ran_zi_cor], fixed = TRUE)
}
}
}
# stanreg random effects variances
ran_sd_cor <- startsWith(out$Parameter, "Sigma[")
if (any(ran_sd_cor)) {
out$Parameter[ran_sd_cor] <- gsub("(Intercept)", "Intercept", out$Parameter[ran_sd_cor], fixed = TRUE)
parm1 <- gsub("^Sigma\\[(.*):(.*),(.*)\\]", "\\2", out$Parameter[ran_sd_cor])
parm2 <- gsub("^Sigma\\[(.*):(.*),(.*)\\]", "\\3", out$Parameter[ran_sd_cor])
# for random intercept or slopes, parm1 and parm2 are identical
ran_sd <- parm1 == parm2
ran_cor <- parm1 != parm2
if (any(ran_sd)) {
out$Parameter[which(ran_sd_cor)[ran_sd]] <- paste0("Sigma (", parm1[ran_sd], ")")
}
if (any(ran_cor)) {
out$Parameter[which(ran_sd_cor)[ran_cor]] <- paste0("Sigma (", parm1[ran_cor], "~", parm2[ran_cor], ")")
}
}
out
}
# helper to format the header / subheader of different model components --------------
.format_model_component_header <- function(x,
type,
split_column,
is_zero_inflated,
is_ordinal_model,
is_multivariate = FALSE,
ran_pars, # nolint
formatted_table = NULL) {
# prepare component names
.conditional_fixed_text <- if (is_zero_inflated) {
"Fixed Effects (Count Model)"
} else {
"Fixed Effects"
}
.conditional_random_text <- if (ran_pars) {
"Random Effects Variances"
} else if (is_zero_inflated) {
"Random Effects (Count Model)"
} else {
"Random Effects"
}
component_name <- switch(type,
mu = ,
fixed = ,
fixed. = ,
conditional = ,
conditional. = "Fixed Effects",
random. = ,
random = "Random Effects",
conditional.fixed = ,
conditional.fixed. = .conditional_fixed_text,
conditional.random = .conditional_random_text,
zero_inflated = "Zero-Inflation",
zero_inflated.fixed = ,
zero_inflated.fixed. = "Fixed Effects (Zero-Inflation Component)",
zero_inflated.random = "Random Effects (Zero-Inflation Component)",
survival = ,
survival.fixed = "Survival",
dispersion.fixed = ,
dispersion.fixed. = ,
dispersion = "Dispersion",
marginal = "Marginal Effects",
emmeans = "Estimated Marginal Means",
contrasts = "Contrasts",
simplex.fixed = ,
simplex = "Monotonic Effects",
smooth_sd = "Smooth Terms (SD)",
smooth_terms = "Smooth Terms",
sigma.fixed = ,
sigma.fixed. = ,
sigma = "Sigma",
thresholds = "Thresholds",
correlation = "Correlation",
`SD/Cor` = "SD / Correlation",
Loading = "Loading",
location = ,
location.fixed = ,
location.fixed. = "Location Parameters",
scale = ,
scale.fixed = ,
scale.fixed. = "Scale Parameters",
extra = ,
extra.fixed = ,
extra.fixed. = "Extra Parameters",
nu = "Nu",
tau = "Tau",
meta = "Meta-Parameters",
studies = "Studies",
within = "Within-Effects",
between = "Between-Effects",
interactions = "(Cross-Level) Interactions",
precision = ,
precision. = "Precision",
infrequent_purchase = "Infrequent Purchase",
auxiliary = "Auxiliary",
residual = "Residual",
intercept = "Intercept",
regression = "Regression",
latent = "Latent",
time_dummies = "Time Dummies",
type
)
if (grepl("^conditional\\.(r|R)andom_variances", component_name)) {
component_name <- insight::trim_ws(gsub("^conditional\\.(r|R)andom_variances(\\.)*", "", component_name))
if (nzchar(component_name, keepNA = TRUE)) {
component_name <- paste0("Random Effects Variances: ", component_name)
} else {
component_name <- "Random Effects Variances"
}
}
if (grepl("^conditional\\.(r|R)andom", component_name)) {
component_name <- insight::trim_ws(gsub("^conditional\\.(r|R)andom(\\.)*", "", component_name))
if (nzchar(component_name, keepNA = TRUE)) {
component_name <- paste0("Random Effects (Count Model): ", component_name)
} else {
component_name <- ifelse(ran_pars, "Random Effects Variances", "Random Effects (Count Model)")
}
}
if (grepl("^zero_inflated\\.(r|R)andom", component_name)) {
component_name <- insight::trim_ws(gsub("^zero_inflated\\.(r|R)andom(\\.)*", "", component_name))
if (nzchar(component_name, keepNA = TRUE)) {
component_name <- paste0("Random Effects (Zero-Inflation Component): ", component_name)
} else {
component_name <- "Random Effects (Zero-Inflation Component)"
}
}
if (startsWith(component_name, "random.")) {
component_name <- paste0("Random Effects: ", gsub("^random\\.", "", component_name))
}
# if we show ZI component only, make sure this appears in header
if (!grepl("(Zero-Inflation Component)", component_name, fixed = TRUE) &&
!is.null(formatted_table$Component) &&
all(formatted_table$Component == "zero_inflated")) {
component_name <- paste0(component_name, " (Zero-Inflation Component)")
}
# tweaking of sub headers
if (isTRUE(attributes(x)$is_ggeffects)) {
s1 <- gsub("(.*)\\.(.*) = (.*)", "\\1 (\\2 = \\3)", component_name)
s2 <- ""
} else if ("DirichletRegModel" %in% attributes(x)$model_class) {
if (startsWith(component_name, "conditional.") || split_column == "Response") {
s1 <- "Response level:"
s2 <- gsub("^conditional\\.(.*)", "\\1", component_name)
} else {
s1 <- component_name
s2 <- ""
}
} else if (length(split_column) > 1 && "Response" %in% split_column && is_multivariate) {
# This here only applies to brms multivariate response models
component_name <- gsub("^conditional\\.(.*)", "Response level: \\1", component_name)
component_name <- gsub("^sigma\\.(.*)", "Auxilliary parameters, response level: \\1", component_name)
component_name <- gsub("(.*)fixed\\.(.*)", "\\1\\2", component_name)
component_name <- gsub("(.*)random\\.(.*)", "Random effects, \\1\\2", component_name)
s1 <- component_name
s2 <- ""
} else if (length(split_column) > 1 ||
split_column %in% c("Subgroup", "Type", "Group") ||
grepl(tolower(split_column), tolower(component_name), fixed = TRUE) ||
component_name %in% c("Within-Effects", "Between-Effects", "(Cross-Level) Interactions")) {
s1 <- component_name
s2 <- ""
} else if (split_column == "Response" && is_ordinal_model) {
s1 <- "Response level:"
s2 <- component_name
} else {
s1 <- component_name
if (tolower(split_column) == "component") {
s2 <- ""
} else {
s2 <- split_column
}
}
list(name = component_name, subheader1 = s1, subheader2 = s2)
}
# helper grouping parameters -------------------
.parameter_groups <- function(x, groups) {
# only apply to conditional component for now
if ("Component" %in% colnames(x) && !any(x$Component == "conditional")) {
return(x)
}
if ("Component" %in% colnames(x)) {
row_index <- which(x$Component == "conditional")
} else {
row_index <- seq_len(nrow(x))
}
x_other <- x[-row_index, ]
x <- x[row_index, ]
att <- attributes(x)
indent_rows <- NULL
indent_parameters <- NULL
if (is.list(groups)) {
# find parameter names and replace by rowindex
group_rows <- lapply(groups, function(i) {
if (is.character(i)) {
i <- match(i, x$Parameter)
}
i
})
# validation check - check if all parameter names in the
# group list are spelled correctly
misspelled <- vapply(group_rows, anyNA, TRUE)
if (any(misspelled)) {
# remove invalid groups
group_rows[misspelled] <- NULL
# tell user
insight::format_alert(
"Couldn't find one or more parameters specified in following groups:",
toString(names(misspelled[misspelled])),
"Maybe you misspelled parameter names?"
)
}
# sort parameters according to grouping
selected_rows <- unlist(group_rows)
indent_parameters <- x$Parameter[selected_rows]
x <- rbind(x[selected_rows, ], x[-selected_rows, ])
# set back correct indices
groups <- 1
for (i in 2:length(group_rows)) {
groups <- c(groups, groups[i - 1] + length(group_rows[[i - 1]]))
}
names(groups) <- names(group_rows)
} else {
# find parameter names and replace by rowindex
group_names <- names(groups)
groups <- match(groups, x$Parameter)
names(groups) <- group_names
# order groups
groups <- sort(groups, na.last = TRUE)
}
empty_row <- x[1, ]
for (i in seq_len(ncol(empty_row))) {
empty_row[[i]] <- NA
}
for (i in rev(seq_along(groups))) {
x[seq(groups[i] + 1, nrow(x) + 1), ] <- x[seq(groups[i], nrow(x)), ]
x[groups[i], ] <- empty_row
x$Parameter[groups[i]] <- paste0("# ", names(groups[i]))
}
# find row indices of indented parameters
if (!is.null(indent_parameters)) {
indent_rows <- match(indent_parameters, x$Parameter)
}
# add other rows back
if (nrow(x_other) > 0) {
x <- rbind(x, x_other)
}
attributes(x) <- utils::modifyList(att, attributes(x))
attr(x, "indent_rows") <- indent_rows
attr(x, "indent_groups") <- "# "
x
}
# .insert_row <- function(x, newrow, r) {
# existingDF[seq(r+1,nrow(existingDF)+1),] <- existingDF[seq(r,nrow(existingDF)),]
# existingDF[r,] <- newrow
# existingDF
# }
.prepare_x_for_print <- function(x, select, coef_name, s_value) {
# minor fix for nested Anovas
if ("Group" %in% colnames(x) && sum(x$Parameter == "Residuals") > 1) {
colnames(x)[which(colnames(x) == "Group")] <- "Subgroup"
}
# check which columns to be printed
if (!is.null(select)) {
if (all(select == "minimal")) {
select <- c("Parameter", "Coefficient", "Std_Coefficient", "CI", "CI_low", "CI_high", "p")
} else if (all(select == "short")) {
select <- c("Parameter", "Coefficient", "Std_Coefficient", "SE", "p")
} else if (is.numeric(select)) {
select <- colnames(x)[select]
}
select <- union(select, c("Parameter", "Component", "Effects", "Response", "Subgroup"))
# for emmGrid objects, we save specific parameter names as attribute
parameter_names <- attributes(x)$parameter_names
if (!is.null(parameter_names)) {
select <- c(parameter_names, select)
}
to_remove <- setdiff(colnames(x), select)
x[to_remove] <- NULL
}
# remove columns that have only NA or Inf
to_remove <- vapply(colnames(x), function(col) {
all(is.na(x[[col]]) | is.infinite(x[[col]])) & !grepl("CI_", col, fixed = TRUE)
}, TRUE)
if (any(to_remove)) x[to_remove] <- NULL
# For Bayesian models, we need to prettify parameter names here...
mc <- attributes(x)$model_class
cp <- attributes(x)$cleaned_parameters
if (!is.null(mc) && !is.null(cp) && any(mc %in% c("stanreg", "stanmvreg", "brmsfit"))) {
match_params <- stats::na.omit(match(names(cp), x$Parameter))
if (any(match_params)) {
x$Parameter[match_params] <- cp[x$Parameter[match_params]]
}
attr(x, "pretty_names") <- FALSE
attr(x, "cleaned_parameters") <- NULL
}
# for bayesian meta, remove ROPE_CI
if (isTRUE(attributes(x)$is_bayes_meta)) {
x$CI <- NULL
x$ROPE_CI <- NULL
x$ROPE_low <- NULL
x$ROPE_high <- NULL
}
if (!is.null(coef_name)) {
colnames(x)[which(colnames(x) == "Coefficient")] <- coef_name
colnames(x)[which(colnames(x) == "Std_Coefficient")] <- paste0("Std_", coef_name)
}
# cpmpute s- instead of p-value?
# see 10.1186/s12874-020-01105-9
if (isTRUE(s_value) && "p" %in% colnames(x)) {
colnames(x)[colnames(x) == "p"] <- "s"
x[["s"]] <- log2(1 / x[["s"]])
}
x
}
.prepare_splitby_for_print <- function(x) {
if (!is.null(attributes(x)$model_class) && any(attributes(x)$model_class == "mvord")) {
x$Response <- NULL
}
split_by <- ""
if ("Component" %in% names(x) && insight::n_unique(x$Component) > 1) {
split_by <- c(split_by, "Component")
}
if ("Effects" %in% names(x) && insight::n_unique(x$Effects) > 1) {
split_by <- c(split_by, "Effects")
}
if ("Response" %in% names(x) && insight::n_unique(x$Response) > 1) {
split_by <- c(split_by, "Response")
}
if ("Group" %in% names(x) && insight::n_unique(x$Group) > 1) {
split_by <- c(split_by, "Group")
}
if ("Subgroup" %in% names(x) && insight::n_unique(x$Subgroup) > 1) {
split_by <- c(split_by, "Subgroup")
}
split_by <- split_by[nzchar(split_by, keepNA = TRUE)]
split_by
}
# this function is actually similar to "insight::print_parameters()", but more
# sophisticated, to ensure nicely outputs even for complicated or complex models,
# or edge cases...
#' @keywords internal
.format_columns_multiple_components <- function(x,
pretty_names,
split_column = "Component",
digits = 2,
ci_digits = digits,
p_digits = 3,
coef_column = NULL,
format = NULL,
ci_width = "auto",
ci_brackets = TRUE,
zap_small = FALSE,
include_reference = FALSE,
...) {
final_table <- list()
ignore_group <- isTRUE(attributes(x)$ignore_group)
ran_pars <- isTRUE(attributes(x)$ran_pars)
is_ggeffects <- isTRUE(attributes(x)$is_ggeffects)
is_fixest_multi <- identical(attributes(x)$model_class, "fixest_multi")
# name of "Parameter" column - usually the first column, however, for
# ggeffects objects, this column has the name of the focal term
if (is_ggeffects) {
parameter_column <- colnames(x)[1]
} else {
parameter_column <- "Parameter"
}
# default brackets are parenthesis for HTML / MD
if ((is.null(ci_brackets) || isTRUE(ci_brackets)) && (identical(format, "html") || identical(format, "markdown"))) {
ci_brackets <- c("(", ")")
} else if (is.null(ci_brackets) || isTRUE(ci_brackets)) {
ci_brackets <- c("[", "]")
}
# check ordinal / multivariate
is_ordinal_model <- isTRUE(attributes(x)$ordinal_model)
is_multivariate <- isTRUE(attributes(x)$multivariate_response)
# zero-inflation stuff
is_zero_inflated <- (!is.null(x$Component) & "zero_inflated" %in% x$Component)
zi_coef_name <- attributes(x)$zi_coefficient_name
# other special model-components, like emm_list
coef_name2 <- attributes(x)$coefficient_name2
# make sure we have correct order of levels from split-factor
if (!is.null(attributes(x)$model_class) && all(attributes(x)$model_class == "mediate")) {
x$Component <- factor(x$Component, levels = c("control", "treated", "average", "Total Effect"))
x$Parameter <- insight::trim_ws(gsub("(.*)\\((.*)\\)$", "\\1", x$Parameter))
} else {
x[split_column] <- lapply(x[split_column], function(i) {
if (!is.factor(i)) i <- factor(i, levels = unique(i))
i
})
}
# fix column output
if (inherits(attributes(x)[["model"]], c("lavaan", "blavaan")) && "Label" %in% colnames(x)) {
x$From <- ifelse(!nzchar(as.character(x$Label), keepNA = TRUE) | x$Label == x$To, x$From, paste0(x$From, " (", x$Label, ")")) # nolint
x$Label <- NULL
}
if (inherits(attributes(x)[["model"]], c("lavaan", "blavaan")) && !"Parameter" %in% colnames(x)) {
parameter_column <- colnames(x)[1]
}
if (inherits(attributes(x)[["model"]], c("lavaan", "blavaan")) && "Defined" %in% x$Component) {
x$From[x$Component == "Defined"] <- ""
x$Operator[x$Component == "Defined"] <- ""
x$To <- ifelse(x$Component == "Defined", paste0("(", x$To, ")"), x$To)
}
# set up split-factor
if (length(split_column) > 1) {
split_by <- lapply(split_column, function(i) x[[i]])
} else {
split_by <- list(x[[split_column]])
}
names(split_by) <- split_column
# make sure we have correct sorting here...
tables <- split(x, f = split_by)
# validation check - only preserve tables with any data in data frames
tables <- tables[vapply(tables, nrow, numeric(1)) > 0]
# fix table names for random effects, when we only have random
# effects. in such cases, the wrong header (fixed effects) is chosen
# to prevent this, we "fake" the name of the splitted components by
# prefixing them with "random."
if (!is.null(x$Effects) && all(x$Effects == "random") && !all(startsWith(names(tables), "random."))) {
wrong_names <- !startsWith(names(tables), "random.")
names(tables)[wrong_names] <- paste0("random.", names(tables)[wrong_names])
}
# fixest_multi models can have a special structure, with multiple responses
# and multiple rhs of formulas. We fix headers here
if (is_fixest_multi && length(split_column) > 1) {
old_names <- unique(paste0(x$Response, ".", x$Group))
new_names <- unique(paste0(x$Response, " ~ ", x$Group))
names(tables) <- new_names[match(names(tables), old_names)]
}
for (type in names(tables)) {
# do we have emmeans emlist? and contrasts?
model_class <- attributes(tables[[type]])$model_class
em_list_coef_name <- (!is.null(model_class) && "emm_list" %in% model_class &&
"contrasts" %in% tables[[type]]$Component)
# Don't print Component column
for (i in split_column) {
tables[[type]][[i]] <- NULL
}
# Smooth terms statistics
if ("t / F" %in% names(tables[[type]])) {
if (type == "smooth_terms") {
names(tables[[type]])[names(tables[[type]]) == "t / F"] <- "F"
}
if (type == "conditional") {
names(tables[[type]])[names(tables[[type]]) == "t / F"] <- "t"
}
} else if (type == "smooth_terms" && "t" %in% names(tables[[type]])) {
names(tables[[type]])[names(tables[[type]]) == "t"] <- "F"
}
if ("z / Chi2" %in% names(tables[[type]])) {
if (type == "smooth_terms") {
names(tables[[type]])[names(tables[[type]]) == "z / Chi2"] <- "Chi2"
}
if (type == "conditional") {
names(tables[[type]])[names(tables[[type]]) == "z / Chi2"] <- "z"
}
}
# Don't print se and ci if all are missing
if (all(is.na(tables[[type]]$SE))) tables[[type]]$SE <- NULL
if (all(is.na(tables[[type]]$CI_low)) && all(is.na(tables[[type]]$CI_high))) {
tables[[type]]$CI_low <- NULL
tables[[type]]$CI_high <- NULL
}
# if (all(is.na(tables[[type]]$CI_low))) tables[[type]]$CI_low <- NULL
# if (all(is.na(tables[[type]]$CI_high))) tables[[type]]$CI_high <- NULL
# Don't print if empty col
tables[[type]][vapply(colnames(tables[[type]]), function(x) {
column <- tables[[type]][[x]]
(!any(nzchar(as.character(column), keepNA = TRUE)) | all(is.na(column))) && !grepl("_CI_(high|low)$", x)
}, logical(1))] <- NULL
attr(tables[[type]], "digits") <- digits
attr(tables[[type]], "ci_digits") <- ci_digits
attr(tables[[type]], "p_digits") <- p_digits
# random pars with level? combine into parameter column
if (all(c("Parameter", "Level") %in% colnames(tables[[type]]))) {
tables[[type]]$Parameter <- paste0(
tables[[type]]$Parameter, " ", ci_brackets[1],
tables[[type]]$Level, ci_brackets[2]
)
tables[[type]]$Level <- NULL
}
# rename columns for emmeans contrast part
if (em_list_coef_name && !is.null(coef_column)) {
colnames(tables[[type]])[which(colnames(tables[[type]]) == coef_column)] <- coef_name2
}
# rename columns for zero-inflation part
if (startsWith(type, "zero") && !is.null(zi_coef_name) && !is.null(coef_column)) {
colnames(tables[[type]])[which(colnames(tables[[type]]) == coef_column)] <- zi_coef_name
colnames(tables[[type]])[which(colnames(tables[[type]]) == paste0("Std_", coef_column))] <- paste0("Std_", zi_coef_name) # nolint
}
# rename columns for correlation, location or scale part
if (type %in% c("correlation", "scale", "location") && !is.null(coef_column)) {
colnames(tables[[type]])[which(colnames(tables[[type]]) == coef_column)] <- "Estimate"
}
# rename columns for dispersion part
if (startsWith(type, "dispersion") && !is.null(coef_column)) {
colnames(tables[[type]])[which(colnames(tables[[type]]) == coef_column)] <- "Coefficient"
}
# rename columns for random part
if (grepl("random", type, fixed = TRUE) && any(colnames(tables[[type]]) %in% .all_coefficient_types)) {
colnames(tables[[type]])[colnames(tables[[type]]) %in% .all_coefficient_types] <- "Coefficient"
}
if (grepl("random", type, fixed = TRUE) && isTRUE(ran_pars)) {
tables[[type]]$CI <- NULL
}
# for ggeffects objects, only choose selected lines, to have
# a more compact output
if (is_ggeffects && is.numeric(tables[[type]][[1]])) {
n_rows <- nrow(tables[[type]])
row_steps <- round(sqrt(n_rows))
sample_rows <- round(c(1, stats::quantile(seq_len(n_rows), seq_len(row_steps - 2) / row_steps), n_rows))
tables[[type]] <- tables[[type]][sample_rows, ]
tables[[type]][[1]] <- insight::format_value(tables[[type]][[1]], digits = digits, protect_integers = TRUE)
}
# add the coefficient for the base-(reference)-level of factors?
if (include_reference) {
tables[[type]] <- .add_reference_level(tables[[type]])
}
formatted_table <- insight::format_table(
tables[[type]],
digits = digits, ci_digits = ci_digits,
p_digits = p_digits, pretty_names = pretty_names, ci_width = ci_width,
ci_brackets = ci_brackets, zap_small = zap_small, ...
)
component_header <- .format_model_component_header(
x, type, split_column, is_zero_inflated, is_ordinal_model,
is_multivariate, ran_pars, formatted_table
)
# exceptions for random effects
if (insight::n_unique(formatted_table$Group) == 1) {
component_header$subheader1 <- paste0(component_header$subheader1, " (", formatted_table$Group, ")")
formatted_table$Group <- NULL
}
# remove non-necessary columns
if (insight::n_unique(formatted_table$Component) == 1) {
formatted_table$Component <- NULL
}
# no column with CI-level in output
if (!is.null(formatted_table$CI) && insight::n_unique(formatted_table$CI) == 1) {
formatted_table$CI <- NULL
}
table_caption <- NULL
if (is.null(format) || format %in% c("markdown", "text")) {
# Print
if (component_header$name != "rewb-contextual") {
table_caption <- c(
sprintf("# %s %s", component_header$subheader1, tolower(component_header$subheader2)),
"blue"
)
}
} else if (format %in% c("markdown", "html")) {
# Print
if (component_header$name != "rewb-contextual") {
table_caption <- sprintf("%s %s", component_header$subheader1, tolower(component_header$subheader2))
}
# replace brackets by parenthesis
if (!is.null(parameter_column) && parameter_column %in% colnames(formatted_table)) {
formatted_table[[parameter_column]] <- gsub("[", ci_brackets[1], formatted_table[[parameter_column]], fixed = TRUE) # nolint
formatted_table[[parameter_column]] <- gsub("]", ci_brackets[2], formatted_table[[parameter_column]], fixed = TRUE) # nolint
}
}
if (identical(format, "html")) {
formatted_table$Component <- table_caption
} else {
attr(formatted_table, "table_caption") <- table_caption
}
# remove unique columns
if (insight::n_unique(formatted_table$Effects) == 1) formatted_table$Effects <- NULL
if (insight::n_unique(formatted_table$Group) == 1) formatted_table$Group <- NULL
final_table <- c(final_table, list(formatted_table))
}
if (identical(format, "html")) {
# fix non-equal length of columns
final_table <- .fix_nonmatching_columns(
final_table,
is_lavaan = inherits(attributes(x)[["model"]], c("lavaan", "blavaan"))
)
do.call(rbind, final_table)
} else {
insight::compact_list(final_table)
}
}
# helper to fix unequal number of columns for list of data frames,
# when used for HTML printing
.fix_nonmatching_columns <- function(final_table, is_lavaan = FALSE) {
# fix for lavaan here
if (is_lavaan) {
for (i in seq_along(final_table)) {
if (!is.null(final_table[[i]]$Link) && !is.null(final_table[[i]]$To) && all(is.na(final_table[[i]]$Link))) {
final_table[[i]]$Link <- final_table[[i]]$To
final_table[[i]]$To <- NA
}
colnames(final_table[[i]])[1] <- "Parameter"
if (!is.null(final_table[[i]]$To) && all(is.na(final_table[[i]]$To))) {
final_table[[i]]$To <- NULL
}
}
}
# then check for correct column length
col_len <- vapply(final_table, function(i) length(colnames(i)), numeric(1))
# remove non matching columns
if (!all(col_len == max(col_len))) {
all_columns <- unique(unlist(lapply(final_table, colnames)))
for (i in seq_along(final_table)) {
missing_columns <- setdiff(all_columns, colnames(final_table[[i]]))
if (length(missing_columns)) {
a <- attributes(final_table[[i]])
final_table[[i]][missing_columns] <- NA
final_table[[i]] <- final_table[[i]][match(all_columns, colnames(final_table[[i]]))]
attributes(final_table[[i]]) <- utils::modifyList(a, attributes(final_table[[i]]))
}
}
}
final_table
}
parameters/R/bootstrap_model.R 0000644 0001762 0000144 00000021701 14736731407 016153 0 ustar ligges users #' Model bootstrapping
#'
#' Bootstrap a statistical model n times to return a data frame of estimates.
#'
#' @param model Statistical model.
#' @param iterations The number of draws to simulate/bootstrap.
#' @param type Character string specifying the type of bootstrap. For mixed models
#' of class `merMod` or `glmmTMB`, may be `"parametric"` (default) or
#' `"semiparametric"` (see `?lme4::bootMer` for details). For all
#' other models, see argument `sim` in `?boot::boot` (defaults to
#' `"ordinary"`).
#' @param parallel The type of parallel operation to be used (if any).
#' @param n_cpus Number of processes to be used in parallel operation.
#' @param cluster Optional cluster when `parallel = "snow"`. See `?lme4::bootMer`
#' for details.
#' @param ... Arguments passed to or from other methods.
#' @inheritParams p_value
#'
#' @return A data frame of bootstrapped estimates.
#'
#' @details By default, `boot::boot()` is used to generate bootstraps from
#' the model data, which are then used to `update()` the model, i.e. refit
#' the model with the bootstrapped samples. For `merMod` objects (**lme4**)
#' or models from **glmmTMB**, the `lme4::bootMer()` function is used to
#' obtain bootstrapped samples. `bootstrap_parameters()` summarizes the
#' bootstrapped model estimates.
#'
#' @section Using with **emmeans**:
#' The output can be passed directly to the various functions from the
#' **emmeans** package, to obtain bootstrapped estimates, contrasts, simple
#' slopes, etc. and their confidence intervals. These can then be passed to
#' `model_parameter()` to obtain standard errors, p-values, etc. (see
#' example).
#'
#' Note that that p-values returned here are estimated under the assumption of
#' *translation equivariance*: that shape of the sampling distribution is
#' unaffected by the null being true or not. If this assumption does not hold,
#' p-values can be biased, and it is suggested to use proper permutation tests
#' to obtain non-parametric p-values.
#'
#' @seealso [`bootstrap_parameters()`], [`simulate_model()`], [`simulate_parameters()`]
#'
#' @examplesIf require("boot", quietly = TRUE) && require("emmeans", quietly = TRUE)
#' \donttest{
#' model <- lm(mpg ~ wt + factor(cyl), data = mtcars)
#' b <- bootstrap_model(model)
#' print(head(b))
#'
#' est <- emmeans::emmeans(b, consec ~ cyl)
#' print(model_parameters(est))
#' }
#' @export
bootstrap_model <- function(model,
iterations = 1000,
...) {
UseMethod("bootstrap_model")
}
#' @rdname bootstrap_model
#' @export
bootstrap_model.default <- function(model,
iterations = 1000,
type = "ordinary",
parallel = "no",
n_cpus = 1,
cluster = NULL,
verbose = FALSE,
...) {
# check for valid input
.is_model_valid(model)
insight::check_if_installed("boot")
type <- insight::validate_argument(
type,
c("ordinary", "parametric", "balanced", "permutation", "antithetic")
)
parallel <- insight::validate_argument(parallel, c("no", "multicore", "snow"))
model_data <- data <- insight::get_data(model, verbose = FALSE) # nolint
model_response <- insight::find_response(model)
boot_function <- function(model, data, indices) {
d <- data[indices, ] # allows boot to select sample
if (inherits(model, "biglm")) {
fit <- suppressMessages(stats::update(model, moredata = d))
} else if (verbose) {
fit <- stats::update(model, data = d)
} else {
fit <- suppressMessages(stats::update(model, data = d))
}
params <- insight::get_parameters(fit, verbose = FALSE)
n_params <- insight::n_parameters(model)
if (nrow(params) != n_params) {
params <- stats::setNames(rep.int(NA, n_params), params$Parameter)
} else {
params <- stats::setNames(params$Estimate, params$Parameter) # Transform to named vector
}
params
}
if (type == "parametric") {
f <- function(x, mle) {
out <- model_data
resp <- stats::simulate(x, nsim = 1)
out[[model_response]] <- resp
out
}
results <- boot::boot(
data = data,
statistic = boot_function,
R = iterations,
sim = type,
parallel = parallel,
ncpus = n_cpus,
model = model,
ran.gen = f
)
} else {
results <- boot::boot(
data = data,
statistic = boot_function,
R = iterations,
sim = type,
parallel = parallel,
ncpus = n_cpus,
model = model
)
}
out <- as.data.frame(results$t)
out <- out[stats::complete.cases(out), ]
names(out) <- insight::get_parameters(model, verbose = FALSE)$Parameter
class(out) <- unique(c("bootstrap_model", "see_bootstrap_model", class(out)))
attr(out, "original_model") <- model
out
}
#' @export
bootstrap_model.merMod <- function(model,
iterations = 1000,
type = "parametric",
parallel = "no",
n_cpus = 1,
cluster = NULL,
verbose = FALSE,
...) {
insight::check_if_installed("lme4")
type <- insight::validate_argument(type, c("parametric", "semiparametric"))
parallel <- insight::validate_argument(parallel, c("no", "multicore", "snow"))
boot_function <- function(model) {
params <- insight::get_parameters(model, verbose = FALSE)
n_params <- insight::n_parameters(model)
# for glmmTMB, remove dispersion paramters, if any
if (inherits(model, "glmmTMB") && "Component" %in% names(params) && "dispersion" %in% params$Component) {
# find number of dispersion parameters
n_disp <- sum(params$Component == "dispersion")
# remove dispersion parameters
params <- params[params$Component != "dispersion", ]
# make sure number of parameters is updated
n_params <- n_params - n_disp
}
if (nrow(params) != n_params) {
params <- stats::setNames(rep.int(NA, n_params), params$Parameter)
} else {
params <- stats::setNames(params$Estimate, params$Parameter) # Transform to named vector
}
params
}
if (verbose) {
results <- lme4::bootMer(
model,
boot_function,
nsim = iterations,
type = type,
parallel = parallel,
ncpus = n_cpus,
cl = cluster
)
} else {
results <- suppressMessages(lme4::bootMer(
model,
boot_function,
nsim = iterations,
verbose = FALSE,
type = type,
parallel = parallel,
ncpus = n_cpus,
cl = cluster
))
}
out <- as.data.frame(results$t)
out <- out[stats::complete.cases(out), ]
names(out) <- insight::find_parameters(model, effects = "fixed")$conditional
class(out) <- unique(c("bootstrap_model", "see_bootstrap_model", class(out)))
attr(out, "original_model") <- model
out
}
#' @export
bootstrap_model.glmmTMB <- bootstrap_model.merMod
#' @export
bootstrap_model.nestedLogit <- function(model,
iterations = 1000,
type = "ordinary",
parallel = "no",
n_cpus = 1,
verbose = FALSE,
...) {
insight::check_if_installed("boot")
type <- insight::validate_argument(
type,
c("ordinary", "balanced", "permutation", "antithetic")
)
parallel <- insight::validate_argument(parallel, c("no", "multicore", "snow"))
model_data <- data <- insight::get_data(model, verbose = FALSE) # nolint
model_response <- insight::find_response(model)
boot_function <- function(model, data, indices) {
d <- data[indices, ] # allows boot to select sample
if (verbose) {
fit <- stats::update(model, data = d)
} else {
fit <- suppressMessages(stats::update(model, data = d))
}
params <- insight::get_parameters(fit, verbose = FALSE)
stats::setNames(params$Estimate, params$Parameter) # Transform to named vector
}
results <- boot::boot(
data = data,
statistic = boot_function,
R = iterations,
sim = type,
parallel = parallel,
ncpus = n_cpus,
model = model
)
out <- as.data.frame(results$t)
out <- out[stats::complete.cases(out), ]
params <- insight::get_parameters(model, verbose = FALSE)
names(out) <- paste0(params$Parameter, ".", params$Component)
class(out) <- unique(c("bootstrap_model", "see_bootstrap_model", class(out)))
attr(out, "original_model") <- model
out
}
parameters/R/methods_vgam.R 0000644 0001762 0000144 00000004360 14736731407 015435 0 ustar ligges users # classes: .vglm, .vgam
########### .vgam ---------------
#' @export
model_parameters.vgam <- model_parameters.gam
#' @export
standard_error.vgam <- function(model, ...) {
params <- insight::get_parameters(model)
se <- sqrt(diag(insight::get_varcov(model)))
# sort
se <- se[params$Parameter]
.data_frame(
Parameter = .remove_backticks_from_string(names(se)),
SE = as.vector(se),
Component = params$Component
)
}
#' @export
p_value.vgam <- function(model, ...) {
stat <- insight::get_statistic(model)
stat$p <- as.vector(stats::pchisq(stat$Statistic, df = insight::get_df(model), lower.tail = FALSE))
stat[c("Parameter", "p", "Component")]
}
#' @export
simulate_model.vgam <- function(model, iterations = 1000, ...) {
out <- .simulate_model(model, iterations, component = "all")
class(out) <- c("parameters_simulate_model", class(out))
out
}
########### .vglm ---------------
#' @export
p_value.vglm <- function(model, ...) {
insight::check_if_installed("VGAM")
cs <- VGAM::summary(model)@coef3
p <- cs[, 4]
.data_frame(
Parameter = .remove_backticks_from_string(names(p)),
p = as.vector(p)
)
}
#' @export
standard_error.vglm <- function(model, ...) {
se <- sqrt(diag(insight::get_varcov(model)))
.data_frame(
Parameter = .remove_backticks_from_string(names(se)),
SE = as.vector(se)
)
}
# ci.vgam <- function(x, ci = 0.95, component = c("all", "conditional", "smooth"), ...) {
# component <- match.arg(component)
#
# # dof and SE
# dof <- degrees_of_freedom(x)
# se <- standard_error(x)$SE
# params <- insight::get_parameters(x)
#
# se <- se[!is.na(dof)]
# dof <- dof[!is.na(dof)]
# params_names <- names(dof)
#
# # Wald CI for non-chisq parameters
# out <- .ci_generic(model = x, ci = ci, dof = Inf)
#
# chisq_fac <- stats::qchisq(se, df = dof, lower.tail = FALSE)
# for (i in 1:length(params_names)) {
# out$CI_low[out$Parameter == params_names[i]] <- params$Estimate[params$Parameter == params_names[i]] - se[i] * chisq_fac[i]
# out$CI_high[out$Parameter == params_names[i]] <- params$Estimate[params$Parameter == params_names[i]] + se[i] * chisq_fac[i]
# }
#
# out
# }
parameters/R/methods_rstanarm.R 0000644 0001762 0000144 00000011252 14761600263 016321 0 ustar ligges users #' @export
model_parameters.stanreg <- function(model,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
bf_prior = NULL,
diagnostic = c("ESS", "Rhat"),
priors = TRUE,
effects = "fixed",
exponentiate = FALSE,
standardize = NULL,
group_level = FALSE,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# for coef(), we don't need all the attributes and just stop here
if (effects %in% c("total", "random_total")) {
params <- .group_level_total(model)
params$Effects <- "total"
class(params) <- c("parameters_coef", "see_parameters_coef", class(params))
return(params)
}
# Processing
params <- .extract_parameters_bayesian(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = bf_prior,
diagnostic = diagnostic,
priors = priors,
effects = effects,
standardize = standardize,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
if (effects != "fixed") {
random_effect_levels <- which(
params$Effects == "random" & !startsWith(params$Parameter, "Sigma[")
)
if (length(random_effect_levels) && isFALSE(group_level)) {
params <- params[-random_effect_levels, , drop = FALSE]
}
}
## TODO: can we use the regular pretty-name-formatting?
params <- .add_pretty_names(params, model)
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(
params,
model,
ci,
exponentiate,
ci_method = ci_method,
group_level = group_level,
verbose = verbose,
...
)
attr(params, "parameter_info") <- insight::clean_parameters(model)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
model_parameters.stanmvreg <- function(model,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
bf_prior = NULL,
diagnostic = c("ESS", "Rhat"),
priors = TRUE,
effects = "fixed",
standardize = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# Processing
params <- .extract_parameters_bayesian(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = bf_prior,
diagnostic = diagnostic,
priors = priors,
effects = effects,
standardize = standardize,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
params$Parameter <- gsub("^(.*)\\|(.*)", "\\2", params$Parameter)
params <- .add_pretty_names(params, model)
attr(params, "ci") <- ci
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
standard_error.stanreg <- standard_error.brmsfit
#' @export
standard_error.mvstanreg <- standard_error.brmsfit
#' @export
p_value.stanreg <- p_value.BFBayesFactor
parameters/R/ci_ml1.R 0000644 0001762 0000144 00000000575 14317274256 014127 0 ustar ligges users #' @rdname p_value_ml1
#' @export
ci_ml1 <- function(model, ci = 0.95, ...) {
df_ml1 <- dof_ml1(model)
out <- lapply(ci, function(i) {
.ci_dof(
model = model,
ci = i,
effects = "fixed",
component = "all",
dof = df_ml1,
method = "ml1",
...
)
})
out <- do.call(rbind, out)
row.names(out) <- NULL
out
}
parameters/R/methods_margins.R 0000644 0001762 0000144 00000004245 14507235543 016141 0 ustar ligges users #' @export
model_parameters.margins <- function(model, ci = 0.95, exponentiate = FALSE, p_adjust = NULL, verbose = TRUE, ...) {
# Parameters, Estimate and CI
params <- insight::get_parameters(model)
params <- .data_frame(
params,
SE = summary(model)$SE
)
# CI
params <- merge(params, ci(model, ci = ci), by = "Parameter", sort = FALSE)
# Statistic
statistic <- insight::get_statistic(model)
params <- merge(params, statistic, by = "Parameter", sort = FALSE)
# p-value
params <- .data_frame(params, p = summary(model)$p)
# ==== Renaming
if ("Statistic" %in% names(params)) {
names(params) <- gsub(
"Statistic",
gsub("(-|\\s)statistic", "", attr(statistic, "statistic", exact = TRUE)),
names(params),
fixed = TRUE
)
names(params) <- gsub("chi-squared", "Chi2", names(params), fixed = TRUE)
}
names(params) <- gsub("(c|C)hisq", "Chi2", names(params))
names(params) <- gsub("Estimate", "Coefficient", names(params), fixed = TRUE)
# ==== adjust p-values?
if (!is.null(p_adjust)) {
params <- .p_adjust(params, p_adjust, model, verbose)
}
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(
params,
model,
ci,
exponentiate,
p_adjust = p_adjust,
verbose = verbose,
...
)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
ci.margins <- function(x, ci = 0.95, ...) {
.ci_generic(model = x, ci = ci, dof = Inf, ...)
}
#' @export
standard_error.margins <- function(model, ...) {
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
SE = summary(model)$SE
)
}
#' @export
p_value.margins <- function(model, ...) {
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
p = summary(model)$p
)
}
#' @export
format_parameters.margins <- function(model, ...) {
NULL
}
parameters/R/methods_pglm.R 0000644 0001762 0000144 00000000303 14004234333 015413 0 ustar ligges users #' @export
p_value.pglm <- function(model, ...) {
p <- summary(model)$estimate[, 4]
.data_frame(
Parameter = .remove_backticks_from_string(names(p)),
p = as.vector(p)
)
}
parameters/R/methods_marginaleffects.R 0000644 0001762 0000144 00000012052 14752352271 017626 0 ustar ligges users # x <- lm(Sepal.Width ~ Species * Petal.Length, data = iris)
# model <- marginaleffects(x, newdata = insight::get_datagrid(x, at = "Species"), variables = "Petal.Length")
# model_parameters ----------------
#' @export
model_parameters.marginaleffects <- function(model,
ci = 0.95,
exponentiate = FALSE,
...) {
insight::check_if_installed("marginaleffects")
tidy_model <- marginaleffects::tidy(model, conf_level = ci, ...)
out <- .rename_reserved_marginaleffects(tidy_model)
out <- insight::standardize_names(out, style = "easystats")
# in case data grid contained column names that are reserved words,
# rename those back now...
colnames(out) <- gsub("#####$", "", colnames(out))
# contrast_ columns provide indispensable information about the comparisons
colnames(out)[colnames(out) == "contrast"] <- "Comparison"
colnames(out) <- gsub("^contrast_", "Comparison: ", colnames(out))
out <- .safe(.add_model_parameters_attributes(out, model, ci, exponentiate = exponentiate, ...), out)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
# do not print or report these columns
out <- out[, !colnames(out) %in% c("predicted_lo", "predicted_hi"), drop = FALSE]
if (inherits(model, "marginalmeans")) {
attr(out, "coefficient_name") <- "Marginal Means"
} else if (inherits(model, "comparisons")) {
attr(out, "coefficient_name") <- "Estimate"
attr(out, "title") <- "Contrasts between Adjusted Predictions"
if ("Type" %in% colnames(out)) {
attr(out, "prediction_type") <- out$Type[1]
}
} else if (inherits(model, "slopes")) {
attr(out, "coefficient_name") <- "Slope"
} else if (inherits(model, "predictions")) {
attr(out, "coefficient_name") <- "Predicted"
} else if (inherits(model, "hypotheses")) {
attr(out, "coefficient_name") <- "Estimate"
}
# exponentiate coefficients and SE/CI, if requested
out <- .exponentiate_parameters(out, model = NULL, exponentiate)
# add further information as attributes
out <- .add_model_parameters_attributes(
out,
model = model,
ci = ci,
exponentiate = exponentiate,
...
)
class(out) <- c("parameters_model", "see_parameters_model", class(out))
out
}
#' @export
model_parameters.comparisons <- model_parameters.marginaleffects
#' @export
model_parameters.marginalmeans <- model_parameters.marginaleffects
#' @export
model_parameters.hypotheses <- model_parameters.marginaleffects
#' @export
model_parameters.slopes <- model_parameters.marginaleffects
#' @export
model_parameters.predictions <- function(model,
ci = 0.95,
exponentiate = FALSE,
...) {
insight::check_if_installed("marginaleffects")
out <- .rename_reserved_marginaleffects(model)
out <- datawizard::data_rename(out, "estimate", "predicted")
out <- datawizard::data_relocate(out, "predicted", before = 1)
out <- insight::standardize_names(out, style = "easystats")
out <- insight::standardize_column_order(out, style = "easystats")
# in case data grid contained column names that are reserved words,
# rename those back now...
colnames(out) <- gsub("#####$", "", colnames(out))
# remove and reorder some columns
out$rowid <- out$Type <- NULL
out <- datawizard::data_relocate(out, select = attributes(model)$newdata_at, after = "Predicted")
# extract response, remove from data frame
reg_model <- attributes(model)$model
if (!is.null(reg_model) && insight::is_model(reg_model)) {
resp <- insight::find_response(reg_model)
out[[resp]] <- NULL
}
out <- .safe(.add_model_parameters_attributes(out, model, ci, exponentiate = exponentiate, ...), out)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(out, "coefficient_name") <- "Predicted"
attr(out, "no_caption") <- TRUE
# exponentiate coefficients and SE/CI, if requested
out <- .exponentiate_parameters(out, model = NULL, exponentiate)
# add further information as attributes
out <- .add_model_parameters_attributes(
out,
model = model,
ci = ci,
exponentiate = exponentiate,
...
)
class(out) <- c("parameters_model", "see_parameters_model", class(out))
out
}
.rename_reserved_marginaleffects <- function(model) {
# get focal terms - we might escape column names where focal terms
# equal "reserved" names, like t- or z-statistic
focal_terms <- attributes(model)$focal_terms
reserved <- c("t", "z")
renamed_focal <- NULL
# any focal terms equals reserved words? if so, rename
if (any(reserved %in% focal_terms)) {
renamed_focal <- focal_terms[focal_terms %in% reserved]
model <- datawizard::data_rename(
model,
select = renamed_focal,
replacement = paste0(renamed_focal, "#####")
)
}
model
}
parameters/R/methods_quantreg.R 0000644 0001762 0000144 00000016040 14736731407 016327 0 ustar ligges users # quantreg: .rq, .rqss, .crq, .nlrq, .rqs
# model parameters ---------------------
#' @export
model_parameters.rqss <- model_parameters.cgam
#' @export
model_parameters.rqs <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
out <- .model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Component"),
standardize = standardize,
exponentiate = exponentiate,
keep_parameters = keep,
drop_parameters = drop,
p_adjust = p_adjust,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
# ci ---------------------
#' @export
ci.rq <- ci.default
#' @export
ci.rqss <- ci.default
#' @export
ci.crq <- ci.default
#' @export
ci.nlrq <- ci.default
#' @export
ci.rqs <- ci.default
# standard errors ---------------------
#' @export
standard_error.rq <- function(model, ...) {
se <- .get_quantreg_se(model)
if (is.null(se)) {
vc <- insight::get_varcov(model)
se <- as.vector(sqrt(diag(vc)))
}
params <- insight::get_parameters(model)
params$SE <- se
params[intersect(colnames(params), c("Parameter", "SE", "Component"))]
}
#' @export
standard_error.rqs <- function(model, ...) {
se <- tryCatch(
{
s <- suppressWarnings(summary(model, covariance = TRUE))
cs <- do.call(rbind, lapply(s, stats::coef))
cs[, "Std. Error"]
},
error = function(e) {
NULL
}
)
params <- insight::get_parameters(model)
data.frame(
Parameter = params$Parameter,
SE = se,
Component = params$Component,
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
standard_error.crq <- standard_error.rq
#' @export
standard_error.nlrq <- standard_error.rq
#' @export
standard_error.rqss <- function(model,
component = c("all", "conditional", "smooth_terms"),
...) {
component <- match.arg(component)
cs <- summary(model)$coef
se_column <- intersect(c("Std Error", "Std. Error"), colnames(cs))
se <- cs[, se_column]
params_cond <- insight::get_parameters(model, component = "conditional")
params_smooth <- insight::get_parameters(model, component = "smooth_terms")
out_cond <- .data_frame(
Parameter = params_cond$Parameter,
SE = se,
Component = "conditional"
)
out_smooth <- .data_frame(
Parameter = params_smooth$Parameter,
SE = NA,
Component = "smooth_terms"
)
switch(component,
all = rbind(out_cond, out_smooth),
conditional = out_cond,
smooth_terms = out_smooth
)
}
.get_quantreg_se <- function(model) {
se <- tryCatch(
{
cs <- suppressWarnings(stats::coef(summary(model)))
se_column <- intersect(c("Std Error", "Std. Error"), colnames(cs))
if (length(se_column)) {
cs[, se_column]
} else {
vc <- insight::get_varcov(model)
as.vector(sqrt(diag(vc)))
}
},
error = function(e) {
NULL
}
)
if (is.null(se)) {
se <- tryCatch(
{
sc <- summary(model)
if (all(unlist(lapply(sc, is.list)))) {
list_sc <- lapply(sc, function(i) {
.x <- as.data.frame(i)
.x$Parameter <- rownames(.x)
.x
})
out <- do.call(rbind, list_sc)
se <- stats::setNames(out$coefficients.Std.Error, sprintf("tau (%g)", out$tau))
} else {
se <- stats::setNames(unname(sc$coefficients[, 4]), names(sc$coefficients[, 4]))
}
},
error = function(e) {
NULL
}
)
}
se
}
# p values ---------------------
#' @export
p_value.rq <- function(model, ...) {
p <- .get_quantreg_p(model)
params <- insight::get_parameters(model)
params$p <- p
params[intersect(colnames(params), c("Parameter", "p", "Component"))]
}
#' @export
p_value.rqs <- function(model, ...) {
p <- tryCatch(
{
s <- suppressWarnings(summary(model, covariance = TRUE))
cs <- do.call(rbind, lapply(s, stats::coef))
cs[, "Pr(>|t|)"]
},
error = function(e) {
NULL
}
)
params <- insight::get_parameters(model)
data.frame(
Parameter = params$Parameter,
p = p,
Component = params$Component,
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
p_value.crq <- p_value.rq
#' @export
p_value.nlrq <- p_value.rq
#' @export
p_value.rqss <- function(model,
component = c("all", "conditional", "smooth_terms"),
...) {
component <- match.arg(component)
cs <- summary(model)$coef
p_column <- intersect(c("Pr(>|t|)", "Pr(>|z|)"), colnames(cs))
p_cond <- cs[, p_column]
cs <- summary(model)$qsstab
p_smooth <- cs[, "Pr(>F)"]
params_cond <- insight::get_parameters(model, component = "conditional")
params_smooth <- insight::get_parameters(model, component = "smooth_terms")
out_cond <- .data_frame(
Parameter = params_cond$Parameter,
p = as.vector(p_cond),
Component = "conditional"
)
out_smooth <- .data_frame(
Parameter = params_smooth$Parameter,
p = as.vector(p_smooth),
Component = "smooth_terms"
)
switch(component,
all = rbind(out_cond, out_smooth),
conditional = out_cond,
smooth_terms = out_smooth
)
}
.get_quantreg_p <- function(model) {
p <- tryCatch(
{
cs <- suppressWarnings(stats::coef(summary(model)))
cs[, "Pr(>|t|)"]
},
error = function(e) {
NULL
}
)
if (is.null(p)) {
p <- tryCatch(
{
.get_pval_from_summary(
model,
cs = suppressWarnings(stats::coef(summary(model, covariance = TRUE)))
)
},
error = function(e) {
NULL
}
)
}
if (is.null(p)) {
p <- tryCatch(
{
sc <- summary(model)
if (all(unlist(lapply(sc, is.list)))) {
list_sc <- lapply(sc, function(i) {
.x <- as.data.frame(i)
.x$Parameter <- rownames(.x)
.x
})
out <- do.call(rbind, list_sc)
p <- stats::setNames(out[[grep("^coefficients\\.Pr", colnames(out))]], sprintf("tau (%g)", out$tau))
} else {
p <- stats::setNames(unname(sc$coefficients[, 6]), names(sc$coefficients[, 6]))
}
},
error = function(e) {
NULL
}
)
}
p
}
parameters/R/methods_lmtest.R 0000644 0001762 0000144 00000000762 14716604200 016001 0 ustar ligges users #' @export
ci.coeftest <- ci.default
#' @export
p_value.coeftest <- function(model, ...) {
.data_frame(
Parameter = .remove_backticks_from_string(row.names(model)),
p = model[, 4]
)
}
#' @export
standard_error.coeftest <- function(model, ...) {
.data_frame(
Parameter = .remove_backticks_from_string(row.names(model)),
SE = model[, "Std. Error"]
)
}
#' @rdname model_parameters.htest
#' @export
model_parameters.coeftest <- model_parameters.ivFixed
parameters/R/methods_ivfixed.R 0000644 0001762 0000144 00000002176 14716604200 016130 0 ustar ligges users #' @export
ci.ivFixed <- ci.default
#' @export
standard_error.ivFixed <- standard_error.coxr
#' @export
p_value.ivFixed <- function(model, method = "wald", ...) {
stat <- insight::get_statistic(model)
if (!is.null(stat)) {
.data_frame(
Parameter = stat$Parameter,
p = as.vector(2 * stats::pt(
abs(stat$Statistic),
df = insight::get_df(model, type = method),
lower.tail = FALSE
))
)
}
}
#' @export
model_parameters.ivFixed <- function(model,
ci = 0.95,
ci_method = "wald",
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
out <- .model_parameters_generic(
model = model,
ci = ci,
ci_method = ci_method,
merge_by = "Parameter",
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
parameters/R/p_significance.R 0000644 0001762 0000144 00000031034 14736731407 015717 0 ustar ligges users #' @importFrom bayestestR p_significance
#' @export
bayestestR::p_significance
#' @title Practical Significance (ps)
#'
#' @description Compute the probability of **Practical Significance** (*ps*),
#' which can be conceptualized as a unidirectional equivalence test. It returns
#' the probability that an effect is above a given threshold corresponding to a
#' negligible effect in the median's direction, considering a parameter's _full_
#' confidence interval. In other words, it returns the probability of a clear
#' direction of an effect, which is larger than the smallest effect size of
#' interest (e.g., a minimal important difference). Its theoretical range is
#' from zero to one, but the *ps* is typically larger than 0.5 (to indicate
#' practical significance).
#'
#' In comparison the the [`equivalence_test()`] function, where the *SGPV*
#' (second generation p-value) describes the proportion of the _full_ confidence
#' interval that is _inside_ the ROPE, the value returned by `p_significance()`
#' describes the _larger_ proportion of the _full_ confidence interval that is
#' _outside_ the ROPE. This makes `p_significance()` comparable to
#' [`bayestestR::p_direction()`], however, while `p_direction()` compares to a
#' point-null by default, `p_significance()` compares to a range-null.
#'
#' @param x A statistical model.
#' @inheritParams bayestestR::p_significance
#' @inheritParams model_parameters.default
#' @param verbose Toggle warnings and messages.
#' @param ... Arguments passed to other methods.
#'
#' @seealso For more details, see [`bayestestR::p_significance()`]. See also
#' [`equivalence_test()`], [`p_function()`] and [`bayestestR::p_direction()`]
#' for functions related to checking effect existence and significance.
#'
#' @details `p_significance()` returns the proportion of the _full_ confidence
#' interval range (assuming a normally or t-distributed, equal-tailed interval,
#' based on the model) that is outside a certain range (the negligible effect,
#' or ROPE, see argument `threshold`). If there are values of the distribution
#' both below and above the ROPE, `p_significance()` returns the higher
#' probability of a value being outside the ROPE. Typically, this value should
#' be larger than 0.5 to indicate practical significance. However, if the range
#' of the negligible effect is rather large compared to the range of the
#' confidence interval, `p_significance()` will be less than 0.5, which
#' indicates no clear practical significance.
#'
#' Note that the assumed interval, which is used to calculate the practical
#' significance, is an estimation of the _full interval_ based on the chosen
#' confidence level. For example, if the 95% confidence interval of a
#' coefficient ranges from -1 to 1, the underlying _full (normally or
#' t-distributed) interval_ approximately ranges from -1.9 to 1.9, see also
#' following code:
#'
#' ```
#' # simulate full normal distribution
#' out <- bayestestR::distribution_normal(10000, 0, 0.5)
#' # range of "full" distribution
#' range(out)
#' # range of 95% CI
#' round(quantile(out, probs = c(0.025, 0.975)), 2)
#' ```
#'
#' This ensures that the practical significance always refers to the general
#' compatible parameter space of coefficients. Therefore, the _full interval_ is
#' similar to a Bayesian posterior distribution of an equivalent Bayesian model,
#' see following code:
#'
#' ```
#' library(bayestestR)
#' library(brms)
#' m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
#' m2 <- brm(mpg ~ gear + wt + cyl + hp, data = mtcars)
#' # probability of significance (ps) for frequentist model
#' p_significance(m)
#' # similar to ps of Bayesian models
#' p_significance(m2)
#' # similar to ps of simulated draws / bootstrap samples
#' p_significance(simulate_model(m))
#' ```
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/bayestestR.html)
#' implemented in the [**see**-package](https://easystats.github.io/see/).
#'
#' @inheritSection model_parameters Statistical inference - how to quantify evidence
#'
#' @references
#'
#' - Amrhein, V., Korner-Nievergelt, F., and Roth, T. (2017). The earth is
#' flat (p > 0.05): Significance thresholds and the crisis of unreplicable
#' research. PeerJ, 5, e3544. \doi{10.7717/peerj.3544}
#'
#' - Greenland S, Rafi Z, Matthews R, Higgs M. To Aid Scientific Inference,
#' Emphasize Unconditional Compatibility Descriptions of Statistics. (2022)
#' https://arxiv.org/abs/1909.08583v7 (Accessed November 10, 2022)
#'
#' - Lakens, D. (2024). Improving Your Statistical Inferences (Version v1.5.1).
#' Retrieved from https://lakens.github.io/statistical_inferences/.
#' \doi{10.5281/ZENODO.6409077}
#'
#' - Lakens, D., Scheel, A. M., and Isager, P. M. (2018). Equivalence Testing
#' for Psychological Research: A Tutorial. Advances in Methods and Practices
#' in Psychological Science, 1(2), 259–269. \doi{10.1177/2515245918770963}
#'
#' - Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and Lüdecke, D. (2019).
#' Indices of Effect Existence and Significance in the Bayesian Framework.
#' Frontiers in Psychology, 10, 2767. \doi{10.3389/fpsyg.2019.02767}
#'
#' - Rafi Z, Greenland S. Semantic and cognitive tools to aid statistical
#' science: replace confidence and significance by compatibility and surprise.
#' BMC Medical Research Methodology (2020) 20:244.
#'
#' - Schweder T. Confidence is epistemic probability for empirical science.
#' Journal of Statistical Planning and Inference (2018) 195:116–125.
#' \doi{10.1016/j.jspi.2017.09.016}
#'
#' - Schweder T, Hjort NL. Frequentist analogues of priors and posteriors.
#' In Stigum, B. (ed.), Econometrics and the Philosophy of Economics: Theory
#' Data Confrontation in Economics, pp. 285-217. Princeton University Press,
#' Princeton, NJ, 2003
#'
#' - Vos P, Holbert D. Frequentist statistical inference without repeated sampling.
#' Synthese 200, 89 (2022). \doi{10.1007/s11229-022-03560-x}
#'
#' @return A data frame with columns for the parameter names, the confidence
#' intervals and the values for practical significance. Higher values indicate
#' more practical significance (upper bound is one).
#'
#' @examplesIf requireNamespace("bayestestR") && packageVersion("bayestestR") > "0.14.0" && requireNamespace("sandwich")
#' data(qol_cancer)
#' model <- lm(QoL ~ time + age + education, data = qol_cancer)
#'
#' p_significance(model)
#' p_significance(model, threshold = c(-0.5, 1.5))
#'
#' # based on heteroscedasticity-robust standard errors
#' p_significance(model, vcov = "HC3")
#'
#' if (require("see", quietly = TRUE)) {
#' result <- p_significance(model)
#' plot(result)
#' }
#' @export
p_significance.lm <- function(x,
threshold = "default",
ci = 0.95,
vcov = NULL,
vcov_args = NULL,
verbose = TRUE,
...) {
# generate normal distribution based on CI range
result <- .posterior_ci(x, ci, vcov = vcov, vcov_args = vcov_args, ...)
# copy
out <- result$out
posterior <- result$posterior
# calculate the ROPE range - for multiple thresholds, we have to check
# each list element for "default", to replace it with the appropriate range
if (is.list(threshold)) {
threshold <- lapply(threshold, function(i) {
if (all(i == "default")) {
i <- bayestestR::rope_range(x, verbose = verbose)
}
i
})
} else if (all(threshold == "default")) {
threshold <- bayestestR::rope_range(x, verbose = verbose)
}
# add ps
result_ps <- bayestestR::p_significance(
posterior,
threshold = threshold,
verbose = verbose
)
out$ps <- as.numeric(result_ps)
# for list-thresholds, we have the list as attribute and need to save it as
# data.frame
if (is.list(threshold)) {
# save for later
threshold_data <- stats::setNames(
as.data.frame(do.call(rbind, attributes(result_ps)$threshold)),
c("ROPE_low", "ROPE_high")
)
out <- cbind(out, threshold_data)
keep <- c("Parameter", "CI", "CI_low", "CI_high", "ROPE_low", "ROPE_high", "ps", "Effects", "Component")
} else {
keep <- c("Parameter", "CI", "CI_low", "CI_high", "ps", "Effects", "Component")
}
# for plot, we need to have it numeric
if (!is.numeric(threshold) && !is.list(threshold)) {
threshold <- 0.1
}
# Reorder columns of 'out' to keep only the relevant ones
out <- out[intersect(keep, colnames(out))]
attr(out, "data") <- posterior
attr(out, "threshold") <- threshold
class(out) <- c("p_significance_lm", "p_significance", "see_p_significance", "data.frame")
out
}
# helper ----------------------------------------------------------------------
.posterior_ci <- function(x, ci, vcov = NULL, vcov_args = NULL, ...) {
# first, we need CIs
if (inherits(x, "parameters_model")) {
# for model_parameters objects, directly extract CIs
out <- as.data.frame(x)[intersect(
c("Parameter", "CI_low", "CI_high", "Component", "Effects"),
colnames(x)
)]
ci <- attributes(x)$ci
# and extract degrees of freedom
df_column <- grep("(df|df_error)", colnames(x))
if (length(df_column) > 0) {
dof <- unique(x[[df_column]])
if (length(dof) > 1) {
dof <- Inf
}
} else {
dof <- Inf
}
} else {
out <- ci(x, ci = ci, vcov = vcov, vcov_args = vcov_args, ...)
dof <- .safe(insight::get_df(x, type = "wald"), Inf)
}
# we now iterate all confidence intervals and create an approximate normal
# distribution that covers the CI-range.
posterior <- as.data.frame(lapply(seq_len(nrow(out)), function(i) {
ci_range <- as.numeric(out[i, c("CI_low", "CI_high")])
.generate_posterior_from_ci(ci, ci_range, dof = dof)
}))
colnames(posterior) <- out$Parameter
# deal with Effects and Component columns
if ("Effects" %in% colnames(out) && insight::n_unique(out$Effects) == 1) {
out$Effects <- NULL
}
if ("Component" %in% colnames(out) && insight::n_unique(out$Component) == 1) {
out$Component <- NULL
}
# check we don't have duplicated columns in "posterior" we need this for
# plotting
if (anyDuplicated(colnames(posterior)) > 0 && !is.null(out$Component)) {
comps <- .rename_values(out$Component, "zero_inflated", "zi")
comps <- .rename_values(comps, "conditional", "cond")
colnames(posterior) <- paste0(out$Parameter, "_", comps)
out$Parameter <- paste0(out$Parameter, "_", comps)
}
list(out = out, posterior = posterior)
}
# methods ---------------------------------------------------------------------
#' @export
print.p_significance_lm <- function(x, digits = 2, ...) {
threshold <- attributes(x)$threshold
# Check if threshold is a list, which indicates multiple thresholds
if (is.list(threshold)) {
caption <- "Practical Significance"
} else {
# make sure it's numeric
if (!is.numeric(threshold)) {
threshold <- 0.1
}
# make sure we have both bounds for the range
if (length(threshold) == 1) {
threshold <- c(threshold * -1, threshold)
}
caption <- sprintf(
"Practical Significance (threshold: %s)",
toString(insight::format_value(threshold, digits = 2))
)
}
x$ps <- insight::format_pd(x$ps, name = NULL)
x <- insight::format_table(x, digits = digits)
cat(insight::export_table(x, title = caption, ...))
}
# other classes --------------------------------------------------------------
#' @export
p_significance.glm <- p_significance.lm
#' @export
p_significance.coxph <- p_significance.lm
#' @export
p_significance.svyglm <- p_significance.lm
#' @export
p_significance.glmmTMB <- p_significance.lm
#' @export
p_significance.merMod <- p_significance.lm
#' @export
p_significance.wbm <- p_significance.lm
#' @export
p_significance.lme <- p_significance.lm
#' @export
p_significance.gee <- p_significance.lm
#' @export
p_significance.gls <- p_significance.lm
#' @export
p_significance.feis <- p_significance.lm
#' @export
p_significance.felm <- p_significance.lm
#' @export
p_significance.mixed <- p_significance.lm
#' @export
p_significance.hurdle <- p_significance.lm
#' @export
p_significance.zeroinfl <- p_significance.lm
#' @export
p_significance.rma <- p_significance.lm
#' @export
p_significance.parameters_model <- p_significance.lm
parameters/R/utils_pca_efa.R 0000644 0001762 0000144 00000035701 14736731407 015561 0 ustar ligges users #' Get Scores from Principal Component Analysis (PCA)
#'
#' `get_scores()` takes `n_items` amount of items that load the most
#' (either by loading cutoff or number) on a component, and then computes their
#' average.
#'
#' @param x An object returned by [principal_components()].
#' @param n_items Number of required (i.e. non-missing) items to build the sum
#' score. If `NULL`, the value is chosen to match half of the number of
#' columns in a data frame.
#'
#' @details
#' `get_scores()` takes the results from [`principal_components()`] and
#' extracts the variables for each component found by the PCA. Then, for each
#' of these "subscales", row means are calculated (which equals adding up the
#' single items and dividing by the number of items). This results in a sum
#' score for each component from the PCA, which is on the same scale as the
#' original, single items that were used to compute the PCA.
#'
#' @examples
#' if (require("psych")) {
#' pca <- principal_components(mtcars[, 1:7], n = 2, rotation = "varimax")
#'
#' # PCA extracted two components
#' pca
#'
#' # assignment of items to each component
#' closest_component(pca)
#'
#' # now we want to have sum scores for each component
#' get_scores(pca)
#'
#' # compare to manually computed sum score for 2nd component, which
#' # consists of items "hp" and "qsec"
#' (mtcars$hp + mtcars$qsec) / 2
#' }
#' @return A data frame with subscales, which are average sum scores for all
#' items from each component.
#' @export
get_scores <- function(x, n_items = NULL) {
subscales <- closest_component(x)
dataset <- attributes(x)$dataset
out <- lapply(sort(unique(subscales)), function(.subscale) {
columns <- names(subscales)[subscales == .subscale]
items <- dataset[columns]
if (is.null(n_items)) {
.n_items <- round(ncol(items) / 2)
} else {
.n_items <- n_items
}
apply(items, 1, function(i) {
if (sum(!is.na(i)) >= .n_items) {
mean(i, na.rm = TRUE)
} else {
NA
}
})
})
out <- as.data.frame(do.call(cbind, out))
colnames(out) <- sprintf("Component_%i", seq_len(ncol(out)))
out
}
# model parameters -----------------------------------------------------------------
#' @export
model_parameters.parameters_efa <- function(model, ...) {
x <- attributes(model)$summary
if (inherits(model, "parameters_efa")) {
class(x) <- c("parameters_efa_summary", class(model))
} else {
class(x) <- c("parameters_pca_summary", class(model))
}
x
}
#' @export
model_parameters.parameters_pca <- model_parameters.parameters_efa
# summary -----------------------------------------------------------------
#' @export
summary.parameters_efa <- function(object, ...) {
x <- attributes(object)$summary
cols <- intersect(
c("Std_Dev", "Eigenvalues", "Variance", "Variance_Cumulative", "Variance_Proportion"),
colnames(x)
)
x <- as.data.frame(t(x[, cols]))
x <- cbind(data.frame(Parameter = row.names(x), stringsAsFactors = FALSE), x)
names(x) <- c("Parameter", attributes(object)$summary$Component)
row.names(x) <- NULL
if (inherits(object, "parameters_efa")) {
class(x) <- c("parameters_efa_summary", class(object))
} else {
class(x) <- c("parameters_pca_summary", class(object))
}
x
}
#' @export
summary.parameters_pca <- summary.parameters_efa
#' @export
summary.parameters_omega <- function(object, ...) {
table_var <- attributes(object)$summary
class(table_var) <- c("parameters_omega_summary", class(table_var))
table_var
}
# predict -----------------------------------------------------------------
#' @rdname principal_components
#' @export
predict.parameters_efa <- function(object,
newdata = NULL,
names = NULL,
keep_na = TRUE,
verbose = TRUE,
...) {
attri <- attributes(object)
# handle if no data is provided
if (is.null(newdata)) {
# check if we have scores attribute - these will be returned directly
if ("scores" %in% names(attri)) {
out <- as.data.frame(attri$scores)
if (isTRUE(keep_na)) {
out <- .merge_na(object, out, verbose)
}
} else if ("dataset" %in% names(attri)) {
# if we have data, use that for prediction
d <- attri$data_set
d <- d[vapply(d, is.numeric, logical(1))]
out <- as.data.frame(stats::predict(attri$model, newdata = d))
} else {
insight::format_error(
"Could not retrieve data nor model. Please report an issue on {.url https://github.com/easystats/parameters/issues}." # nolint
)
}
} else if (inherits(attri$model, "spca")) {
# https://github.com/erichson/spca/issues/7
newdata <- newdata[names(attri$model$center)]
if (attri$standardize) {
newdata <- sweep(newdata, MARGIN = 2, STATS = attri$model$center, FUN = "-", check.margin = TRUE)
newdata <- sweep(newdata, MARGIN = 2, STATS = attri$model$scale, FUN = "/", check.margin = TRUE)
}
out <- as.matrix(newdata) %*% as.matrix(attri$model$loadings)
out <- stats::setNames(as.data.frame(out), paste0("Component", seq_len(ncol(out))))
} else if (inherits(attri$model, c("psych", "fa", "principal"))) {
out <- as.data.frame(stats::predict(attri$model, data = newdata[rownames(attri$model$weights)], ...))
} else {
out <- as.data.frame(stats::predict(attri$model, newdata = newdata, ...))
}
if (!is.null(names)) {
names(out)[seq_along(names)] <- names
}
row.names(out) <- NULL
out
}
#' @export
predict.parameters_pca <- predict.parameters_efa
.merge_na <- function(object, out, verbose = TRUE) {
compl_cases <- attributes(object)$complete_cases
if (is.null(compl_cases)) {
if (verbose) {
insight::format_alert(
"Could not retrieve information about missing data. Returning only complete cases."
)
}
} else {
original_data <- data.frame(.parameters_merge_id = seq_along(compl_cases))
out$.parameters_merge_id <- (seq_len(nrow(original_data)))[compl_cases]
out <- merge(original_data, out, by = ".parameters_merge_id", all = TRUE, sort = TRUE)
out$.parameters_merge_id <- NULL
}
out
}
# print -------------------------------------------------------------------
#' @export
print.parameters_efa_summary <- function(x, digits = 3, ...) {
if ("Parameter" %in% names(x)) {
x$Parameter <- c(
"Eigenvalues", "Variance Explained", "Variance Explained (Cumulative)",
"Variance Explained (Proportion)"
)
} else if ("Component" %in% names(x)) {
names(x) <- c(
"Component", "Eigenvalues", "Variance Explained",
"Variance Explained (Cumulative)", "Variance Explained (Proportion)"
)
}
cat(insight::export_table(
x,
digits = digits,
caption = c("# (Explained) Variance of Components", "blue"),
format = "text",
...
))
invisible(x)
}
#' @export
print.parameters_pca_summary <- print.parameters_efa_summary
#' @rdname principal_components
#' @export
print.parameters_efa <- function(x,
digits = 2,
sort = FALSE,
threshold = NULL,
labels = NULL,
...) {
cat(
.print_parameters_cfa_efa(
x,
threshold = threshold,
sort = sort,
format = "text",
digits = digits,
labels = labels,
...
)
)
invisible(x)
}
#' @export
print.parameters_pca <- print.parameters_efa
#' @export
print.parameters_omega <- function(x, ...) {
orig_x <- x
names(x) <- c("Composite", "Omega (total)", "Omega (hierarchical)", "Omega (group)")
cat(insight::export_table(x))
invisible(orig_x)
}
#' @export
print.parameters_omega_summary <- function(x, ...) {
orig_x <- x
names(x) <- c(
"Composite", "Total Variance (%)", "Variance due to General Factor (%)",
"Variance due to Group Factor (%)"
)
cat(insight::export_table(x))
invisible(orig_x)
}
# print-helper ----------------------
.print_parameters_cfa_efa <- function(x, threshold, sort, format, digits, labels, ...) {
# Method
if (inherits(x, "parameters_pca")) {
method <- "Principal Component Analysis"
} else {
method <- "Factor Analysis"
}
# Rotation
rotation_name <- attr(x, "rotation", exact = TRUE)
# Labels
if (!is.null(labels)) {
x$Label <- labels
x <- x[c("Variable", "Label", names(x)[!names(x) %in% c("Variable", "Label")])]
}
# Sorting
if (isTRUE(sort)) {
x <- .sort_loadings(x)
}
# Replace by NA all cells below threshold
if (!is.null(threshold)) {
x <- .filter_loadings(x, threshold = threshold)
}
# table caption
if (is.null(rotation_name) || rotation_name == "none") {
if (format == "markdown") {
table_caption <- sprintf("Loadings from %s (no rotation)", method)
} else {
table_caption <- c(sprintf("# Loadings from %s (no rotation)", method), "blue")
}
} else if (format == "markdown") {
table_caption <- sprintf("Rotated loadings from %s (%s-rotation)", method, rotation_name)
} else {
table_caption <- c(sprintf("# Rotated loadings from %s (%s-rotation)", method, rotation_name), "blue")
}
# footer
if (is.null(attributes(x)$type)) {
footer <- NULL
} else {
footer <- c(.text_components_variance(x, sep = ifelse(format == "markdown", "", "\n")), "yellow")
}
# alignment?
if (is.null(labels)) {
alignment <- NULL
} else {
alignment <- paste(c("ll", rep("r", ncol(x) - 2)), collapse = "")
}
insight::export_table(
x,
digits = digits,
format = format,
caption = table_caption,
footer = footer,
align = alignment,
...
)
}
#' @keywords internal
.text_components_variance <- function(x, sep = "") {
type <- attributes(x)$type
if (type %in% c("prcomp", "principal", "pca")) {
type <- "principal component"
} else if (type == "fa") {
type <- "latent factor"
} else if (type %in% c("kmeans", "hclust", "pvclust", "dbscan", "mixture", "pam")) {
type <- "cluster"
} else {
type <- paste0(type, " component")
}
if (type == "cluster") {
cluster_summary <- as.data.frame(x)
variance <- attributes(x)$variance * 100
} else {
cluster_summary <- attributes(x)$summary
variance <- max(cluster_summary$Variance_Cumulative) * 100
}
if (nrow(cluster_summary) == 1) {
text_variance <- paste0("The unique ", type)
} else {
text_variance <- paste0("The ", nrow(cluster_summary), " ", type, "s")
}
# rotation
if (!is.null(attributes(x)$rotation) && attributes(x)$rotation != "none") {
text_variance <- paste0(text_variance, " (", attributes(x)$rotation, " rotation)")
}
text_variance <- paste0(
text_variance,
" accounted for ",
sprintf("%.2f", variance),
"% of the total variance of the original data"
)
if (type == "cluster" || nrow(cluster_summary) == 1) {
text_variance <- paste0(text_variance, ".")
} else {
text_variance <- paste0(
text_variance,
" (",
paste0(cluster_summary$Component,
" = ",
sprintf("%.2f", cluster_summary$Variance * 100),
"%",
collapse = ", "
),
")."
)
}
paste0(sep, text_variance, sep)
}
# sort --------------------------------------------------------------------
#' @rdname principal_components
#' @export
sort.parameters_efa <- function(x, ...) {
.sort_loadings(x)
}
#' @export
sort.parameters_pca <- sort.parameters_efa
#' @keywords internal
.sort_loadings <- function(loadings, cols = NULL) {
if (is.null(cols)) {
cols <- attributes(loadings)$loadings_columns
}
# Remove variable name column
x <- loadings[, cols, drop = FALSE]
row.names(x) <- NULL
# Initialize clusters
nitems <- nrow(x)
loads <- data.frame(item = seq(1:nitems), cluster = rep(0, nitems))
# first sort them into clusters: Find the maximum for each row and assign it to that cluster
loads$cluster <- apply(abs(x), 1, which.max)
ord <- sort(loads$cluster, index.return = TRUE)
x[1:nitems, ] <- x[ord$ix, ]
rownames(x)[1:nitems] <- rownames(x)[ord$ix]
total.ord <- ord$ix
# now sort column wise so that the loadings that have their highest loading on each cluster
items <- table(loads$cluster) # how many items are in each cluster?
first <- 1
item <- loads$item
for (i in seq_along(items)) {
if (items[i] > 0) {
last <- first + items[i] - 1
ord <- sort(abs(x[first:last, i]), decreasing = TRUE, index.return = TRUE)
x[first:last, ] <- x[item[ord$ix + first - 1], ]
loads[first:last, 1] <- item[ord$ix + first - 1]
rownames(x)[first:last] <- rownames(x)[ord$ix + first - 1]
total.ord[first:last] <- total.ord[ord$ix + first - 1]
first <- first + items[i]
}
}
row_order <- row.names(x)
loadings <- loadings[as.numeric(as.character(row_order)), ] # Arrange by max
row.names(loadings) <- NULL
loadings
}
# Filter --------------------------------------------------------------------
#' @keywords internal
.filter_loadings <- function(loadings, threshold = 0.2, loadings_columns = NULL) {
if (is.null(loadings_columns)) {
loadings_columns <- attributes(loadings)$loadings_columns
}
if (threshold == "max" || threshold >= 1) {
if (threshold == "max") {
for (row in seq_len(nrow(loadings))) {
maxi <- max(abs(loadings[row, loadings_columns, drop = FALSE]))
loadings[row, loadings_columns][abs(loadings[row, loadings_columns]) < maxi] <- NA
}
} else {
for (col in loadings_columns) {
loadings[utils::tail(order(abs(loadings[, col]), decreasing = TRUE), -round(threshold)), col] <- NA
}
}
} else {
loadings[, loadings_columns][abs(loadings[, loadings_columns]) < threshold] <- NA
}
loadings
}
# closest_component -------------------------------------------------------
#' @rdname principal_components
#' @export
closest_component <- function(pca_results) {
if ("closest_component" %in% names(attributes(pca_results))) {
attributes(pca_results)$closest_component
} else {
.closest_component(pca_results)
}
}
.closest_component <- function(loadings, loadings_columns = NULL, variable_names = NULL) {
if (is.matrix(loadings)) loadings <- as.data.frame(loadings)
if (is.null(loadings_columns)) loadings_columns <- seq_len(ncol(loadings))
if (is.null(variable_names)) variable_names <- row.names(loadings)
component_columns <- apply(loadings[loadings_columns], 1, function(i) which.max(abs(i)))
stats::setNames(component_columns, variable_names)
}
parameters/R/dominance_analysis.R 0000644 0001762 0000144 00000053304 14736731407 016622 0 ustar ligges users #' @title Dominance Analysis
#' @name dominance_analysis
#' @inheritParams domir::domin
#'
#' @description Computes Dominance Analysis Statistics and Designations
#'
#' @param model A model object supported by `performance::r2()`. See 'Details'.
#'
#' @param sets A (named) list of formula objects with no left hand
#' side/response. If the list has names, the name provided each element
#' will be used as the label for the set. Unnamed list elements will be
#' provided a set number name based on its position among the sets as entered.
#'
#' Predictors in each formula are bound together as a set in the dominance
#' analysis and dominance statistics and designations are computed for
#' the predictors together. Predictors in `sets` must be present in the model
#' submitted to the `model` argument and cannot be in the `all` argument.
#'
#' @param all A formula with no left hand side/response.
#'
#' Predictors in the formula are included in each subset in the dominance
#' analysis and the R2 value associated with them is subtracted from the
#' overall value. Predictors in `all` must be present in the model
#' submitted to the `model` argument and cannot be in the `sets` argument.
#'
#' @param quote_args A character vector of arguments in the model submitted to
#' `model` to `quote()` prior to submitting to the dominance analysis. This
#' is necessary for data masked arguments (e.g., `weights`) to prevent them
#' from being evaluated before being applied to the model and causing an error.
#'
#' @param contrasts A named list of [`contrasts`] used by the model object.
#' This list is required in order for the correct mapping of parameters to
#' predictors in the output when the model creates indicator codes for factor
#' variables using [`insight::get_modelmatrix()`]. By default, the `contrast`
#' element from the model object submitted is used. If the model object does
#' not have a `contrast` element the user can supply this named list.
#'
#' @param ... Not used at current.
#'
#' @return Object of class `"parameters_da"`.
#'
#' An object of class `"parameters_da"` is a list of `data.frame`s composed
#' of the following elements:
#' \describe{
#' \item{`General`}{A `data.frame` which associates dominance statistics with
#' model parameters. The variables in this `data.frame` include:
#' \describe{
#' \item{`Parameter`}{Parameter names.}
#' \item{`General_Dominance`}{Vector of general dominance statistics.
#' The R2 ascribed to variables in the `all` argument are also reported
#' here though they are not general dominance statistics.}
#' \item{`Percent`}{Vector of general dominance statistics normalized
#' to sum to 1.}
#' \item{`Ranks`}{Vector of ranks applied to the general dominance
#' statistics.}
#' \item{`Subset`}{Names of the subset to which the parameter belongs in
#' the dominance analysis. Each other `data.frame` returned will refer
#' to these subset names.}}}
#' \item{`Conditional`}{A `data.frame` of conditional dominance
#' statistics. Each observation represents a subset and each variable
#' represents an the average increment to R2 with a specific number of
#' subsets in the model. `NULL` if `conditional` argument is `FALSE`.}
#' \item{`Complete`}{A `data.frame` of complete dominance
#' designations. The subsets in the observations are compared to the
#' subsets referenced in each variable. Whether the subset
#' in each variable dominates the subset in each observation is
#' represented in the logical value. `NULL` if `complete`
#' argument is `FALSE`.}
#' }
#'
#' @details Computes two decompositions of the model's R2 and returns
#' a matrix of designations from which predictor relative importance
#' determinations can be obtained.
#'
#' Note in the output that the "constant" subset is associated with a
#' component of the model that does not directly contribute to the R2 such
#' as an intercept. The "all" subset is apportioned a component of the fit
#' statistic but is not considered a part of the dominance analysis and
#' therefore does not receive a rank, conditional dominance statistics, or
#' complete dominance designations.
#'
#' The input model is parsed using `insight::find_predictors()`, does not
#' yet support interactions, transformations, or offsets applied in the R
#' formula, and will fail with an error if any such terms are detected.
#'
#' The model submitted must accept an formula object as a `formula`
#' argument. In addition, the model object must accept the data on which
#' the model is estimated as a `data` argument. Formulas submitted
#' using object references (i.e., `lm(mtcars$mpg ~ mtcars$vs)`) and
#' functions that accept data as a non-`data` argument
#' (e.g., `survey::svyglm()` uses `design`) will fail with an error.
#'
#' Models that return `TRUE` for the `insight::model_info()`
#' function's values "is_bayesian", "is_mixed", "is_gam",
#' is_multivariate", "is_zero_inflated",
#' or "is_hurdle" are not supported at current.
#'
#' When `performance::r2()` returns multiple values, only the first is used
#' by default.
#'
#' @references
#' - Azen, R., & Budescu, D. V. (2003). The dominance analysis approach
#' for comparing predictors in multiple regression. Psychological Methods,
#' 8(2), 129-148. doi:10.1037/1082-989X.8.2.129
#'
#' - Budescu, D. V. (1993). Dominance analysis: A new approach to the
#' problem of relative importance of predictors in multiple regression.
#' Psychological Bulletin, 114(3), 542-551. doi:10.1037/0033-2909.114.3.542
#'
#' - Groemping, U. (2007). Estimators of relative importance in linear
#' regression based on variance decomposition. The American Statistician,
#' 61(2), 139-147. doi:10.1198/000313007X188252
#'
#' @seealso [domir::domin()]
#'
#' @author Joseph Luchman
#'
#' @examplesIf require("domir") && require("performance")
#' data(mtcars)
#'
#' # Dominance Analysis with Logit Regression
#' model <- glm(vs ~ cyl + carb + mpg, data = mtcars, family = binomial())
#'
#' performance::r2(model)
#' dominance_analysis(model)
#'
#' # Dominance Analysis with Weighted Logit Regression
#' model_wt <- glm(vs ~ cyl + carb + mpg,
#' data = mtcars,
#' weights = wt, family = quasibinomial()
#' )
#'
#' dominance_analysis(model_wt, quote_args = "weights")
#' @export
dominance_analysis <- function(model, sets = NULL, all = NULL,
conditional = TRUE, complete = TRUE,
quote_args = NULL, contrasts = model$contrasts,
...) {
# Exit Conditions ----
insight::check_if_installed("domir")
insight::check_if_installed("performance")
if (!insight::is_regression_model(model)) {
insight::format_error(
paste(deparse(substitute(model)), "is not a supported {.pkg insight} model."),
"You may be able to dominance analyze this model using the {.pkg domir} package."
)
}
if (!any(utils::.S3methods("r2", class = class(model)[[1]], envir = getNamespace("performance")) %in%
paste0("r2.", class(model)))) {
insight::format_error(
paste(deparse(substitute(model)), "does not have a {.pkg perfomance}-supported `r2()` method."),
"You may be able to dominance analyze this model using the {.pkg domir} package."
)
}
model_info <- insight::model_info(model)
if (any(unlist(model_info[c("is_bayesian", "is_mixed", "is_gam", "is_multivariate", "is_zero_inflated", "is_hurdle")]))) {
insight::format_error(
paste0("`dominance_analysis()` does not yet support models of class `", class(model)[[1]], "`."),
"You may be able to dominance analyze this model using the {.pkg domir} package."
)
}
if (length(insight::find_predictors(model, flatten = TRUE)) < 2) {
insight::format_error("Too few predictors for a dominance analysis.")
}
if (!is.null(insight::find_offset(model))) {
insight::format_error(
"Offsets in the model are not allowed in this version of `dominance_analysis()`.",
"Try using package {.pkg domir}."
)
}
if (!all(insight::find_predictors(model, flatten = TRUE) %in% insight::find_terms(model)$conditional)) {
insight::format_error(
"Predictors do not match terms.",
"This usually occurs when there are in-formula predictor transformations such as `log(x)` or `I(x+z)`.",
"`dominance_analysis()` cannot yet accommodate such terms. Reformat your model to ensure all parameters",
"match predictors in the data or use the {.pkg domir} package."
)
}
if (!is.null(insight::find_interactions(model))) {
insight::format_error("Interactions in the model formula are not allowed.")
}
if (!is.null(sets)) {
if (!is.list(sets)) {
insight::format_error("`sets` argument must be submitted as list.")
}
if (length(sets) != length(unlist(sets))) {
insight::format_error("Nested lists are not allowed in `sets`.")
}
if (!all(sapply(sets, inherits, "formula"))) {
insight::format_error("Each element of list in `sets` must be a formula.")
}
if (any(sapply(sets, function(x) attr(stats::terms(x), "response") == 1))) {
insight::format_error("Formulas in `sets` argument must not have responses/left hand sides.")
}
}
if (!is.null(all)) {
if (!inherits(all, "formula")) {
insight::format_error("`all` argument must be submitted as a formula.")
}
if (attr(stats::terms(all), "response") == 1) {
insight::format_error("Formula in `all` argument must not have a response/left hand side.")
}
}
if (!is.null(quote_args) && !all(is.character(quote_args))) {
insight::format_error("All arguments in `quote_args` must be characters.")
}
# Collect components for arguments ----
ivs <- insight::find_predictors(model, flatten = TRUE)
dv <- insight::find_response(model)
# reg <- insight::model_name(model) # insight::get_call + as.list() and take first element? glm.nb doesn't work...
reg <- as.list(insight::get_call(model))[[1]]
# Process sets ----
if (!is.null(sets)) {
# gather predictors from each set
sets_processed <- lapply(sets, function(x) attr(stats::terms(x), "term.labels"))
# remove predictors from `ivs` list if in sets
set_remove_loc <- unlist(lapply(sets_processed, function(x) which(ivs %in% x)))
if (length(set_remove_loc) != length(unlist(sets_processed))) {
wrong_set_terms <- unlist(sets_processed)[which(!(unlist(sets_processed) %in% ivs))]
insight::format_error(
"Terms",
paste(wrong_set_terms, sep = " "),
"in `sets` argument do not match any predictors in model."
)
}
ivs <- ivs[-set_remove_loc]
# apply names to sets
set_names <- names(sets)
missing_set_names <- which(set_names == "")
if (length(missing_set_names) > 0) {
set_names[missing_set_names] <- paste0("set", missing_set_names)
}
if (any(set_names %in% c("all", "constant"))) {
insight::format_error(
"Names \"all\" and \"constant\" are reserved for subset names in the `dominance_analysis()` function.",
"Please rename any sets currently named \"all\" or \"constant\"."
)
}
if (any(set_names %in% ivs)) {
repeat_names <- set_names[which(set_names %in% ivs)]
insight::format_error(
"Set names",
paste(repeat_names, sep = " "), "are also the names of invidiual predictors.",
"Please rename these sets."
)
}
} else {
sets_processed <- NULL
}
# Process all ----
if (!is.null(all)) {
# gather predictors in all
all_processed <- attr(stats::terms(all), "term.labels")
# remove predictors in all from `ivs` list
all_remove_loc <- which(ivs %in% all_processed)
if (any(all_processed %in% unlist(sets_processed))) {
reused_terms <-
all_processed[which(all_processed %in% unlist(sets_processed))]
insight::format_error(
"Terms",
paste(reused_terms, sep = " "),
"in all argument are also used in `sets` argument."
)
}
if (length(all_remove_loc) != length(unlist(all_processed))) {
wrong_all_terms <- all_processed[which(!(all_processed) %in% ivs)]
insight::format_error(
"Terms",
paste(wrong_all_terms, sep = " "),
"in `all` argument do not match any predictors in model."
)
}
ivs <- ivs[-all_remove_loc] # update IVs
} else {
all_processed <- NULL
}
# name collisions across subsets - exit
if (any(ivs %in% c("all", "constant"))) {
insight::format_error(
"Names 'all' and 'constant' are reserved for subset names in the `dominance_analysis()` function.",
"Please rename any predictors currently named 'all' or 'constant.'",
"Alternatively, put the predictor in a set by itself."
)
}
# big DA warning
if (length(c(ivs, unlist(sets_processed))) > 15) {
insight::format_warning(
paste0("Total of ", 2^length(ivs) - 1, " models to be estimated."),
"Process may take some time."
)
}
# Build non-formula model arguments to `domin` ----
if (length(ivs) == 0) ivs <- "1"
fml <- stats::reformulate(ivs, response = dv, intercept = insight::has_intercept(model))
data <- insight::get_data(model, verbose = FALSE)
args <- as.list(insight::get_call(model), collapse = "") # extract all arguments from call
loc <- which(!(names(args) %in% c("formula", "data"))) # find formula and data arguments
if (length(which(names(args) %in% c("formula", "data"))) != 2) {
# exit if formula and data arguments missing
insight::format_error("Model submitted does not have a formula and `data` argument.")
}
args <- args[loc] # remove formula and data arguments
args <- args[-1] # remove function name
# quote arguments for domin
for (arg in quote_args) {
if (arg %in% names(args)) {
args[[arg]] <- str2lang(paste0("quote(", deparse(args[[arg]]), ")", collapse = ""))
} else {
insight::format_error(arg, " in `quote_args` not among arguments in model.")
}
}
# Internal wrapper to ensure r2 values conform to domin ----
.r2_wrap <- function(model, ...) {
list(fitstat = performance::r2(model, ...)[[1]])
}
# Finalize and implement DA
args2domin <- append(list(
formula_overall = fml, reg = reg, fitstat = list(.r2_wrap, "fitstat"),
data = data, conditional = conditional, complete = complete,
sets = sets_processed, all = all_processed
), args)
utils::capture.output({
domir_res <- do.call(domir::domin, args2domin)
})
# Set up returned data.frames ----
# Apply set names to domin results
if (!is.null(sets)) {
names(domir_res$General_Dominance) <-
c(
names(domir_res$General_Dominance)[1:(length(domir_res$General_Dominance) - length(set_names))],
set_names
)
if (conditional) {
rownames(domir_res$Conditional_Dominance) <-
names(domir_res$General_Dominance)
}
}
if (complete) {
colnames(domir_res$Complete_Dominance) <-
paste0("dmn_", names(domir_res$General_Dominance))
dimnames(domir_res$Complete_Dominance) <- list(
colnames(domir_res$Complete_Dominance),
names(domir_res$General_Dominance)
)
domir_res$Complete_Dominance <- t(domir_res$Complete_Dominance)
}
# Map parameter names to subsets - structure set-up
da_df_res <-
da_df_cat <-
.data_frame(parameter = insight::find_parameters(model, flatten = TRUE))
da_df_cat <- .data_frame(da_df_cat, subset = NA_character_)
# if parameter is same as domin name, copy it to 'subset'
da_df_cat$subset <-
ifelse((da_df_res$parameter %in%
names(domir_res$General_Dominance)) &
(is.na(da_df_cat$subset)),
da_df_res$parameter,
da_df_cat$subset
)
# Expand contrast names
if (!is.null(contrasts)) {
contr_names <-
lapply(
names(contrasts),
function(name) {
pred_loc <- which(insight::find_predictors(model, flatten = TRUE) == name)
pred_names <-
colnames(insight::get_modelmatrix(model))[
which(attr(insight::get_modelmatrix(model), "assign") == pred_loc)
]
}
)
names(contr_names) <- names(contrasts)
contr_map <- rep(names(contr_names), lengths(contr_names))
names(contr_map) <- unlist(contr_names)
for (subset in which(is.na(da_df_cat$subset))) {
if ((da_df_res$parameter[[subset]] %in% names(contr_map))) {
da_df_cat$subset[[subset]] <-
contr_map[[which(names(contr_map) == da_df_res$parameter[[subset]])]]
}
}
}
# Apply set names
if (!is.null(sets)) {
for (set in seq_along(sets)) {
set_name <- if (!is.null(names(sets)[[set]])) {
names(sets)[[set]]
} else {
paste0("set", set)
}
da_df_cat$subset <-
replace(
da_df_cat$subset,
da_df_res$parameter %in% all.vars(sets[[set]]), set_name
)
da_df_cat$subset <-
replace(
da_df_cat$subset,
da_df_cat$subset %in% all.vars(sets[[set]]), set_name
)
}
}
# Apply 'all' names
if (!is.null(all)) {
da_df_cat$subset <-
replace(
da_df_cat$subset,
da_df_res$parameter %in% all.vars(all), "all"
)
da_df_cat$subset <-
replace(
da_df_cat$subset,
da_df_cat$subset %in% all.vars(all), "all"
)
}
# assume remaining parameters are part of 'constant'
da_df_cat$subset <-
replace(
da_df_cat$subset,
is.na(da_df_cat$subset), "constant"
)
# merge subsets and DA results to parameter names
da_df_res <-
datawizard::data_merge(
da_df_cat,
.data_frame(
subset = names(domir_res$General_Dominance),
general_dominance = domir_res$General_Dominance
)
)
# plug in value of 'all' in 'all' subsets/parameters
if (!is.null(all)) {
da_df_res$general_dominance <-
replace(
da_df_res$general_dominance,
da_df_res$subset == "all",
domir_res$Fit_Statistic_All_Subsets
)
}
# merge standardized general dominance stat values
da_df_res <-
datawizard::data_merge(
da_df_res,
.data_frame(
subset = names(domir_res$General_Dominance),
standardized = domir_res$Standardized
)
)
# merge ranks based on general dominance stat values
da_df_res <-
datawizard::data_merge(
da_df_res,
.data_frame(
subset = names(domir_res$General_Dominance),
ranks = domir_res$Ranks
)
)
da_df_res <-
datawizard::data_relocate(da_df_res, "subset", after = "ranks")
if (conditional) {
da_df_cdl <- .data_frame(Subset = names(domir_res$General_Dominance))
da_df_cdl <- datawizard::data_merge(
da_df_cdl,
.data_frame(
Subset = names(domir_res$General_Dominance),
domir_res$Conditional_Dominance
)
)
cols_to_select <- colnames(da_df_cdl)[2:length(da_df_cdl)]
da_df_cdl <- datawizard::data_rename(
da_df_cdl,
select = cols_to_select,
replacement = colnames(domir_res$Conditional_Dominance)
)
} else {
da_df_cdl <- NULL
}
if (complete) {
da_df_cpt <- .data_frame(Subset = names(domir_res$General_Dominance))
da_df_cpt <- datawizard::data_merge(
da_df_cpt,
.data_frame(
Subset = names(domir_res$General_Dominance),
domir_res$Complete_Dominance
)
)
cols_to_select <- colnames(da_df_cpt)[2:length(da_df_cpt)]
da_df_cpt <- datawizard::data_rename(
da_df_cpt,
select = cols_to_select,
replacement = colnames(domir_res$Complete_Dominance)
)
} else {
da_df_cpt <- NULL
}
da_df_res <- datawizard::data_rename(
da_df_res,
replacement = c(
"Parameter", "General_Dominance",
"Percent", "Ranks", "Subset"
)
)
da_list <- list(
General = da_df_res,
Conditional = da_df_cdl,
Complete = da_df_cpt
)
# add attributes and class
attr(da_list, "model_R2") <- domir_res$Fit_Statistic_Overall
attr(da_list$General, "table_title") <- "General Dominance Statistics"
if (conditional) attr(da_list$Conditional, "table_title") <- "Conditional Dominance Statistics"
if (complete) attr(da_list$Complete, "table_title") <- "Complete Dominance Designations"
class(da_list) <- "parameters_da"
da_list
}
# methods ------------------------------
#' @export
print.parameters_da <- function(x, digits = 3, ...) {
insight::print_color("# Dominance Analysis Results", "blue")
cat("\n\n")
cat("Model R2 Value: ", sprintf("%.*f", digits, attr(x, "model_R2")), "\n\n")
printed_x <- x
printed_x$General <- datawizard::data_rename(x$General,
select = "General_Dominance",
replacement = "General Dominance"
)
if (!is.null(x$Conditional)) {
cdl_col <- ncol(x$Conditional)
cdl_names <- paste0("IVs_", 1:(cdl_col - 1))
cdl_names_rep <- paste("IVs:", 1:(cdl_col - 1))
printed_x$Conditional <-
datawizard::data_rename(x$Conditional,
select = cdl_names,
replacement = cdl_names_rep
)
}
if (!is.null(x$Complete)) {
cpt_names <- names(x$Complete)[-1]
cpt_names_rep <- gsub(
"dmn_", "< ",
cpt_names,
fixed = TRUE
)
printed_x$Complete <-
datawizard::data_rename(x$Complete,
select = cpt_names,
replacement = cpt_names_rep
)
}
cat(insight::export_table(printed_x, digits = digits, ...))
invisible(x)
}
parameters/R/methods_metaplus.R 0000644 0001762 0000144 00000027134 14736731407 016341 0 ustar ligges users # metaplus
###### .metaplus -------------------
#' @export
model_parameters.metaplus <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
include_studies = TRUE,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
if (!missing(ci)) {
if (isTRUE(verbose)) {
insight::format_alert(
"'metaplus' models do not support other levels for confidence intervals than 0.95. Argument 'ci' is ignored."
)
}
ci <- 0.95
}
meta_analysis_overall <- suppressWarnings(.model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = "Parameter",
standardize = standardize,
exponentiate = exponentiate,
keep_parameters = keep,
drop_parameters = drop,
...
))
rma_parameters <- if (!is.null(model$slab) && !is.numeric(model$slab)) {
sprintf("%s", model$slab)
} else if (is.null(model$k) && !is.null(model$slab) && is.numeric(model$slab)) {
sprintf("Study %i", model$slab)
} else if (!is.null(model$k)) {
sprintf("Study %i", 1:model[["k"]])
} else {
sprintf("Study %i", seq_along(model$yi))
}
alpha <- (1 + ci) / 2
rma_coeffients <- as.vector(model$yi)
rma_se <- as.vector(model$sei)
rma_ci_low <- rma_coeffients - rma_se * stats::qt(alpha, df = Inf)
rma_ci_high <- rma_coeffients + rma_se * stats::qt(alpha, df = Inf)
rma_statistic <- rma_coeffients / rma_se
rma_ci_p <- 2 * stats::pt(abs(rma_statistic), df = Inf, lower.tail = FALSE)
meta_analysis_studies <- data.frame(
Parameter = rma_parameters,
Coefficient = rma_coeffients,
SE = rma_se,
CI_low = rma_ci_low,
CI_high = rma_ci_high,
z = rma_statistic,
df_error = NA,
p = rma_ci_p,
Weight = 1 / as.vector(model$sei),
stringsAsFactors = FALSE
)
original_attributes <- attributes(meta_analysis_overall)
out <- merge(meta_analysis_studies, meta_analysis_overall, all = TRUE, sort = FALSE)
# fix intercept name
out$Parameter[out$Parameter == "(Intercept)"] <- "Overall"
out <- out[!(out$Parameter %in% c("tau2", "vinv")), ]
# filter studies?
if (isFALSE(include_studies)) {
out <- out[out$Parameter == "Overall", ]
}
original_attributes$names <- names(out)
original_attributes$row.names <- seq_len(nrow(out))
original_attributes$pretty_names <- stats::setNames(out$Parameter, out$Parameter)
attributes(out) <- original_attributes
# no df
out$df_error <- NULL
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(out, "measure") <- "Estimate"
if (!"Method" %in% names(out)) {
out$Method <- "Robust meta-analysis using 'metaplus'"
}
attr(out, "title") <- unique(out$Method)
out
}
#' @export
standard_error.metaplus <- function(model, ...) {
ci_low <- as.vector(model$results[, "95% ci.lb"])
ci_high <- as.vector(model$results[, "95% ci.ub"])
cis <- apply(cbind(ci_low, ci_high), MARGIN = 1, diff)
out <- .data_frame(
Parameter = .remove_backticks_from_string(rownames(model$results)),
SE = cis / (2 * stats::qnorm(0.975))
)
out$Parameter[grepl("muhat", out$Parameter, fixed = TRUE)] <- "(Intercept)"
out
}
#' @export
p_value.metaplus <- function(model, ...) {
out <- .data_frame(
Parameter = .remove_backticks_from_string(rownames(model$results)),
p = as.vector(model$results[, "pvalue"])
)
out$Parameter[grepl("muhat", out$Parameter, fixed = TRUE)] <- "(Intercept)"
out
}
#' @export
ci.metaplus <- function(x, ...) {
out <- .data_frame(
Parameter = .remove_backticks_from_string(rownames(x$results)),
CI_low = as.vector(x$results[, "95% ci.lb"]),
CI_high = as.vector(x$results[, "95% ci.ub"])
)
out$Parameter[grepl("muhat", out$Parameter, fixed = TRUE)] <- "(Intercept)"
out
}
###### .meta_random -------------------
#' @export
model_parameters.meta_random <- function(model,
ci = 0.95,
ci_method = "eti",
exponentiate = FALSE,
include_studies = TRUE,
verbose = TRUE,
...) {
# process arguments
params <- as.data.frame(model$estimates)
ci_method <- match.arg(ci_method, choices = c("hdi", "eti", "quantile"))
# parameters of studies included
study_params <- model$data
fac <- stats::qnorm((1 + ci) / 2, lower.tail = TRUE)
out_study <- data.frame(
Parameter = study_params$labels,
Coefficient = study_params$y,
SE = study_params$SE,
CI_low = study_params$y - fac * study_params$SE,
CI_high = study_params$y + fac * study_params$SE,
Weight = 1 / study_params$SE^2,
BF = NA,
Rhat = NA,
ESS = NA,
Component = "studies",
Prior_Distribution = NA,
Prior_Location = NA,
Prior_Scale = NA,
stringsAsFactors = FALSE
)
# extract ci-level and find ci-columns
ci <- .meta_bma_extract_ci(params)
ci_cols <- .metabma_ci_columns(ci_method, ci)
# parameters of overall / tau
out <- data.frame(
Parameter = rownames(params),
Coefficient = params$mean,
SE = params$sd,
CI_low = params[[ci_cols[1]]],
CI_high = params[[ci_cols[2]]],
Weight = NA,
BF = NA,
Rhat = params$Rhat,
ESS = params$n_eff,
Component = "meta",
stringsAsFactors = FALSE
)
# add prior information
priors <- insight::get_priors(model)
out$Prior_Distribution <- priors$Distribution
out$Prior_Location <- priors$Location
out$Prior_Scale <- priors$Scale
# fix intercept name
out$Parameter[out$Parameter == "d"] <- "Overall"
# add BF
out$BF[1] <- model$BF[2, 1]
# merge
out <- rbind(out_study, out)
# filter studies?
if (isFALSE(include_studies)) {
out <- out[out$Parameter %in% c("Overall", "tau"), ]
}
# exponentiate coefficients and SE/CI, if requested
out <- .exponentiate_parameters(out, model, exponentiate)
out <- .add_model_parameters_attributes(
params = out,
model = model,
ci = ci,
exponentiate = exponentiate,
ci_method = ci_method,
verbose = verbose,
...
)
# final atributes
attr(out, "measure") <- "Estimate"
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(out) <- c("parameters_model", "see_parameters_model", class(params))
if (!"Method" %in% names(out)) {
out$Method <- "Bayesian meta-analysis using 'metaBMA'"
}
attr(out, "title") <- unique(out$Method)
out
}
#' @export
standard_error.meta_random <- function(model, ...) {
params <- as.data.frame(model$estimates)
out <- data.frame(
Parameter = .remove_backticks_from_string(rownames(params)),
SE = params$sd,
stringsAsFactors = FALSE
)
out$Parameter[grepl("d", out$Parameter, fixed = TRUE)] <- "(Intercept)"
out
}
#' @export
ci.meta_random <- function(x, method = "eti", ...) {
# process arguments
params <- as.data.frame(x$estimates)
ci_method <- match.arg(method, choices = c("hdi", "eti", "quantile"))
# extract ci-level and find ci-columns
ci <- .meta_bma_extract_ci(params)
ci_cols <- .metabma_ci_columns(ci_method, ci)
out <- data.frame(
Parameter = rownames(params),
ci = 0.95,
CI_low = params[[ci_cols[1]]],
CI_high = params[[ci_cols[2]]],
stringsAsFactors = FALSE
)
out$Parameter[grepl("d", out$Parameter, fixed = TRUE)] <- "(Intercept)"
out
}
###### .meta_fixed -------------------
#' @export
model_parameters.meta_fixed <- model_parameters.meta_random
#' @export
standard_error.meta_fixed <- standard_error.meta_random
#' @export
ci.meta_fixed <- ci.meta_random
###### .meta_bma -------------------
#' @export
model_parameters.meta_bma <- function(model,
ci = 0.95,
ci_method = "eti",
exponentiate = FALSE,
include_studies = TRUE,
verbose = TRUE,
...) {
# process arguments
params <- as.data.frame(model$estimates)
ci_method <- insight::validate_argument(ci_method, c("hdi", "eti", "quantile"))
# parameters of studies included
study_params <- model$meta$fixed$data
fac <- stats::qnorm((1 + ci) / 2, lower.tail = TRUE)
out_study <- data.frame(
Parameter = study_params$labels,
Coefficient = study_params$y,
SE = study_params$SE,
CI_low = study_params$y - fac * study_params$SE,
CI_high = study_params$y + fac * study_params$SE,
Weight = 1 / study_params$SE^2,
BF = NA,
Rhat = NA,
ESS = NA,
Component = "studies",
stringsAsFactors = FALSE
)
# extract ci-level and find ci-columns
ci <- .meta_bma_extract_ci(params)
ci_cols <- .metabma_ci_columns(ci_method, ci)
out <- data.frame(
Parameter = rownames(params),
Coefficient = params$mean,
SE = params$sd,
CI_low = params[[ci_cols[1]]],
CI_high = params[[ci_cols[2]]],
Weight = NA,
BF = NA,
Rhat = params$Rhat,
ESS = params$n_eff,
Component = "meta",
stringsAsFactors = FALSE
)
# add BF
out$BF <- c(NA, model$BF[2, 1], model$BF[4, 1])
# merge
out <- rbind(out_study, out)
# filter studies?
if (isFALSE(include_studies)) {
out <- out[out$Parameter %in% c("averaged", "fixed", "random"), ]
}
# exponentiate coefficients and SE/CI, if requested
out <- .exponentiate_parameters(out, model, exponentiate)
out <- .add_model_parameters_attributes(
params = out,
model = model,
ci = ci,
exponentiate = exponentiate,
ci_method = ci_method,
verbose = verbose,
...
)
# final attributes
attr(out, "measure") <- "Estimate"
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(out) <- c("parameters_model", "see_parameters_model", class(params))
if (!"Method" %in% names(out)) {
out$Method <- "Bayesian meta-analysis using 'metaBMA'"
}
attr(out, "title") <- unique(out$Method)
out
}
#' @export
standard_error.meta_bma <- standard_error.meta_random
#' @export
ci.meta_bma <- ci.meta_random
# helper ------
.meta_bma_extract_ci <- function(params) {
hpd_col <- colnames(params)[grepl("hpd(\\d+)_lower", colnames(params))]
as.numeric(gsub("hpd(\\d+)_lower", "\\1", hpd_col)) / 100
}
.metabma_ci_columns <- function(ci_method, ci) {
switch(toupper(ci_method),
HDI = sprintf(c("hpd%i_lower", "hpd%i_upper"), 100 * ci),
c(sprintf("%g%%", (100 * (1 - ci)) / 2), sprintf("%g%%", 100 - (100 * (1 - ci)) / 2))
)
}
# format_parameters -----------------------------------
#' @export
format_parameters.meta_random <- function(model, ...) {
params <- insight::find_parameters(model, flatten = TRUE)
names(params) <- params
params
}
#' @export
format_parameters.meta_fixed <- format_parameters.meta_random
#' @export
format_parameters.meta_bma <- format_parameters.meta_random
parameters/R/methods_emmeans.R 0000644 0001762 0000144 00000031637 14736731407 016137 0 ustar ligges users # emmeans
# model_parameters ----------------
#' @export
model_parameters.emmGrid <- function(model,
ci = 0.95,
centrality = "median",
dispersion = FALSE,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# set default for p-adjust
emm_padjust <- .safe(model@misc$adjust)
if (!is.null(emm_padjust) && is.null(p_adjust)) {
p_adjust <- emm_padjust
}
s <- summary(model, level = ci, adjust = "none")
params <- as.data.frame(s)
if (.is_bayesian_emmeans(model)) {
# Bayesian models go here...
params <- bayestestR::describe_posterior(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = NULL,
diagnostic = NULL,
priors = NULL,
verbose = verbose,
...
)
statistic <- NULL
} else {
# we assume frequentist here...
statistic <- insight::get_statistic(model, ci = ci, adjust = "none")
SE <- standard_error(model)
p <- p_value(model, ci = ci, adjust = "none")
params$Statistic <- statistic$Statistic
params$SE <- SE$SE
params$p <- p$p
# ==== adjust p-values?
if (!is.null(p_adjust)) {
params <- .p_adjust(params, p_adjust, model, verbose)
}
}
# Renaming
estName <- attr(s, "estName")
if (!is.null(statistic)) {
names(params) <- gsub(
"Statistic",
gsub("-statistic", "", attr(statistic, "statistic", exact = TRUE), fixed = TRUE),
names(params),
fixed = TRUE
)
}
names(params) <- gsub("Std. Error", "SE", names(params), fixed = TRUE)
names(params) <- gsub(estName, "Estimate", names(params), fixed = TRUE)
names(params) <- gsub("lower.CL", "CI_low", names(params), fixed = TRUE)
names(params) <- gsub("upper.CL", "CI_high", names(params), fixed = TRUE)
names(params) <- gsub("asymp.LCL", "CI_low", names(params), fixed = TRUE)
names(params) <- gsub("asymp.UCL", "CI_high", names(params), fixed = TRUE)
names(params) <- gsub("lower.HPD", "CI_low", names(params), fixed = TRUE)
names(params) <- gsub("upper.HPD", "CI_high", names(params), fixed = TRUE)
# check if we have CIs
if (!any(startsWith(colnames(params), "CI_"))) {
df_column <- grep("(df|df_error)", colnames(params))
if (length(df_column) > 0) {
dof <- params[[df_column[1]]]
} else {
dof <- Inf
}
fac <- stats::qt((1 + ci) / 2, df = dof)
params$CI_low <- params$Estimate - fac * params$SE
params$CI_high <- params$Estimate + fac * params$SE
}
# rename if necessary
if ("df" %in% colnames(params)) {
colnames(params)[colnames(params) == "df"] <- "df_error"
}
# Reorder
estimate_pos <- which(colnames(s) == estName)
parameter_names <- colnames(params)[seq_len(estimate_pos - 1)]
col_order <- c(
parameter_names, "Estimate", "Median", "Mean", "SE", "SD", "MAD",
"CI_low", "CI_high", "F", "t", "z", "df", "df_error", "p", "pd",
"ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage"
)
params <- params[col_order[col_order %in% names(params)]]
# rename
names(params) <- gsub("Estimate", "Coefficient", names(params), fixed = TRUE)
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
# filter parameters
if (!is.null(keep) || !is.null(drop)) {
params <- .filter_parameters(params,
keep = keep,
drop = drop,
verbose = verbose
)
}
params <- suppressWarnings(.add_model_parameters_attributes(
params,
model,
ci,
exponentiate = FALSE,
p_adjust = p_adjust,
verbose = verbose,
...
))
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(params, "parameter_names") <- parameter_names
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
model_parameters.emm_list <- function(model,
ci = 0.95,
exponentiate = FALSE,
p_adjust = NULL,
verbose = TRUE,
...) {
s <- summary(model)
params <- lapply(seq_along(s), function(i) {
pars <- model_parameters(
model[[i]],
ci = ci,
exponentiate = exponentiate,
p_adjust = p_adjust,
verbose = verbose
)
estimate_pos <- which(colnames(pars) %in% c("Coefficient", "Median", "Mean"))[1]
pars[seq_len(estimate_pos - 1)] <- NULL
cbind(
Parameter = .pretty_emmeans_Parameter_names(model[[i]]),
pars
)
})
params <- do.call(rbind, params)
params$Component <- .pretty_emmeans_Component_names(s)
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(
params,
model,
ci,
exponentiate,
p_adjust = p_adjust,
verbose = verbose,
...
)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
model_parameters.summary_emm <- function(model,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
params <- model
# Renaming
estName <- attr(model, "estName")
names(params) <- gsub("Std. Error", "SE", names(params), fixed = TRUE)
names(params) <- gsub(estName, "Estimate", names(params), fixed = TRUE)
names(params) <- gsub("response", "Response", names(params), fixed = TRUE)
names(params) <- gsub("lower.CL", "CI_low", names(params), fixed = TRUE)
names(params) <- gsub("upper.CL", "CI_high", names(params), fixed = TRUE)
names(params) <- gsub("asymp.LCL", "CI_low", names(params), fixed = TRUE)
names(params) <- gsub("asymp.UCL", "CI_high", names(params), fixed = TRUE)
names(params) <- gsub("lower.HPD", "CI_low", names(params), fixed = TRUE)
names(params) <- gsub("upper.HPD", "CI_high", names(params), fixed = TRUE)
# rename if necessary
if ("df" %in% colnames(params)) {
colnames(params)[colnames(params) == "df"] <- "df_error"
}
# Reorder
estimate_pos <- which(colnames(model) == estName)
parameter_names <- colnames(params)[seq_len(estimate_pos - 1)]
col_order <- c(
parameter_names, "Estimate", "Median", "Mean", "SE", "SD", "MAD",
"CI_low", "CI_high", "F", "t", "z", "df", "df_error", "p", "pd",
"ROPE_CI", "ROPE_low", "ROPE_high", "ROPE_Percentage"
)
params <- params[col_order[col_order %in% names(params)]]
# rename
names(params) <- gsub("Estimate", "Coefficient", names(params), fixed = TRUE)
# filter parameters
if (!is.null(keep) || !is.null(drop)) {
params <- .filter_parameters(params,
keep = keep,
drop = drop,
verbose = verbose
)
}
params <- suppressWarnings(.add_model_parameters_attributes(
params,
model,
ci = 0.95,
exponentiate = FALSE,
p_adjust = NULL,
verbose = verbose,
...
))
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(params, "parameter_names") <- parameter_names
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
# standard errors -----------------
#' @export
standard_error.emmGrid <- function(model, ...) {
if (!is.null(model@misc$is_boot) && model@misc$is_boot) {
return(boot_em_standard_error(model))
}
s <- summary(model)
estimate_pos <- which(colnames(s) == attr(s, "estName"))
if (length(estimate_pos) && !is.null(s$SE)) {
out <- .data_frame(
Parameter = .pretty_emmeans_Parameter_names(model),
SE = unname(s$SE)
)
} else {
out <- NULL
}
out
}
#' @export
standard_error.emm_list <- function(model, ...) {
if (!is.null(model[[1]]@misc$is_boot) && model[[1]]@misc$is_boot) {
return(boot_em_standard_error(model))
}
params <- insight::get_parameters(model)
s <- summary(model)
se <- unlist(lapply(s, function(i) {
if (is.null(i$SE)) {
rep(NA, nrow(i))
} else {
i$SE
}
}))
.data_frame(
Parameter = .pretty_emmeans_Parameter_names(model),
SE = unname(se),
Component = .pretty_emmeans_Component_names(s)
)
}
boot_em_standard_error <- function(model) {
est <- insight::get_parameters(model, summary = FALSE)
Component <- NULL
s <- summary(model)
if (inherits(s, "list")) {
Component <- .pretty_emmeans_Component_names(s)
}
out <- .data_frame(
Parameter = .pretty_emmeans_Parameter_names(model),
SE = vapply(est, stats::sd, numeric(1))
)
if (!is.null(Component)) out$Component <- Component
out
}
# p values ----------------------
#' @rdname p_value
#' @export
p_value.emmGrid <- function(model, ci = 0.95, adjust = "none", ...) {
if (!is.null(model@misc$is_boot) && model@misc$is_boot) {
return(boot_em_pval(model, adjust))
}
s <- summary(model, level = ci, adjust = adjust)
estimate_pos <- which(colnames(s) == attr(s, "estName"))
if (!length(estimate_pos)) {
return(NULL)
}
stat <- insight::get_statistic(model, ci = ci, adjust = adjust)
p <- 2 * stats::pt(abs(stat$Statistic), df = s$df, lower.tail = FALSE)
.data_frame(
Parameter = .pretty_emmeans_Parameter_names(model),
p = as.vector(p)
)
}
#' @export
p_value.emm_list <- function(model, adjust = "none", ...) {
if (!is.null(model[[1]]@misc$is_boot) && model[[1]]@misc$is_boot) {
return(boot_em_pval(model, adjust))
}
params <- insight::get_parameters(model)
s <- summary(model, adjust = adjust)
# p-values
p <- unlist(lapply(s, function(i) {
if (is.null(i$p)) {
rep(NA, nrow(i))
} else {
i$p
}
}))
# result
out <- .data_frame(
Parameter = .pretty_emmeans_Parameter_names(model),
p = as.vector(p),
Component = .pretty_emmeans_Component_names(s)
)
# any missing values?
if (anyNA(out$p)) {
# standard errors
se <- unlist(lapply(s, function(i) {
if (is.null(i$SE)) {
rep(NA, nrow(i))
} else {
i$SE
}
}))
# test statistic and p-values
stat <- params$Estimate / se
dof <- insight::get_df(model)
p_val <- 2 * stats::pt(abs(stat), df = dof, lower.tail = FALSE)
out$p[is.na(out$p)] <- p_val[is.na(out$p)]
}
out
}
boot_em_pval <- function(model, adjust) {
est <- insight::get_parameters(model, summary = FALSE)
p <- sapply(est, p_value)
p <- stats::p.adjust(p, method = adjust)
Component <- NULL
s <- summary(model)
if (inherits(s, "list")) {
Component <- .pretty_emmeans_Component_names(s)
}
out <- .data_frame(
Parameter = .pretty_emmeans_Parameter_names(model),
p = unname(p)
)
if (!is.null(Component)) out$Component <- Component
out
}
# format parameters -----------------
#' @export
format_parameters.emm_list <- function(model, ...) {
NULL
}
# Utils -------------------------------------------------------------------
.pretty_emmeans_Parameter_names <- function(model) {
s <- summary(model)
if (inherits(s, "list")) {
parnames <- lapply(seq_along(s), function(i) .pretty_emmeans_Parameter_names(model[[i]]))
parnames <- unlist(parnames)
} else {
estimate_pos <- which(colnames(s) == attr(s, "estName"))
params <- s[, 1:(estimate_pos - 1), drop = FALSE]
if (ncol(params) >= 2) {
r <- apply(params, 1, function(i) paste0(colnames(params), " [", i, "]"))
parnames <- unname(sapply(as.data.frame(r), toString))
} else {
parnames <- as.vector(params[[1]])
}
}
parnames
}
.pretty_emmeans_Component_names <- function(s) {
Component <- lapply(seq_along(s), function(i) {
rep(names(s)[[i]], nrow(s[[i]]))
})
Component <- unlist(Component)
}
.is_bayesian_emmeans <- function(model) {
is_frq <- isTRUE(all.equal(dim(model@post.beta), c(1, 1))) &&
isTRUE(is.na(model@post.beta)) && is.null(model@misc$is_boot)
isFALSE(is_frq)
}
parameters/R/print_html.R 0000644 0001762 0000144 00000025316 14761570351 015141 0 ustar ligges users # normal print ----------------------------
#' @rdname print.parameters_model
#' @export
print_html.parameters_model <- function(x,
pretty_names = TRUE,
split_components = TRUE,
select = NULL,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
footer_digits = 3,
ci_brackets = c("(", ")"),
show_sigma = FALSE,
show_formula = FALSE,
zap_small = FALSE,
groups = NULL,
font_size = "100%",
line_padding = 4,
column_labels = NULL,
include_reference = FALSE,
verbose = TRUE,
...) {
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", p_digits)
}
if (missing(footer_digits)) {
footer_digits <- .additional_arguments(x, "footer_digits", footer_digits)
}
# get attributes
if (missing(select) || is.null(select)) {
select <- attributes(x)$output_style
}
if (missing(groups)) {
groups <- attributes(x)$parameter_groups
}
# we need glue-like syntax right now...
if (!is.null(select)) {
select <- .convert_to_glue_syntax(style = select, "
")
}
# check options ---------------
# check if pretty names should be replaced by value labels
# (if we have labelled data)
if (isTRUE(getOption("parameters_labels", FALSE)) || identical(pretty_names, "labels")) {
attr(x, "pretty_names") <- attr(x, "pretty_labels", exact = TRUE)
pretty_names <- TRUE
}
# select which columns to print
if (is.null(select)) {
select <- getOption("parameters_select")
}
# table caption
table_caption <- .print_caption(x, caption, format = "html")
# main table
formatted_table <- .print_core(
x = x,
pretty_names = pretty_names,
split_components = split_components,
select = select,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
zap_small = zap_small,
ci_width = NULL,
ci_brackets = ci_brackets,
format = "html",
groups = groups,
include_reference = include_reference,
...
)
# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
}
# footer
footer_stats <- .print_footer(
x,
digits = footer_digits,
show_sigma = show_sigma,
show_formula = show_formula,
format = "html"
)
if (!is.null(footer)) {
footer <- paste0(footer, "
", paste(footer_stats, collapse = "
"))
} else if (!is.null(footer_stats)) {
footer <- paste(footer_stats, collapse = "
")
}
out <- insight::export_table(
formatted_table,
format = "html",
caption = table_caption,
subtitle = subtitle,
footer = footer,
align = align,
...
)
.add_gt_options(
out,
style = select,
font_size = font_size,
line_padding = line_padding,
user_labels = column_labels
)
}
#' @export
print_html.parameters_brms_meta <- print_html.parameters_model
#' @export
print_html.parameters_simulate <- print_html.parameters_model
#' @export
print_html.parameters_sem <- print_html.parameters_model
#' @rdname print.compare_parameters
#' @export
print_html.compare_parameters <- function(x,
caption = NULL,
subtitle = NULL,
footer = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
zap_small = FALSE,
groups = NULL,
select = NULL,
ci_brackets = c("(", ")"),
font_size = "100%",
line_padding = 4,
column_labels = NULL,
engine = "gt",
...) {
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", p_digits)
}
# get attributes
if (missing(select) || is.null(select)) {
select <- attributes(x)$output_style
}
# markdown engine?
engine <- match.arg(getOption("easystats_html_engine", engine), c("gt", "default", "tt"))
# for tiny table, we can just call print_md()
if (engine == "tt") {
return(print_md(
x,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
caption = caption,
subtitle = subtitle,
footer = footer,
select = select,
split_components = TRUE,
ci_brackets = ci_brackets,
zap_small = zap_small,
groups = groups,
engine = "tt",
outformat = "html"
))
}
# we need glue-like syntax right now...
select <- .convert_to_glue_syntax(style = select, "
")
formatted_table <- format(
x,
select = select,
split_components = TRUE,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
ci_width = NULL,
ci_brackets = ci_brackets,
format = "html",
zap_small = zap_small,
groups = groups
)
# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
}
out <- insight::export_table(
formatted_table,
format = "html",
caption = caption, # TODO: get rid of NOTE
subtitle = subtitle,
footer = footer,
...
)
.add_gt_options(
out,
style = select,
font_size = font_size,
line_padding = line_padding,
# we assume that model names are at the end of each column name, in parenthesis
original_colnames = gsub("(.*) \\((.*)\\)$", "\\2", colnames(formatted_table))[-1],
column_names = colnames(formatted_table),
user_labels = column_labels
)
}
# helper ------------------
.add_gt_options <- function(out,
style,
font_size = "100%",
line_padding = 4,
original_colnames = NULL,
column_names = NULL,
user_labels = NULL) {
insight::check_if_installed("gt")
out <- gt::tab_options(out,
table.font.size = font_size,
data_row.padding = gt::px(line_padding)
)
# insert newlines
if (!is.null(style) && grepl("
", style, fixed = TRUE)) {
insight::check_if_installed("tidyselect")
out <- gt::fmt_markdown(out, columns = tidyselect::everything())
}
# user defined column labels
new_labels <- NULL
if (!is.null(user_labels)) {
new_labels <- c(
colnames(out[["_data"]])[1],
rep_len(user_labels, ncol(out[["_data"]]) - 1)
)
new_labels <- as.list(new_labels)
}
# add a column span? here we have multiple columns (like estimate, CI, p, ...)
# for each model. In this case, we want to add a column spanner, i.e. a
# separate heading for all columns of each model.
if (!is.null(original_colnames) && anyDuplicated(original_colnames) > 0) {
duplicates <- original_colnames[duplicated(original_colnames)]
for (d in duplicates) {
# we need +1 here, because first column is parameter column
span <- which(original_colnames == d) + 1
# add column spanner
out <- gt::tab_spanner(out, label = d, columns = span)
}
# relabel columns. The single columns still have their old labels
# (like "Estimate (model1)", "p (model1)"), and we extracted the "model names"
# and used them for the column spanner. Now we no longer need this suffix,
# and remove it. In case user-defined column labels are provided, "new_labels"
# is not NULL, so we use user labels, else we extract labels from columns.
if (!is.null(column_names)) {
if (is.null(new_labels)) {
new_labels <- as.list(gsub("(.*) \\((.*)\\)$", "\\1", column_names))
}
names(new_labels) <- column_names
out <- gt::cols_label(out, .list = new_labels)
}
# default column label, if we have user labels
} else if (!is.null(new_labels)) {
names(new_labels) <- colnames(out[["_data"]])
out <- gt::cols_label(out, .list = new_labels)
}
# find name of parameter column
pcol_name <- colnames(out[["_data"]])[1]
# check where last parameter row ends. For "compare_models()", the
# first Parameter value after data rows is "". If this is not found,
# simply use number of rows as last row
last_row <- which(!nzchar(as.character(out[["_data"]][[pcol_name]]), keepNA = TRUE))[1]
if (is.na(last_row)) {
last_row <- nrow(out[["_data"]])
} else {
last_row <- last_row - 1
}
# add a border to the first column.
out <- gt::tab_style(
out,
style = gt::cell_borders(
sides = "right",
style = "solid",
color = "#d3d3d3"
),
locations = gt::cells_body(
columns = pcol_name,
rows = 1:last_row
)
)
out
}
parameters/R/methods_DirichletReg.R 0000644 0001762 0000144 00000006452 14717111737 017051 0 ustar ligges users #' @export
model_parameters.DirichletRegModel <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "all",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
if (component == "all") {
merge_by <- c("Parameter", "Component", "Response")
} else {
merge_by <- c("Parameter", "Response")
}
## TODO check merge by
junk <- utils::capture.output({
out <- .model_parameters_generic(
model = model,
ci = ci,
component = component,
bootstrap = bootstrap,
iterations = iterations,
merge_by = merge_by,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
...
)
})
out$Response[is.na(out$Response)] <- ""
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
ci.DirichletRegModel <- function(x, ci = 0.95, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
params <- insight::get_parameters(x, component = component)
out <- .ci_generic(model = x, ci = ci, dof = Inf, ...)
if (is.null(out$Component)) {
component <- "all"
}
if ("Response" %in% colnames(params)) {
out$Response <- params$Response
}
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
standard_error.DirichletRegModel <- function(model, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
params <- insight::get_parameters(model)
out <- .data_frame(
Parameter = params$Parameter,
Response = params$Response,
SE = as.vector(model$se)
)
if (is.null(params$Component)) {
component <- "all"
} else {
out$Component <- params$Component
}
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
p_value.DirichletRegModel <- function(model, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
params <- insight::get_parameters(model)
out <- .data_frame(
Parameter = params$Parameter,
Response = params$Response,
p = as.vector(2 * stats::pnorm(-abs(params$Estimate / model$se)))
)
if (is.null(params$Component)) {
component <- "all"
} else {
out$Component <- params$Component
}
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
parameters/R/methods_brglm2.R 0000644 0001762 0000144 00000017013 14761570351 015664 0 ustar ligges users # classes: .bracl, .multinom, .brmultinom
## TODO add ci_method later?
############# .bracl --------------
#' @export
model_parameters.bracl <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(model)[1],
verbose = verbose
)
# detect number of levels of response
resp <- insight::get_response(model)
# for cbind(), response is a data frame, not a factor. We then need to use
# number of columns as "nl"
if (is.data.frame(resp)) {
nl <- ncol(resp)
} else {
nl <- .safe(nlevels(factor(resp)), 0)
}
# merge by response as well if more than 2 levels
if (nl > 2) {
merge_by <- c("Parameter", "Response")
} else {
merge_by <- "Parameter"
}
fun_args <- list(
model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = merge_by,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
include_info = include_info,
vcov = NULL,
vcov_args = NULL
)
fun_args <- c(fun_args, dot_args)
out <- do.call(".model_parameters_generic", fun_args)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
ci.bracl <- function(x, ci = 0.95, method = NULL, verbose = TRUE, ...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(x)[1],
function_name = "ci",
verbose = verbose
)
params <- insight::get_parameters(x)
out <- .ci_generic(model = x, ci = ci, method = method, ...)
if ("Response" %in% colnames(params)) {
out$Response <- params$Response
}
out
}
#' @export
standard_error.bracl <- function(model, verbose = TRUE, ...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(model)[1],
function_name = "standard_error",
verbose = verbose
)
smry <- suppressMessages(as.data.frame(stats::coef(summary(model))))
se <- smry[[2]]
names(se) <- rownames(smry)
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
SE = as.vector(se),
Response = params$Response
)
}
#' @export
p_value.bracl <- function(model, verbose = TRUE, ...) {
# validation check, warn if unsupported argument is used.
dot_args <- .check_dots(
dots = list(...),
not_allowed = c("vcov", "vcov_args"),
class(model)[1],
function_name = "p_value",
verbose = verbose
)
smry <- suppressMessages(as.data.frame(stats::coef(summary(model))))
p <- smry[[4]]
names(p) <- rownames(smry)
params <- insight::get_parameters(model)
.data_frame(
Parameter = params$Parameter,
p = as.vector(p),
Response = params$Response
)
}
############# .multinom --------------
#' @export
model_parameters.multinom <- function(model,
ci = 0.95,
ci_method = "normal",
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
model_parameters.bracl(
model,
ci = ci,
ci_method = ci_method,
bootstrap = bootstrap,
iterations = iterations,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
include_info = include_info,
keep = keep,
drop = drop,
verbose = verbose,
...
)
}
#' @export
ci.multinom <- function(x, ci = 0.95, method = "normal", verbose = TRUE, ...) {
ci.bracl(x, ci = ci, method = method, verbose = verbose, ...)
}
#' @export
standard_error.multinom <- function(model, ...) {
se <- tryCatch(
{
std_err <- summary(model)$standard.errors
if (is.null(std_err)) {
vc <- insight::get_varcov(model)
std_err <- as.vector(sqrt(diag(vc)))
} else {
if (is.matrix(std_err)) {
tmp <- NULL
for (i in seq_len(nrow(std_err))) {
tmp <- c(tmp, as.vector(std_err[i, ]))
}
} else {
tmp <- as.vector(std_err)
}
std_err <- tmp
}
std_err
},
error = function(e) {
vc <- insight::get_varcov(model)
as.vector(sqrt(diag(vc)))
}
)
params <- insight::get_parameters(model)
if ("Response" %in% colnames(params)) {
.data_frame(
Parameter = params$Parameter,
SE = se,
Response = params$Response
)
} else {
.data_frame(
Parameter = params$Parameter,
SE = se
)
}
}
#' @export
p_value.multinom <- function(model, method = "normal", ...) {
stat <- insight::get_statistic(model)
out <- p_value.default(model, method = method, ...)
if (!is.null(stat$Response)) {
out$Response <- stat$Response
}
out
}
#' @export
simulate_parameters.multinom <- function(model,
iterations = 1000,
centrality = "median",
ci = 0.95,
ci_method = "quantile",
test = "p-value",
...) {
sim_data <- simulate_model(model, iterations = iterations, ...)
out <- .summary_bootstrap(
data = sim_data,
test = test,
centrality = centrality,
ci = ci,
ci_method = ci_method,
...
)
params <- insight::get_parameters(model)
out$Parameter <- params$Parameter
if ("Response" %in% colnames(params)) {
out$Response <- params$Response
}
class(out) <- c("parameters_simulate", "see_parameters_simulate", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(out, "iterations") <- iterations
attr(out, "ci") <- ci
attr(out, "ci_method") <- ci_method
attr(out, "centrality") <- centrality
out
}
############# .brmultinom --------------
#' @export
model_parameters.brmultinom <- model_parameters.bracl
#' @export
ci.brmultinom <- ci.bracl
#' @export
standard_error.brmultinom <- standard_error.multinom
#' @export
p_value.brmultinom <- p_value.multinom
parameters/R/methods_mclogit.R 0000644 0001762 0000144 00000003521 14761570351 016134 0 ustar ligges users #' @export
model_parameters.mblogit <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
out <- .model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Response"),
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
include_info = include_info,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.mblogit <- function(model, ...) {
s <- stats::coef(summary(model))
out <- data.frame(
Parameter = gsub("(.*)~(.*)", "\\2", rownames(s)),
SE = unname(s[, "Std. Error"]),
Response = gsub("(.*)~(.*)", "\\1", rownames(s)),
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
p_value.mblogit <- function(model, ...) {
s <- stats::coef(summary(model))
out <- data.frame(
Parameter = gsub("(.*)~(.*)", "\\2", rownames(s)),
p = unname(s[, "Pr(>|z|)"]),
Response = gsub("(.*)~(.*)", "\\1", rownames(s)),
stringsAsFactors = FALSE,
row.names = NULL
)
}
#' @export
simulate_parameters.mblogit <- simulate_parameters.multinom
parameters/R/ci_betwithin.R 0000644 0001762 0000144 00000000617 14317274256 015430 0 ustar ligges users #' @rdname p_value_betwithin
#' @export
ci_betwithin <- function(model, ci = 0.95, ...) {
df_bet <- dof_ml1(model)
out <- lapply(ci, function(i) {
.ci_dof(
model = model,
ci = i,
effects = "fixed",
component = "all",
dof = df_bet,
method = "betwithin",
...
)
})
out <- do.call(rbind, out)
row.names(out) <- NULL
out
}
parameters/R/methods_ggeffects.R 0000644 0001762 0000144 00000006740 14716604200 016430 0 ustar ligges users #' @export
model_parameters.ggeffects <- function(model, keep = NULL, drop = NULL, verbose = TRUE, ...) {
ci <- attributes(model)$ci.lvl
## TODO: deprecate later, this is forthcoming in ggeffects 1.8.0
if (is.null(ci)) {
ci <- attributes(model)$ci_level
}
co_terms <- attributes(model)$terms[-1]
focal_term <- attributes(model)$terms[1]
constant_values <- attributes(model)$constant.values
caption <- attr(model, "title")
# exception for survival
if (attributes(model)$type %in% c("surv", "survival", "cumhaz", "cumulative_hazard")) {
focal_term <- "Time"
}
model <- as.data.frame(model, terms_to_colnames = FALSE)
# rename columns
new_colnames <- colnames(model)
new_colnames[new_colnames == "predicted"] <- "Predicted"
new_colnames[new_colnames == "std.error"] <- "SE"
new_colnames[new_colnames == "conf.low"] <- "CI_low"
new_colnames[new_colnames == "conf.high"] <- "CI_high"
new_colnames[new_colnames == "group"] <- "Component"
new_colnames[new_colnames == "facet"] <- "Group"
new_colnames[new_colnames == "response"] <- "Subgroup"
colnames(model) <- new_colnames
model$SE <- NULL
if (insight::n_unique(model$Component) == 1) {
model$Component <- NULL
}
if (!is.null(focal_term)) {
colnames(model)[1] <- focal_term
}
if (length(co_terms) >= 1) {
model$Component <- paste0(co_terms[1], " = ", model$Component)
}
if (length(co_terms) >= 2) {
model$Group <- paste0(co_terms[2], " = ", model$Group)
}
if (length(co_terms) >= 3) {
model$Subgroup <- paste0(co_terms[3], " = ", model$Subgroup)
}
# filter parameters
if (!is.null(keep) || !is.null(drop)) {
model <- .filter_parameters(model,
keep = keep,
drop = drop,
verbose = verbose
)
}
model <- .add_model_parameters_attributes(model, model, ci = ci, verbose = verbose)
# special attributes
attr(model, "is_ggeffects") <- TRUE
attr(model, "footer_text") <- .generate_ggeffects_footer(constant_values)
attr(model, "title") <- c(caption, "blue")
attr(model, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(model) <- c("parameters_model", "data.frame")
model
}
.generate_ggeffects_footer <- function(constant_values) {
cv <- lapply(constant_values, function(.x) {
if (is.numeric(.x)) {
sprintf("%.2f", .x)
} else {
as.character(.x)
}
})
footer <- NULL
if (!insight::is_empty_object(cv)) {
cv.names <- names(cv)
cv.space <- max(nchar(cv.names))
# ignore this string when determining maximum length
poplev <- which(cv %in% c("NA (population-level)", "0 (population-level)"))
if (insight::is_empty_object(poplev)) {
mcv <- cv
} else {
mcv <- cv[-poplev]
}
if (insight::is_empty_object(mcv)) {
cv.space2 <- 0
} else {
cv.space2 <- max(nchar(mcv))
}
adjusted_predictors <- paste0(sprintf("* %*s = %*s", cv.space, cv.names, cv.space2, cv), collapse = "\n")
footer <- paste0("Adjusted for:\n", adjusted_predictors)
}
footer
}
.get_ggeffects_model <- function(x) {
obj_name <- attr(x, "model.name", exact = TRUE)
.model <- NULL
if (!is.null(obj_name)) {
.model <- .safe(get(obj_name, envir = parent.frame()))
if (is.null(.model)) {
.model <- .safe(get(obj_name, envir = globalenv()))
}
if (is.null(.model)) {
.model <- .safe(.dynGet(obj_name))
}
}
.model
}
parameters/R/methods_FactoMineR.R 0000644 0001762 0000144 00000004664 14717115074 016474 0 ustar ligges users #' @export
model_parameters.PCA <- function(model,
sort = FALSE,
threshold = NULL,
labels = NULL,
verbose = TRUE,
...) {
loadings <- as.data.frame(model$var$coord)
n <- model$call$ncp
# Get summary
eig <- as.data.frame(model$eig[1:n, ])
data_summary <- .data_frame(
Component = names(loadings),
Eigenvalues = eig$eigenvalue,
Variance = eig$`percentage of variance` / 100,
Variance_Cumulative = eig$`cumulative percentage of variance` / 100
)
data_summary$Variance_Proportion <- data_summary$Variance / sum(data_summary$Variance)
# Format
loadings <- cbind(data.frame(Variable = row.names(loadings)), loadings)
row.names(loadings) <- NULL
# Labels
if (!is.null(labels)) {
loadings$Label <- labels
loadings <- loadings[c("Variable", "Label", names(loadings)[!names(loadings) %in% c("Variable", "Label")])]
loading_cols <- 3:(n + 2)
} else {
loading_cols <- 2:(n + 1)
}
loadings$Complexity <- (apply(loadings[, loading_cols, drop = FALSE], 1, function(x) sum(x^2)))^2 / apply(loadings[, loading_cols, drop = FALSE], 1, function(x) sum(x^4))
# Add attributes
attr(loadings, "summary") <- data_summary
attr(loadings, "model") <- model
attr(loadings, "rotation") <- "none"
attr(loadings, "scores") <- as.data.frame(model$ind$coord)
attr(loadings, "additional_arguments") <- list(...)
attr(loadings, "n") <- n
attr(loadings, "loadings_columns") <- loading_cols
# Sorting
if (isTRUE(sort)) {
loadings <- .sort_loadings(loadings)
}
# Replace by NA all cells below threshold
if (!is.null(threshold)) {
loadings <- .filter_loadings(loadings, threshold = threshold)
}
# Add some more attributes
attr(loadings, "loadings_long") <- .long_loadings(loadings, threshold = threshold, loadings_columns = loading_cols)
# add class-attribute for printing
if (inherits(model, "PCA")) {
attr(loadings, "type") <- "pca"
class(loadings) <- unique(c("parameters_pca", "see_parameters_pca", class(loadings)))
} else if (inherits(model, "FAMD")) {
attr(loadings, "type") <- "fa"
class(loadings) <- unique(c("parameters_efa", "see_parameters_efa", class(loadings)))
}
loadings
}
#' @export
model_parameters.FAMD <- model_parameters.PCA
parameters/R/standardize_info.R 0000644 0001762 0000144 00000043244 14736731407 016307 0 ustar ligges users #' Get Standardization Information
#'
#' This function extracts information, such as the deviations (SD or MAD) from
#' parent variables, that are necessary for post-hoc standardization of
#' parameters. This function gives a window on how standardized are obtained,
#' i.e., by what they are divided. The "basic" method of standardization uses.
#'
#' @inheritParams standardize_parameters
#' @param include_pseudo (For (G)LMMs) Should Pseudo-standardized information be
#' included?
#' @param ... Arguments passed to or from other methods.
#'
#' @return A data frame with information on each parameter (see
#' [`parameters_type()`]), and various standardization coefficients
#' for the post-hoc methods (see [`standardize_parameters()`]) for the predictor
#' and the response.
#'
#' @family standardize
#'
#' @examplesIf insight::check_if_installed("datawizard", minimum_version = "0.12.0", quietly = TRUE)
#' model <- lm(mpg ~ ., data = mtcars)
#' standardize_info(model)
#' standardize_info(model, robust = TRUE)
#' standardize_info(model, two_sd = TRUE)
#' @aliases standardise_info
#' @export
standardize_info <- function(model, ...) {
UseMethod("standardize_info")
}
#' @export
standardise_info <- standardize_info
#' @rdname standardize_info
#' @export
standardize_info.default <- function(model,
robust = FALSE,
two_sd = FALSE,
include_pseudo = FALSE,
verbose = TRUE,
...) {
# check for valid input
.is_model_valid(model)
mi <- .get_model_info(model, ...)
params <- if (inherits(model, c("glmmTMB", "MixMod"))) {
insight::find_parameters(model, effects = "fixed", component = "conditional", flatten = TRUE, ...)
} else {
insight::find_parameters(model, effects = "fixed", flatten = TRUE, ...)
}
types <- parameters_type(model)
# model_matrix <- as.data.frame(stats::model.matrix(model))
model_matrix <- as.data.frame(insight::get_modelmatrix(model))
model_data <- insight::get_data(model, source = "mf", verbose = FALSE)
wgts <- insight::get_weights(model, remove_na = TRUE)
# validation check for ZI
if (mi$is_zero_inflated && verbose) {
insight::format_alert(
"Non-refit parameter standardization is ignoring the zero-inflation component."
)
# would need to also get the binomial model matrix...
}
# validation check for glmmTMB with dispersion
if (length(params) != nrow(types)) {
types <- types[types$Parameter %in% params, ]
}
out <- data.frame(
Parameter = params,
Type = types$Type,
Link = types$Link,
Secondary_Parameter = types$Secondary_Parameter,
stringsAsFactors = FALSE
)
# Type of effect size
out$EffectSize_Type <- ifelse(types$Type == "interaction", "interaction",
ifelse(types$Link == "Association", "r", # nolint
ifelse(types$Link == "Difference", "d", NA) # nolint
)
)
# Response - Basic
out <- merge(
out,
.std_info_response_basic(model, mi, params, robust = robust, w = wgts),
by = "Parameter", all = TRUE
)
# Response - Smart
out <- merge(
out,
.std_info_response_smart(model, mi, data = model_data, model_matrix, types, robust = robust, w = wgts),
by = "Parameter", all = TRUE
)
# Basic
out <- merge(
out,
.std_info_predictors_basic(model, model_matrix, types, robust = robust, two_sd = two_sd, w = wgts),
by = "Parameter", all = TRUE
)
# Smart
out <- merge(
out,
.std_info_predictors_smart(model,
data = model_data,
params,
types,
robust = robust,
two_sd = two_sd,
w = wgts
),
by = "Parameter", all = TRUE
)
# sdy (see Mood 2009, 10.1093/esr/jcp006)
out <- merge(
out,
.std_info_predictors_sdy(model, model_matrix, types, robust = robust, two_sd = two_sd, w = wgts),
by = "Parameter", all = TRUE
)
# Pseudo (for LMM)
if (include_pseudo && mi$is_mixed && length(insight::find_random(model)$random) == 1L) {
out <- merge(
out,
.std_info_pseudo(
model, mi,
params,
model_matrix,
data = model_data,
types = types$Type,
robust = robust,
two_sd = two_sd,
verbose = verbose
)
)
}
# Reorder
out <- out[match(params, out$Parameter), ]
out$Parameter <- params
row.names(out) <- NULL
# Remove all means for now (because it's not used)
out <- out[!grepl("Mean_", names(out), fixed = TRUE)]
# Select only desired columns
# if(method == "all") method <- c("smart", "basic")
# if(!any(method == "smart")){
# out <- out[!grepl("_Smart", names(out))]
# }
# if(!any(method == "basic")){
# out <- out[!grepl("_Basic", names(out))]
# }
out
}
# Predictors - Smart ------------------------------------------------------------
#' @keywords internal
.std_info_predictors_smart <- function(model,
data,
params,
types,
robust = FALSE,
two_sd = FALSE,
w = NULL,
...) {
# Get deviations for all parameters
means <- deviations <- rep(NA_real_, times = length(params))
for (i in seq_along(params)) {
variable <- params[i]
info <- .std_info_predictor_smart(
data = data,
variable = types[types$Parameter == variable, "Variable"],
type = types[types$Parameter == variable, "Type"],
robust = robust,
two_sd = two_sd,
weights = w
)
deviations[i] <- info$sd
means[i] <- info$mean
}
# Out
data.frame(
Parameter = params,
Deviation_Smart = deviations,
Mean_Smart = means,
stringsAsFactors = FALSE
)
}
#' @keywords internal
.std_info_predictor_smart <- function(data,
variable,
type,
robust = FALSE,
two_sd = FALSE,
weights = NULL,
...) {
if (type == "intercept") { # nolint
info <- list(sd = 0, mean = 0)
} else if (type == "numeric") {
info <- .compute_std_info(
data = data,
variable = variable,
robust = robust,
two_sd = two_sd,
weights = weights
)
} else if (type == "factor") {
info <- list(sd = 1, mean = 0)
# TO BE IMPROVED: Adjust if involved in interactions
# interactions <- types[types$Type %in% c("interaction"), ]
# if(variable %in% interactions$Secondary_Variable){
# interac_var <- unique(interactions[interactions$Secondary_Variable == variable, "Variable"])
# for(i in interac_var){
# if(types[types$Parameter == i, "Type"] == "numeric"){
# sd_x <- sd_x * .get_deviation(data, i, robust)
# }
# }
# }
} else if (type %in% c("interaction", "nested")) {
if (is.numeric(data[, variable])) {
info <- .compute_std_info(
data = data,
variable = variable,
robust = robust,
two_sd = two_sd,
weights = weights
)
} else if (is.factor(data[, variable])) {
info <- list(sd = 1, mean = 0)
} else {
info <- list(sd = 1, mean = 0)
}
} else {
info <- list(sd = 1, mean = 0)
}
list(sd = info$sd, mean = info$mean)
}
# Predictors - Basic ------------------------------------------------------------
#' @keywords internal
.std_info_predictors_basic <- function(model,
model_matrix,
types,
robust = FALSE,
two_sd = FALSE,
w = NULL,
...) {
# Get deviations for all parameters
means <- deviations <- rep(NA_real_, length = length(names(model_matrix)))
for (i in seq_along(names(model_matrix))) {
variable <- names(model_matrix)[i]
if (types[i, "Type"] == "intercept") {
means[i] <- deviations[i] <- 0
} else {
std_info <- .compute_std_info(
data = model_matrix, variable = variable,
robust = robust, two_sd = two_sd, weights = w
)
deviations[i] <- std_info$sd
means[i] <- std_info$mean
}
}
# Out
data.frame(
Parameter = types$Parameter[seq_along(names(model_matrix))],
Deviation_Basic = deviations,
Mean_Basic = means,
stringsAsFactors = FALSE
)
}
# Predictors - sdy ------------------------------------------------------------
#' @keywords internal
.std_info_predictors_sdy <- function(model,
model_matrix,
types,
...) {
deviations <- NA_real_
# fitted values
fitted_values <- .safe(stats::fitted(model))
if (!is.null(fitted_values)) {
deviations <- 1 / sum(c(stats::sd(fitted_values), sqrt(pi^2 / 3)))
}
# Out
data.frame(
Parameter = types$Parameter[seq_along(names(model_matrix))],
Deviation_SDy = deviations,
stringsAsFactors = FALSE
)
}
# Response ------------------------------------------------------------
#' @keywords internal
.std_info_response_smart <- function(model, info, data, model_matrix, types, robust = FALSE, w = NULL, ...) {
if (info$is_linear) {
if (inherits(model, c("gls", "lme"))) {
response <- insight::get_response(model)
} else {
response <- stats::model.frame(model)[[1]]
}
means <- deviations <- rep(NA_real_, length = length(names(model_matrix)))
for (i in seq_along(names(model_matrix))) {
variable <- names(model_matrix)[i]
if (any(types$Parameter == variable) && types$Link[types$Parameter == variable] == "Difference") {
parent_var <- types$Variable[types$Parameter == variable]
intercept <- unique(data[[parent_var]])[1]
response_at_intercept <- response[data[[parent_var]] == intercept]
weights_at_intercept <- if (length(w)) w[data[[parent_var]] == intercept] else NULL
std_info <- .compute_std_info(
response = response_at_intercept,
robust = robust, weights = weights_at_intercept
)
} else {
std_info <- .compute_std_info(
response = response,
robust = robust, weights = w
)
}
deviations[i] <- std_info$sd
means[i] <- std_info$mean
}
} else {
deviations <- 1
means <- 0
}
# Out
data.frame(
Parameter = types$Parameter[seq_along(names(model_matrix))],
Deviation_Response_Smart = deviations,
Mean_Response_Smart = means,
stringsAsFactors = FALSE
)
}
#' @keywords internal
.std_info_response_basic <- function(model, info, params, robust = FALSE, w = NULL, ...) {
if (inherits(model, c("gls", "lme"))) {
response <- insight::get_response(model)
} else {
response <- stats::model.frame(model)[[1]]
}
if (info$is_linear) {
if (robust) {
sd_y <- datawizard::weighted_mad(response, w)
mean_y <- datawizard::weighted_median(response, w)
} else {
sd_y <- datawizard::weighted_sd(response, w)
mean_y <- datawizard::weighted_mean(response, w)
}
} else {
sd_y <- 1
mean_y <- 0
}
# Out
data.frame(
Parameter = params,
Deviation_Response_Basic = sd_y,
Mean_Response_Basic = mean_y,
stringsAsFactors = FALSE
)
}
# Pseudo (GLMM) -----------------------------------------------------------
.std_info_pseudo <- function(model,
mi,
params,
model_matrix,
data,
types,
robust = FALSE,
two_sd = FALSE,
verbose = verbose,
...) {
if (robust && verbose) {
insight::format_alert("`robust` standardization not available for `pseudo` method.")
}
insight::check_if_installed("performance")
insight::check_if_installed("datawizard", minimum_version = "0.12.0")
f <- if (two_sd) 2 else 1
within_vars <- unclass(performance::check_heterogeneity_bias(model))
id <- insight::get_random(model)[[1]]
w <- insight::get_weights(model, remove_na = TRUE)
## Find which parameters vary on level 1 ("within")
is_within <- logical(length = length(params))
is_within[] <- NA
for (i in seq_along(params)) {
if (types[i] == "intercept") { # nolint
is_within[i] <- FALSE
} else if (types[i] == "numeric") {
is_within[i] <- insight::clean_names(params[i]) %in% within_vars
} else if (types[i] == "factor") {
is_within[i] <- any(sapply(paste0("^", within_vars), grepl, insight::clean_names(params[i])))
} else if (types[i] == "interaction") {
ints <- unlist(strsplit(params[i], ":", fixed = TRUE))
is_within[i] <- any(sapply(ints, function(int) {
int <- insight::clean_names(int)
int %in% within_vars | # numeric
any(sapply(paste0("^", within_vars), grepl, int)) # factor
}))
}
}
## test "within"s are fully "within"
# only relevant to numeric predictors that can have variance
check_within <- is_within & types == "numeric"
if (any(check_within)) {
p_check_within <- params[check_within]
temp_d <- data.frame(model_matrix[, p_check_within, drop = FALSE])
colnames(temp_d) <- paste0("W", seq_len(ncol(temp_d))) # overwrite because can't deal with ":"
dm <- datawizard::demean(cbind(id, temp_d),
select = colnames(temp_d),
by = "id"
)
dm <- dm[, paste0(colnames(temp_d), "_between"), drop = FALSE]
has_lvl2_var <- sapply(seq_along(colnames(temp_d)), function(i) {
# If more than 1% of the variance in the within-var is between:
stats::var(dm[, i]) / stats::var(temp_d[, i])
}) > 0.01
also_between <- p_check_within[has_lvl2_var]
if (length(also_between) && verbose) {
insight::format_alert(
"The following within-group terms have between-group variance:",
toString(also_between),
"This can inflate standardized within-group parameters associated with these terms.",
"See `help(\"demean\", package = \"datawizard\")` for modeling between- and within-subject effects."
)
}
}
## Get 2 types of Deviation_Response_Pseudo
sd_y_within <- sd_y_between <- 1
if (mi$is_linear) {
insight::check_if_installed("lme4")
rand_name <- insight::find_random(model)$random
# maintain any y-transformations
frm <- insight::find_formula(model)
frm <- paste0(frm$conditional[2], " ~ (1|", rand_name, ")")
m0 <- suppressWarnings(suppressMessages(
lme4::lmer(stats::as.formula(frm),
weights = w,
data = data
)
))
m0v <- insight::get_variance(m0)
sd_y_between <- unname(sqrt(m0v$var.intercept))
sd_y_within <- unname(sqrt(m0v$var.residual))
}
## Get scaling factors for each parameter
Deviation_Response_Pseudo <- Deviation_Pseudo <- numeric(ncol(model_matrix))
for (i in seq_along(params)) {
if (types[i] == "intercept") {
Deviation_Response_Pseudo[i] <- sd_y_between # doesn't matter
Deviation_Pseudo[i] <- 0
} else {
## dumb way
if (is_within[i]) {
## is within
X <- model_matrix[[i]]
Deviation_Response_Pseudo[i] <- sd_y_within
} else {
## is between
X <- tapply(model_matrix[[i]], id, mean)
Deviation_Response_Pseudo[i] <- sd_y_between
}
Deviation_Pseudo[i] <- f * datawizard::weighted_sd(X, w)
## smart way?
## DONT USE: see correspondence with between Mattan and Eran BC
# m <- suppressWarnings(suppressMessages(lme4::lmer(model_matrix[[i]] ~ (1|id))))
# if (is_within[i]) {
# ## is within
# Deviation_Pseudo[i] <- sqrt(unname(unlist(suppressWarnings(
# insight::get_variance(m, component = "residual")
# ))))
# Deviation_Response_Pseudo[i] <- sd_y_within
# } else {
# ## is between
# Deviation_Pseudo[i] <- sqrt(unname(unlist(suppressWarnings(
# insight::get_variance(m, component = "intercept")
# ))))
# Deviation_Response_Pseudo[i] <- sd_y_between
# }
}
}
data.frame(
Parameter = params,
Deviation_Response_Pseudo,
Deviation_Pseudo,
stringsAsFactors = FALSE
)
}
# Utils -------------------------------------------------------------------
#' @keywords internal
.compute_std_info <- function(data = NULL,
variable = NULL,
response = NULL,
robust = FALSE,
two_sd = FALSE,
weights = NULL) {
f <- if (two_sd) 2 else 1
if (is.null(response)) {
response <- as.numeric(data[, variable])
}
if (robust) {
sd_x <- datawizard::weighted_mad(response, weights)
mean_x <- datawizard::weighted_median(response, weights)
} else {
sd_x <- datawizard::weighted_sd(response, weights)
mean_x <- datawizard::weighted_mean(response, weights)
}
list(sd = f * sd_x, mean = mean_x)
}
parameters/R/methods_mass.R 0000644 0001762 0000144 00000006126 14736731407 015450 0 ustar ligges users # ci -----------------
#' @export
ci.negbin <- ci.glm
#' @export
ci.polr <- function(x, ci = 0.95, dof = NULL, method = "profile", ...) {
method <- match.arg(method, choices = c("profile", "wald", "robust"))
robust <- !is.null(method) && method == "robust"
if (.check_vcov_args(robust, ...)) {
return(ci.default(x, ...))
}
if (method == "profile") {
out <- lapply(ci, function(i) .ci_profiled2(model = x, ci = i))
out <- do.call(rbind, out)
} else {
out <- .ci_generic(model = x, ci = ci, dof = dof, method = method, ...)
}
# for polr, profiled CI do not return CI for response levels
# thus, we also calculate Wald CI and add missing rows to result
out_missing <- .ci_generic(model = x, ci = ci)
missing_rows <- out_missing$Parameter %in% setdiff(out_missing$Parameter, out$Parameter)
out <- rbind(out, out_missing[missing_rows, ])
# fix names, to match standard error and p_value
out$Parameter <- gsub("Intercept: ", "", out$Parameter, fixed = TRUE)
row.names(out) <- NULL
out
}
# SE -----------------
#' @export
standard_error.polr <- function(model, method = NULL, ...) {
robust <- !is.null(method) && method == "robust"
if (.check_vcov_args(robust, ...)) {
return(standard_error.default(model, ...))
}
smry <- suppressMessages(as.data.frame(stats::coef(summary(model))))
se <- smry[[2]]
names(se) <- rownames(smry)
.data_frame(
Parameter = .remove_backticks_from_string(names(se)),
SE = as.vector(se)
)
}
# p -----------------
#' @export
p_value.negbin <- p_value.default
#' @export
p_value.rlm <- function(model, ...) {
cs <- stats::coef(summary(model))
p <- 2 * stats::pt(abs(cs[, 3]), df = insight::get_df(model, type = "wald"), lower.tail = FALSE)
.data_frame(
Parameter = .remove_backticks_from_string(names(p)),
p = as.vector(p)
)
}
#' @export
p_value.polr <- function(model, method = NULL, ...) {
robust <- !is.null(method) && method == "robust"
if (.check_vcov_args(robust, ...)) {
return(p_value.default(model, ...))
}
smry <- suppressMessages(as.data.frame(stats::coef(summary(model))))
tstat <- smry[[3]]
p <- 2 * stats::pt(abs(tstat), df = insight::get_df(x = model, type = "wald"), lower.tail = FALSE)
names(p) <- rownames(smry)
.data_frame(
Parameter = .remove_backticks_from_string(names(p)),
p = as.vector(p)
)
}
# parameters -----------------
#' @export
model_parameters.ridgelm <- function(model, verbose = TRUE, ...) {
parameters <- insight::get_parameters(model)
parameters$Scale <- as.vector(model$scales)
# remove all complete-missing cases
parameters <- parameters[apply(parameters, 1, function(i) !all(is.na(i))), ]
rownames(parameters) <- NULL
class(parameters) <- c("parameters_model", "see_parameters_model", class(parameters))
attr(parameters, "object_name") <- insight::safe_deparse_symbol(substitute(model))
parameters
}
#' @export
model_parameters.polr <- model_parameters.glm
#' @export
model_parameters.negbin <- model_parameters.glm
parameters/R/4_standard_error.R 0000644 0001762 0000144 00000017521 14736731407 016217 0 ustar ligges users #' @title Standard Errors
#' @name standard_error
#'
#' @description `standard_error()` attempts to return standard errors of model
#' parameters.
#'
#' @param model A model.
#' @param force Logical, if `TRUE`, factors are converted to numerical
#' values to calculate the standard error, with the lowest level being the
#' value `1` (unless the factor has numeric levels, which are converted
#' to the corresponding numeric value). By default, `NA` is returned for
#' factors or character vectors.
#' @param vcov Variance-covariance matrix used to compute uncertainty estimates
#' (e.g., for robust standard errors). This argument accepts a covariance
#' matrix, a function which returns a covariance matrix, or a string which
#' identifies the function to be used to compute the covariance matrix.
#' * A covariance matrix
#' * A function which returns a covariance matrix (e.g., `stats::vcov()`)
#' * A string which indicates the kind of uncertainty estimates to return.
#' - Heteroskedasticity-consistent: `"HC"`, `"HC0"`, `"HC1"`, `"HC2"`,
#' `"HC3"`, `"HC4"`, `"HC4m"`, `"HC5"`. See `?sandwich::vcovHC`
#' - Cluster-robust: `"CR"`, `"CR0"`, `"CR1"`, `"CR1p"`, `"CR1S"`,
#' `"CR2"`, `"CR3"`. See `?clubSandwich::vcovCR`
#' - Bootstrap: `"BS"`, `"xy"`, `"residual"`, `"wild"`, `"mammen"`,
#' `"fractional"`, `"jackknife"`, `"norm"`, `"webb"`. See
#' `?sandwich::vcovBS`
#' - Other `sandwich` package functions: `"HAC"`, `"PC"`, `"CL"`, `"OPG"`,
#' `"PL"`.
#' @param vcov_args List of arguments to be passed to the function identified by
#' the `vcov` argument. This function is typically supplied by the
#' **sandwich** or **clubSandwich** packages. Please refer to their
#' documentation (e.g., `?sandwich::vcovHAC`) to see the list of available
#' arguments. If no estimation type (argument `type`) is given, the default
#' type for `"HC"` equals the default from the **sandwich** package; for type
#' `"CR"`, the default is set to `"CR3"`.
#' @param effects Should standard errors for fixed effects (`"fixed"`), random
#' effects (`"random"`), or both (`"all"`) be returned? Only applies
#' to mixed models. May be abbreviated. When standard errors for random
#' effects are requested, for each grouping factor a list of standard errors
#' (per group level) for random intercepts and slopes is returned.
#' @param component Model component for which standard errors should be shown.
#' See the documentation for your object's class in [`model_parameters()`] or
#' [`p_value()`] for further details.
#' @inheritParams simulate_model
#' @inheritParams p_value
#' @param ... Arguments passed to or from other methods.
#'
#' @note For Bayesian models (from **rstanarm** or **brms**), the standard
#' error is the SD of the posterior samples.
#'
#' @return A data frame with at least two columns: the parameter names and the
#' standard errors. Depending on the model, may also include columns for model
#' components etc.
#'
#' @examplesIf require("sandwich") && require("clubSandwich")
#' model <- lm(Petal.Length ~ Sepal.Length * Species, data = iris)
#' standard_error(model)
#'
#' # robust standard errors
#' standard_error(model, vcov = "HC3")
#'
#' # cluster-robust standard errors
#' standard_error(model,
#' vcov = "vcovCL",
#' vcov_args = list(cluster = iris$Species)
#' )
#' @export
standard_error <- function(model, ...) {
UseMethod("standard_error")
}
# Default methods ---------------------------------------------------------
#' @rdname standard_error
#' @export
standard_error.default <- function(model,
effects = "fixed",
component = "all",
vcov = NULL,
vcov_args = NULL,
verbose = TRUE,
...) {
# check for valid input
.is_model_valid(model)
dots <- list(...)
se <- NULL
# if a vcov is provided, we calculate standard errors based on that matrix
# this is usually the case for HC (robust) standard errors
# ------------------------------------------------------------------------
# vcov: matrix
if (is.matrix(vcov)) {
se <- sqrt(diag(vcov))
}
# vcov: function which returns a matrix
if (is.function(vcov)) {
fun_args <- c(list(model), vcov_args, dots)
se <- .safe(sqrt(diag(do.call("vcov", fun_args))))
}
# vcov: character
if (is.character(vcov)) {
.vcov <- insight::get_varcov(
model,
component = component,
vcov = vcov,
vcov_args = vcov_args,
verbose = verbose,
...
)
se <- sqrt(diag(.vcov))
}
# classical SE from summary()
# ------------------------------------------------------------------------
if (is.null(se)) {
se <- .safe({
if (grepl("Zelig-", class(model)[1], fixed = TRUE)) {
unlist(model$get_se())
} else {
.get_se_from_summary(model)
}
})
}
# if retrieving SE from summary() failed, we try to calculate SE based
# on classical se from get_varcov()
# ------------------------------------------------------------------------
if (is.null(se)) {
se <- .safe({
varcov <- insight::get_varcov(model, component = component)
se_from_varcov <- sqrt(diag(varcov))
names(se_from_varcov) <- colnames(varcov)
se_from_varcov
})
}
# output
if (is.null(se)) {
if (isTRUE(verbose)) {
insight::format_warning("Could not extract standard errors from model object.")
}
} else {
params <- insight::get_parameters(model, component = component)
if (length(se) == nrow(params) && "Component" %in% colnames(params)) {
se <- .data_frame(Parameter = params$Parameter, SE = as.vector(se), Component = params$Component)
} else {
se <- .data_frame(Parameter = names(se), SE = as.vector(se))
}
}
se
}
# helper -----------------------------------------------------------------
.get_se_from_summary <- function(model, component = NULL) {
cs <- .safe(suppressWarnings(stats::coef(summary(model))))
se <- NULL
if (is.list(cs) && !is.null(component)) {
cs <- cs[[component]]
}
if (!is.null(cs)) {
# do we have a se column?
se_col <- which(colnames(cs) == "Std. Error")
# if not, default to 2
if (length(se_col) == 0) {
se_col <- 2
}
se <- as.vector(cs[, se_col])
if (is.null(names(se))) {
coef_names <- rownames(cs)
if (length(coef_names) == length(se)) {
names(se) <- coef_names
}
}
}
names(se) <- .remove_backticks_from_string(names(se))
se
}
.check_vcov_args <- function(robust, ...) {
dots <- list(...)
isTRUE(isTRUE(robust) || isTRUE(dots$robust) || ("vcov" %in% names(dots) && !is.null(dots[["vcov"]])))
}
# .ranef_se <- function(x) {
# insight::check_if_installed("lme4")
#
# cc <- stats::coef(model)
#
# # get names of intercepts
# inames <- names(cc)
#
# # variances of fixed effects
# fixed.vars <- diag(as.matrix(stats::vcov(model)))
#
# # extract variances of conditional modes
# r1 <- lme4::ranef(model, condVar = TRUE)
#
# # we may have multiple random intercepts, iterate all
# se.merMod <- lapply(1:length(cc), function(i) {
# cmode.vars <- t(apply(attr(r1[[i]], "postVar"), 3, diag))
# seVals <- sqrt(sweep(cmode.vars, 2, fixed.vars[names(r1[[i]])], "+", check.margin = FALSE))
#
# if (length(r1[[i]]) == 1) {
# seVals <- as.data.frame(t(seVals))
# stats::setNames(seVals, names(r1[[i]]))
# } else {
# seVals <- seVals[, 1:2]
# stats::setNames(as.data.frame(seVals), names(r1[[i]]))
# }
# })
#
# # set names of list
# names(se.merMod) <- inames
#
# se.merMod
# }
parameters/R/parameters-package.R 0000644 0001762 0000144 00000002447 14413011732 016500 0 ustar ligges users #' @title parameters: Extracting, Computing and Exploring the Parameters of Statistical Models using R
#'
#' @description
#'
#' **parameters**' primary goal is to provide utilities for processing the
#' parameters of various statistical models (see [here](https://easystats.github.io/insight/)
#' for a list of supported models). Beyond computing *p-values*, *CIs*,
#' *Bayesian indices* and other measures for a wide variety of models, this
#' package implements features like *bootstrapping* of parameters and models,
#' *feature reduction* (feature extraction and variable selection), or tools for
#' data reduction like functions to perform cluster, factor or principal
#' component analysis.
#'
#' Another important goal of the **parameters** package is to facilitate and
#' streamline the process of reporting results of statistical models, which
#' includes the easy and intuitive calculation of standardized estimates or
#' robust standard errors and p-values. **parameters** therefor offers a
#' simple and unified syntax to process a large variety of (model) objects
#' from many different packages.
#'
#' References: Lüdecke et al. (2020) \doi{10.21105/joss.02445}
#'
#' @docType package
#' @aliases parameters-package
#' @name parameters-package
#' @keywords internal
"_PACKAGE"
parameters/R/methods_mhurdle.R 0000644 0001762 0000144 00000005727 14736731407 016153 0 ustar ligges users #' @export
model_parameters.mhurdle <- function(model,
ci = 0.95,
component = "all",
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated", "infrequent_purchase", "ip", "auxiliary")
)
params <- .model_parameters_generic(
model,
ci = ci,
merge_by = c("Parameter", "Component"),
exponentiate = exponentiate,
effects = "fixed",
component = component,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
params$Parameter <- gsub("^(h1|h2|h3)\\.(.*)", "\\2", params$Parameter)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
params
}
#' @export
p_value.mhurdle <- function(model,
component = c("all", "conditional", "zi", "zero_inflated", "infrequent_purchase", "ip", "auxiliary"),
...) {
component <- match.arg(component)
s <- summary(model)
params <- insight::get_parameters(model, component = "all")
pvals <- data.frame(
Parameter = rownames(s$coefficients),
p = as.vector(s$coefficients[, 4]),
stringsAsFactors = FALSE
)
params <- merge(params, pvals, sort = FALSE)
if (component != "all") {
params <- params[params$Component == component, , drop = FALSE]
}
params[c("Parameter", "p", "Component")]
}
#' @export
ci.mhurdle <- function(x, ci = 0.95, ...) {
.ci_generic(model = x, ci = ci, ...)
}
#' @export
standard_error.mhurdle <- function(model, component = c("all", "conditional", "zi", "zero_inflated", "infrequent_purchase", "ip", "auxiliary"), ...) {
component <- match.arg(component)
s <- summary(model)
params <- insight::get_parameters(model, component = "all")
se <- data.frame(
Parameter = rownames(s$coefficients),
SE = as.vector(s$coefficients[, 2]),
stringsAsFactors = FALSE
)
params <- merge(params, se, sort = FALSE)
if (component != "all") {
params <- params[params$Component == component, , drop = FALSE]
}
params[c("Parameter", "SE", "Component")]
}
#' @export
simulate_model.mhurdle <- function(model, iterations = 1000, component = c("all", "conditional", "zi", "zero_inflated", "infrequent_purchase", "ip", "auxiliary"), ...) {
component <- match.arg(component)
out <- .simulate_model(model, iterations, component = component, effects = "fixed", ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
parameters/R/standardize_parameters.R 0000644 0001762 0000144 00000067177 14736731407 017532 0 ustar ligges users #' Parameters standardization
#'
#' Compute standardized model parameters (coefficients).
#'
#' @param model A statistical model.
#' @param method The method used for standardizing the parameters. Can be
#' `"refit"` (default), `"posthoc"`, `"smart"`, `"basic"`, `"pseudo"` or
#' `"sdy"`. See Details'.
#' @param include_response If `TRUE` (default), the response value will also be
#' standardized. If `FALSE`, only the predictors will be standardized. For
#' GLMs the response value will never be standardized (see *Generalized Linear
#' Models* section).
#' @inheritParams datawizard::standardize.default
#' @inheritParams effectsize::chisq_to_phi
#' @param ... For `standardize_parameters()`, arguments passed to
#' [`model_parameters()`], such as:
#' - `ci_method`, `centrality` for Mixed models and Bayesian models...
#' - `exponentiate`, ...
#' - etc.
#'
#' @details
#'
#' ## Standardization Methods
#' - **refit**: This method is based on a complete model re-fit with a
#' standardized version of the data. Hence, this method is equal to
#' standardizing the variables before fitting the model. It is the "purest" and
#' the most accurate (Neter et al., 1989), but it is also the most
#' computationally costly and long (especially for heavy models such as Bayesian
#' models). This method is particularly recommended for complex models that
#' include interactions or transformations (e.g., polynomial or spline terms).
#' The `robust` (default to `FALSE`) argument enables a robust standardization
#' of data, i.e., based on the `median` and `MAD` instead of the `mean` and
#' `SD`. **See [`datawizard::standardize()`] for more details.**
#' - **Note** that `standardize_parameters(method = "refit")` may not return
#' the same results as fitting a model on data that has been standardized with
#' `standardize()`; `standardize_parameters()` used the data used by the model
#' fitting function, which might not be same data if there are missing values.
#' see the `remove_na` argument in `standardize()`.
#' - **posthoc**: Post-hoc standardization of the parameters, aiming at
#' emulating the results obtained by "refit" without refitting the model. The
#' coefficients are divided by the standard deviation (or MAD if `robust`) of
#' the outcome (which becomes their expression 'unit'). Then, the coefficients
#' related to numeric variables are additionally multiplied by the standard
#' deviation (or MAD if `robust`) of the related terms, so that they correspond
#' to changes of 1 SD of the predictor (e.g., "A change in 1 SD of `x` is
#' related to a change of 0.24 of the SD of `y`). This does not apply to binary
#' variables or factors, so the coefficients are still related to changes in
#' levels. This method is not accurate and tend to give aberrant results when
#' interactions are specified.
#' - **basic**: This method is similar to `method = "posthoc"`, but treats all
#' variables as continuous: it also scales the coefficient by the standard
#' deviation of model's matrix' parameter of factors levels (transformed to
#' integers) or binary predictors. Although being inappropriate for these cases,
#' this method is the one implemented by default in other software packages,
#' such as [`lm.beta::lm.beta()`].
#' - **smart** (Standardization of Model's parameters with Adjustment,
#' Reconnaissance and Transformation - *experimental*): Similar to `method =
#' "posthoc"` in that it does not involve model refitting. The difference is
#' that the SD (or MAD if `robust`) of the response is computed on the relevant
#' section of the data. For instance, if a factor with 3 levels A (the
#' intercept), B and C is entered as a predictor, the effect corresponding to B
#' vs. A will be scaled by the variance of the response at the intercept only.
#' As a results, the coefficients for effects of factors are similar to a Glass'
#' delta.
#' - **pseudo** (*for 2-level (G)LMMs only*): In this (post-hoc) method, the
#' response and the predictor are standardized based on the level of prediction
#' (levels are detected with [`performance::check_heterogeneity_bias()`]): Predictors
#' are standardized based on their SD at level of prediction (see also
#' [`datawizard::demean()`]); The outcome (in linear LMMs) is standardized based
#' on a fitted random-intercept-model, where `sqrt(random-intercept-variance)`
#' is used for level 2 predictors, and `sqrt(residual-variance)` is used for
#' level 1 predictors (Hoffman 2015, page 342). A warning is given when a
#' within-group variable is found to have access between-group variance.
#' - **sdy** (*for logistic regression models only*): This y-standardization
#' is useful when comparing coefficients of logistic regression models across
#' models for the same sample. Unobserved heterogeneity varies across models
#' with different independent variables, and thus, odds ratios from the same
#' predictor of different models cannot be compared directly. The
#' y-standardization makes coefficients "comparable across models by dividing
#' them with the estimated standard deviation of the latent variable for each
#' model" (Mood 2010). Thus, whenever one has multiple logistic regression models
#' that are fit to the same data and share certain predictors (e.g. nested
#' models), it can be useful to use this standardization approach to make
#' log-odds or odds ratios comparable.
#'
#' ## Transformed Variables
#' When the model's formula contains transformations (e.g. `y ~ exp(X)`) `method
#' = "refit"` will give different results compared to `method = "basic"`
#' (`"posthoc"` and `"smart"` do not support such transformations): While
#' `"refit"` standardizes the data *prior* to the transformation (e.g.
#' equivalent to `exp(scale(X))`), the `"basic"` method standardizes the
#' transformed data (e.g. equivalent to `scale(exp(X))`).
#' \cr\cr
#' See the *Transformed Variables* section in [`datawizard::standardize.default()`]
#' for more details on how different transformations are dealt with when
#' `method = "refit"`.
#'
#' ## Confidence Intervals
#' The returned confidence intervals are re-scaled versions of the
#' unstandardized confidence intervals, and not "true" confidence intervals of
#' the standardized coefficients (cf. Jones & Waller, 2015).
#'
#' ## Generalized Linear Models
#' Standardization for generalized linear models (GLM, GLMM, etc) is done only
#' with respect to the predictors (while the outcome remains as-is,
#' unstandardized) - maintaining the interpretability of the coefficients (e.g.,
#' in a binomial model: the exponent of the standardized parameter is the OR of
#' a change of 1 SD in the predictor, etc.)
#'
#' ## Dealing with Factors
#' `standardize(model)` or `standardize_parameters(model, method = "refit")` do
#' *not* standardize categorical predictors (i.e. factors) / their
#' dummy-variables, which may be a different behaviour compared to other R
#' packages (such as \pkg{lm.beta}) or other software packages (like SPSS). To
#' mimic such behaviours, either use `standardize_parameters(model, method =
#' "basic")` to obtain post-hoc standardized parameters, or standardize the data
#' with `datawizard::standardize(data, force = TRUE)` *before* fitting the
#' model.
#'
#' @return A data frame with the standardized parameters (`Std_*`, depending on
#' the model type) and their CIs (`CI_low` and `CI_high`). Where applicable,
#' standard errors (SEs) are returned as an attribute (`attr(x,
#' "standard_error")`).
#'
#' @family standardize
#' @family effect size indices
#'
#' @seealso See also [package vignette](https://easystats.github.io/parameters/articles/standardize_parameters_effsize.html).
#'
#' @examples
#' model <- lm(len ~ supp * dose, data = ToothGrowth)
#' standardize_parameters(model, method = "refit")
#' \donttest{
#' standardize_parameters(model, method = "posthoc")
#' standardize_parameters(model, method = "smart")
#' standardize_parameters(model, method = "basic")
#'
#' # Robust and 2 SD
#' standardize_parameters(model, robust = TRUE)
#' standardize_parameters(model, two_sd = TRUE)
#'
#' model <- glm(am ~ cyl * mpg, data = mtcars, family = "binomial")
#' standardize_parameters(model, method = "refit")
#' standardize_parameters(model, method = "posthoc")
#' standardize_parameters(model, method = "basic", exponentiate = TRUE)
#' }
#'
#' @examplesIf require("lme4", quietly = TRUE)
#' \donttest{
#' m <- lme4::lmer(mpg ~ cyl + am + vs + (1 | cyl), mtcars)
#' standardize_parameters(m, method = "pseudo", ci_method = "satterthwaite")
#' }
#'
#' @examplesIf require("rstanarm", quietly = TRUE)
#' \donttest{
#' model <- rstanarm::stan_glm(rating ~ critical + privileges, data = attitude, refresh = 0)
#' standardize_posteriors(model, method = "refit", verbose = FALSE)
#' standardize_posteriors(model, method = "posthoc", verbose = FALSE)
#' standardize_posteriors(model, method = "smart", verbose = FALSE)
#' head(standardize_posteriors(model, method = "basic", verbose = FALSE))
#' }
#'
#' @references
#' - Hoffman, L. (2015). Longitudinal analysis: Modeling within-person fluctuation
#' and change. Routledge.
#'
#' - Jones, J. A., & Waller, N. G. (2015). The normal-theory and asymptotic
#' distribution-free (ADF) covariance matrix of standardized regression
#' coefficients: theoretical extensions and finite sample behavior.
#' Psychometrika, 80(2), 365-378.
#'
#' - Neter, J., Wasserman, W., & Kutner, M. H. (1989). Applied linear
#' regression models.
#'
#' - Gelman, A. (2008). Scaling regression inputs by dividing by two standard
#' deviations. Statistics in medicine, 27(15), 2865-2873.
#'
#' - Mood C. Logistic Regression: Why We Cannot Do What We Think We Can Do, and
#' What We Can Do About It. European Sociological Review (2010) 26:67–82.
#'
#' @export
#' @aliases standardise_parameters
standardize_parameters <- function(model,
method = "refit",
ci = 0.95,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
UseMethod("standardize_parameters")
}
#' @export
standardise_parameters <- standardize_parameters
#' @export
standardize_parameters.default <- function(model,
method = "refit",
ci = 0.95,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
# check for valid input
.is_model_valid(model)
object_name <- insight::safe_deparse_symbol(substitute(model))
method <- match.arg(method, c("refit", "posthoc", "smart", "basic", "classic", "pseudo", "sdy"))
m_info <- .get_model_info(model, ...)
include_response <- include_response && .safe_to_standardize_response(m_info, verbose = verbose)
if (method == "refit") {
model <- datawizard::standardize(model,
robust = robust, two_sd = two_sd,
include_response = include_response,
verbose = verbose, m_info = m_info
)
}
# need model_parameters to return the parameters, not the terms
if (inherits(model, "aov")) {
class(model) <- class(model)[class(model) != "aov"]
}
pars <- model_parameters(model, ci = ci, standardize = NULL, effects = "fixed", as_draws = TRUE, ...)
# save attributes for later, these are lost in between
att <- attributes(pars)
# should post hoc exponentiate?
exponentiate <- isTRUE(eval(match.call()[["exponentiate"]], envir = parent.frame()))
coefficient_name <- attr(pars, "coefficient_name")
if (method %in% c("posthoc", "smart", "basic", "classic", "pseudo", "sdy")) {
if (m_info$is_multivariate) {
insight::format_error(
"Cannot post-hoc standardize multivariate models. Try using method \"refit\" instead."
)
}
if (method == "sdy" && !m_info$is_binomial) {
insight::format_error("Method \"sdy\" is only applicable to logistic regression models.")
}
pars <- .standardize_parameters_posthoc(
pars, method, model, m_info, robust, two_sd, exponentiate,
include_response, verbose
)
method <- attr(pars, "std_method")
robust <- attr(pars, "robust")
}
## clean cols
if (!is.null(ci)) pars$CI <- attr(pars, "ci")
colnm <- c("Component", "Response", "Group", "Parameter", utils::head(.col_2_scale, -2), "CI", "CI_low", "CI_high")
pars <- pars[, colnm[colnm %in% colnames(pars)]]
if (!is.null(coefficient_name) && coefficient_name %in% c("Odds Ratio", "Risk Ratio", "IRR", "Prevalence Ratio")) {
colnames(pars)[colnames(pars) == "Coefficient"] <- gsub(" ", "_", coefficient_name, fixed = TRUE)
}
i <- colnames(pars) %in% c("Coefficient", "Median", "Mean", "MAP", "Odds_Ratio", "Risk_Ratio", "IRR", "Prevalence_Ratio")
colnames(pars)[i] <- paste0("Std_", colnames(pars)[i])
## SE attribute?
if ("SE" %in% colnames(pars)) {
attr(pars, "standard_error") <- pars$SE
pars$SE <- NULL
}
# add those attributes back here...
if (!is.null(att)) {
attributes(pars) <- utils::modifyList(att, attributes(pars))
}
## attributes
attr(pars, "std_method") <- method
attr(pars, "two_sd") <- two_sd
attr(pars, "robust") <- robust
attr(pars, "object_name") <- object_name
attr(pars, "ci") <- ci
attr(pars, "include_response") <- include_response
class(pars) <- c("parameters_standardized", "effectsize_table", "see_effectsize_table", "data.frame")
pars
}
#' @export
standardize_parameters.mediate <- function(model,
method = "refit",
ci = 0.95,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
if (method != "refit") {
insight::format_warning("Only `method=\"refit\"` is supported for mediation models.")
}
NextMethod("standardize_parameters",
method = "refit", ci = ci, robust = robust,
two_sd = two_sd, include_response = include_response, verbose = verbose
)
}
#' @export
standardize_parameters.parameters_model <- function(model,
method = "refit",
ci = NULL,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
if (method == "refit") {
insight::format_error(
"Argument `refit` not supported for standardizing results from `model_parameters()`."
)
}
if (!is.null(ci)) {
insight::format_alert(
"Argument `ci` not supported for standardizing results from `model_parameters()`. It is ignored."
)
}
pars <- model
ci <- attr(pars, "ci")
model <- .get_object(pars)
if (is.null(model)) model <- attr(pars, "object")
m_info <- .get_model_info(model, ...)
include_response <- include_response && .safe_to_standardize_response(m_info, verbose = verbose)
exponentiate <- attr(pars, "exponentiate")
if (is.null(exponentiate)) {
exponentiate <- FALSE
}
pars <- .standardize_parameters_posthoc(
pars, method, model, m_info, robust, two_sd, exponentiate, include_response, verbose
)
method <- attr(pars, "std_method")
robust <- attr(pars, "robust")
## clean cols
if (!is.null(ci)) pars$CI <- attr(pars, "ci")
colnm <- c("Component", "Response", "Group", "Parameter", utils::head(.col_2_scale, -2), "CI", "CI_low", "CI_high")
pars <- pars[, colnm[colnm %in% colnames(pars)]]
i <- colnames(pars) %in% c("Coefficient", "Median", "Mean", "MAP")
colnames(pars)[i] <- paste0("Std_", colnames(pars)[i])
## SE attribute?
if ("SE" %in% colnames(pars)) {
attr(pars, "standard_error") <- pars$SE
pars$SE <- NULL
}
## attributes
attr(pars, "std_method") <- method
attr(pars, "two_sd") <- two_sd
attr(pars, "robust") <- robust
attr(pars, "ci") <- ci
attr(pars, "include_response") <- include_response
class(pars) <- c("parameters_standardized", "effectsize_table", "see_effectsize_table", "data.frame")
pars
}
#' @export
standardize_parameters.bootstrap_model <- function(model,
method = "refit",
ci = 0.95,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
object_name <- insight::safe_deparse_symbol(substitute(model))
method <- match.arg(method, c("refit", "posthoc", "smart", "basic", "classic", "pseudo", "sdy"))
pars <- model
model <- attr(pars, "original_model")
m_info <- .get_model_info(model, ...)
include_response <- include_response && .safe_to_standardize_response(m_info, verbose = verbose)
if (method == "refit") {
insight::format_error("The `refit` method is not supported for bootstrapped models.")
## But it would look something like this:
# model <- standardize(model, robust = robust, two_sd = two_sd, verbose = verbose, m_info = m_info)
# model <- parameters::bootstrap_model(model, iterations = 1000, verbose = verbose)
# return(model)
}
# need model_parameters to return the parameters, not the terms
if (inherits(model, "aov")) class(model) <- class(model)[class(model) != "aov"]
if (method %in% c("posthoc", "smart", "basic", "classic", "pseudo")) {
pars <- .standardize_posteriors_posthoc(pars, method, model, m_info, robust, two_sd, include_response, verbose)
method <- attr(pars, "std_method")
robust <- attr(pars, "robust")
}
pars <- bayestestR::describe_posterior(pars,
centrality = "median",
ci = ci, ci_method = "quantile",
test = NULL
)
names(pars)[names(pars) == "Median"] <- "Std_Coefficient"
attr(pars, "std_method") <- method
attr(pars, "two_sd") <- two_sd
attr(pars, "robust") <- robust
attr(pars, "object_name") <- object_name
attr(pars, "ci") <- ci
attr(pars, "include_response") <- include_response
class(pars) <- c("parameters_standardized", "effectsize_table", "see_effectsize_table", "data.frame")
pars
}
#' @export
standardize_parameters.bootstrap_parameters <- function(model,
method = "refit",
ci = 0.95,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
standardize_parameters(attr(model, "boot_samples"),
method = method,
ci = ci,
robust = robust,
two_sd = two_sd,
include_response = include_response,
verbose = verbose,
...
)
}
#' @export
standardize_parameters.model_fit <- function(model,
method = "refit",
ci = 0.95,
robust = FALSE,
two_sd = FALSE,
include_response = TRUE,
verbose = TRUE,
...) {
standardize_parameters(
model$fit,
method = method,
ci = ci,
robust = robust,
two_sd = two_sd,
include_response = include_response,
verbose = verbose,
...
)
}
# methods --------------------------------
#' @export
format.parameters_standardized <- function(x,
digits = 2,
format = c("text", "markdown", "html"),
...) {
format <- match.arg(format)
footer <- subtitle <- NULL
caption <- sprintf("Standardization method: %s", attr(x, "std_method"))
# robust / two_sd
if (attr(x, "two_sd") || attr(x, "robust")) {
footer <- sprintf(
"Scaled by %s %s%s from the %s.",
ifelse(attr(x, "two_sd"), "two", "one"),
ifelse(attr(x, "robust"), "MAD", "SD"),
ifelse(attr(x, "two_sd"), "s", ""),
ifelse(attr(x, "robust"), "median", "mean")
)
}
# include_response
if (!attr(x, "include_response")) {
footer <- c(footer, "Response is unstandardized.")
}
if (format %in% c("markdown", "text") && !is.null(footer)) {
footer <- lapply(footer, function(ftr) {
c(paste0("\n- ", ftr), "blue")
})
}
attr(x, "table_footer") <- footer
if (format %in% c("markdown", "text") && !is.null(caption)) {
caption <- c(paste0("# ", caption), "blue")
}
attr(x, "table_caption") <- caption
attr(x, "table_subtitle") <- subtitle
attr(x, "ci") <- NULL
attr(x, "ci_method") <- NULL
insight::format_table(x, digits = digits, ci_digits = digits, preserve_attributes = TRUE, ...)
}
#' @export
print.parameters_standardized <- function(x, digits = 2, ...) {
x_fmt <- format(x, digits = digits, output = "text", ...)
cat(insight::export_table(x_fmt, format = NULL, ...))
invisible(x)
}
#' @export
print_md.parameters_standardized <- function(x, digits = 2, ...) {
x_fmt <- format(x, digits = digits, output = "markdown", ...)
insight::export_table(x_fmt, format = "markdown", ...)
}
#' @export
print_html.parameters_standardized <- function(x, digits = 2, ...) {
x_fmt <- format(x, digits = digits, output = "html", ...)
insight::export_table(x_fmt, format = "html", ...)
}
# helper -------------------------
#' @keywords internal
.standardize_parameters_posthoc <- function(pars,
method,
model,
mi,
robust,
two_sd,
exponentiate,
include_response,
verbose) {
# validation check for "pseudo"
method <- .should_pseudo(method, model, mi)
method <- .cant_smart_or_posthoc(method, model, mi, pars$Parameter)
if (robust && method == "pseudo") {
insight::format_alert("`robust` standardization not available for `pseudo` method.")
robust <- FALSE
}
## Get scaling factors
deviations <- standardize_info(
model,
robust = robust,
include_pseudo = method == "pseudo",
two_sd = two_sd,
model_info = mi
)
i_missing <- setdiff(seq_len(nrow(pars)), seq_len(nrow(deviations)))
unstd <- pars
if (length(i_missing)) {
deviations[i_missing, ] <- NA
}
if (method == "basic") { # nolint
col_dev_resp <- "Deviation_Response_Basic"
col_dev_pred <- "Deviation_Basic"
} else if (method == "posthoc") {
col_dev_resp <- "Deviation_Response_Basic"
col_dev_pred <- "Deviation_Smart"
} else if (method == "smart") {
col_dev_resp <- "Deviation_Response_Smart"
col_dev_pred <- "Deviation_Smart"
} else if (method == "pseudo") {
col_dev_resp <- "Deviation_Response_Pseudo"
col_dev_pred <- "Deviation_Pseudo"
} else if (method == "sdy") {
col_dev_resp <- "Deviation_Response_Basic"
col_dev_pred <- "Deviation_SDy"
include_response <- FALSE
} else {
insight::format_error("`method` must be one of \"basic\", \"posthoc\", \"smart\", \"pseudo\" or \"sdy\".")
}
.dev_pred <- deviations[[col_dev_pred]]
.dev_resp <- deviations[[col_dev_resp]]
if (!include_response) .dev_resp <- 1
.dev_factor <- .dev_pred / .dev_resp
# Sapply standardization
pars[, colnames(pars) %in% .col_2_scale] <- lapply(
pars[, colnames(pars) %in% .col_2_scale, drop = FALSE],
function(x) {
if (exponentiate) {
if (method == "sdy") {
exp(x * .dev_factor)
} else {
x^.dev_factor
}
} else {
x * .dev_factor
}
}
)
to_complete <- apply(pars[, colnames(pars) %in% .col_2_scale], 1, anyNA)
if (length(i_missing) || any(to_complete)) {
i_missing <- union(i_missing, which(to_complete))
pars[i_missing, colnames(pars) %in% .col_2_scale] <-
unstd[i_missing, colnames(pars) %in% .col_2_scale]
}
attr(pars, "std_method") <- method
attr(pars, "two_sd") <- two_sd
attr(pars, "robust") <- robust
pars
}
#' @keywords internal
.col_2_scale <- c("Coefficient", "Median", "Mean", "MAP", "SE", "CI_low", "CI_high")
#' @keywords internal
.cant_smart_or_posthoc <- function(method, model, mi, params) {
if (method %in% c("smart", "posthoc")) {
cant_posthocsmart <- FALSE
if (mi$is_linear && colnames(stats::model.frame(model))[1] != insight::find_response(model)) {
can_posthocsmart <- TRUE
}
# factors are allowed
if (!cant_posthocsmart && !all(params == insight::clean_names(params) | grepl("(as.factor|factor)\\(", params))) {
cant_posthocsmart <- TRUE
}
if (cant_posthocsmart) {
insight::format_alert(
"Method `", method, "` does not currently support models with transformed parameters.",
"Reverting to `basic` method. Concider using the `refit` method directly."
)
method <- "basic"
}
}
method
}
#' @keywords internal
.should_pseudo <- function(method, model, mi) {
if (method == "pseudo" && !(mi$is_mixed && length(insight::find_random(model)$random) == 1)) {
insight::format_alert(
"`pseudo` method only available for 2-level (G)LMMs.",
"Setting method to `basic`."
)
method <- "basic"
}
method
}
#' @keywords internal
.safe_to_standardize_response <- function(info, verbose = TRUE) {
if (is.null(info)) {
if (verbose) {
insight::format_warning(
"Unable to verify if response should not be standardized.",
"Response will be standardized."
)
}
return(TRUE)
}
# check if model has a response variable that should not be standardized.
info$is_linear &&
info$family != "inverse.gaussian" &&
!info$is_survival &&
!info$is_censored
# # alternative would be to keep something like:
# !info$is_count &&
# !info$is_ordinal &&
# !info$is_multinomial &&
# !info$is_beta &&
# !info$is_censored &&
# !info$is_binomial &&
# !info$is_survival
# # And then treating response for "Gamma()" or "inverse.gaussian" similar to
# # log-terms...
}
#' @keywords internal
.get_model_info <- function(model, model_info = NULL, ...) {
if (is.null(model_info)) model_info <- insight::model_info(model, verbose = FALSE)
model_info
}
parameters/R/methods_bayestestR.R 0000644 0001762 0000144 00000000072 14037763760 016625 0 ustar ligges users #' @importFrom bayestestR ci
#' @export
bayestestR::ci
parameters/R/methods_selection.R 0000644 0001762 0000144 00000006474 14761570351 016475 0 ustar ligges users #' @export
model_parameters.selection <- function(model,
ci = 0.95,
component = "all",
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("all", "selection", "outcome", "auxiliary")
)
out <- .model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
component = component,
merge_by = c("Parameter", "Component"),
standardize = standardize,
exponentiate = exponentiate,
keep_parameters = keep,
drop_parameters = drop,
include_info = include_info,
p_adjust = p_adjust,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
p_value.selection <- function(model, component = c("all", "selection", "outcome", "auxiliary"), ...) {
component <- match.arg(component)
s <- summary(model)
rn <- row.names(s$estimate)
estimates <- as.data.frame(s$estimate, row.names = FALSE)
params <- data.frame(
Parameter = rn,
p = estimates[[4]],
Component = "auxiliary",
stringsAsFactors = FALSE,
row.names = NULL
)
params$Component[s$param$index$betaS] <- "selection"
params$Component[s$param$index$betaO] <- "outcome"
if (component != "all") {
params <- params[params$Component == component, , drop = FALSE]
}
insight::text_remove_backticks(params, verbose = FALSE)
}
#' @export
standard_error.selection <- function(model, component = c("all", "selection", "outcome", "auxiliary"), ...) {
component <- match.arg(component)
s <- summary(model)
rn <- row.names(s$estimate)
estimates <- as.data.frame(s$estimate, row.names = FALSE)
params <- data.frame(
Parameter = rn,
SE = estimates[[2]],
Component = "auxiliary",
stringsAsFactors = FALSE,
row.names = NULL
)
params$Component[s$param$index$betaS] <- "selection"
params$Component[s$param$index$betaO] <- "outcome"
if (component != "all") {
params <- params[params$Component == component, , drop = FALSE]
}
insight::text_remove_backticks(params, verbose = FALSE)
}
#' @export
simulate_model.selection <- function(model,
iterations = 1000,
component = c("all", "selection", "outcome", "auxiliary"),
...) {
component <- match.arg(component)
out <- .simulate_model(model, iterations, component = component, effects = "fixed", ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
ci.selection <- ci.default
parameters/R/methods_bife.R 0000644 0001762 0000144 00000001577 14717114773 015417 0 ustar ligges users #' @export
standard_error.bife <- function(model, ...) {
cs <- summary(model)
se <- cs$cm[, 2]
.data_frame(
Parameter = .remove_backticks_from_string(rownames(cs$cm)),
SE = as.vector(se)
)
}
#' @export
p_value.bife <- function(model, ...) {
cs <- summary(model)
p <- cs$cm[, 4]
.data_frame(
Parameter = .remove_backticks_from_string(rownames(cs$cm)),
p = as.vector(p)
)
}
#' @export
model_parameters.bifeAPEs <- function(model, ...) {
est <- model[["delta"]]
se <- sqrt(diag(model[["vcov"]]))
z <- est / se
p <- 2 * stats::pnorm(-abs(z))
nms <- names(est)
out <- data.frame(nms, est, se, z, p)
colnames(out) <- c("Parameter", "Coefficient", "Std. error", "z value", "p")
rownames(out) <- NULL
out <- as.data.frame(out)
class(out) <- c("parameters_model", "see_parameters_model", class(out))
out
}
parameters/R/equivalence_test.R 0000644 0001762 0000144 00000101577 14736731407 016330 0 ustar ligges users #' @importFrom bayestestR equivalence_test
#' @export
bayestestR::equivalence_test
#' @title Equivalence test
#'
#' @description Compute the (conditional) equivalence test for frequentist models.
#'
#' @param x A statistical model.
#' @param range The range of practical equivalence of an effect. May be
#' `"default"`, to automatically define this range based on properties of the
#' model's data.
#' @param ci Confidence Interval (CI) level. Default to `0.95` (`95%`).
#' @param rule Character, indicating the rules when testing for practical
#' equivalence. Can be `"bayes"`, `"classic"` or `"cet"`. See 'Details'.
#' @param test Hypothesis test for computing contrasts or pairwise comparisons.
#' See [`?ggeffects::test_predictions`](https://strengejacke.github.io/ggeffects/reference/test_predictions.html)
#' for details.
#' @param verbose Toggle warnings and messages.
#' @param ... Arguments passed to or from other methods.
#' @inheritParams model_parameters.glmmTMB
#' @inheritParams p_value
#'
#' @seealso For more details, see [bayestestR::equivalence_test()]. Further
#' readings can be found in the references. See also [`p_significance()`] for
#' a unidirectional equivalence test.
#'
#' @details In classical null hypothesis significance testing (NHST) within a
#' frequentist framework, it is not possible to accept the null hypothesis, H0 -
#' unlike in Bayesian statistics, where such probability statements are
#' possible. "[...] one can only reject the null hypothesis if the test
#' statistics falls into the critical region(s), or fail to reject this
#' hypothesis. In the latter case, all we can say is that no significant effect
#' was observed, but one cannot conclude that the null hypothesis is true."
#' (_Pernet 2017_). One way to address this issues without Bayesian methods is
#' *Equivalence Testing*, as implemented in `equivalence_test()`. While you
#' either can reject the null hypothesis or claim an inconclusive result in
#' NHST, the equivalence test - according to _Pernet_ - adds a third category,
#' *"accept"*. Roughly speaking, the idea behind equivalence testing in a
#' frequentist framework is to check whether an estimate and its uncertainty
#' (i.e. confidence interval) falls within a region of "practical equivalence".
#' Depending on the rule for this test (see below), statistical significance
#' does not necessarily indicate whether the null hypothesis can be rejected or
#' not, i.e. the classical interpretation of the p-value may differ from the
#' results returned from the equivalence test.
#'
#' ## Calculation of equivalence testing
#' - "bayes" - Bayesian rule (Kruschke 2018)
#'
#' This rule follows the "HDI+ROPE decision rule" (_Kruschke, 2014, 2018_) used
#' for the [`Bayesian counterpart()`][bayestestR::equivalence_test]. This
#' means, if the confidence intervals are completely outside the ROPE, the
#' "null hypothesis" for this parameter is "rejected". If the ROPE
#' completely covers the CI, the null hypothesis is accepted. Else, it's
#' undecided whether to accept or reject the null hypothesis. Desirable
#' results are low proportions inside the ROPE (the closer to zero the
#' better).
#'
#' - "classic" - The TOST rule (Lakens 2017)
#'
#' This rule follows the "TOST rule", i.e. a two one-sided test procedure
#' (_Lakens 2017_). Following this rule...
#' - practical equivalence is assumed (i.e. H0 *"accepted"*) when the narrow
#' confidence intervals are completely inside the ROPE, no matter if the
#' effect is statistically significant or not;
#' - practical equivalence (i.e. H0) is *rejected*, when the coefficient is
#' statistically significant, both when the narrow confidence intervals
#' (i.e. `1-2*alpha`) include or exclude the the ROPE boundaries, but the
#' narrow confidence intervals are *not fully covered* by the ROPE;
#' - else the decision whether to accept or reject practical equivalence is
#' undecided (i.e. when effects are *not* statistically significant *and*
#' the narrow confidence intervals overlaps the ROPE).
#'
#' - "cet" - Conditional Equivalence Testing (Campbell/Gustafson 2018)
#'
#' The Conditional Equivalence Testing as described by _Campbell and
#' Gustafson 2018_. According to this rule, practical equivalence is
#' rejected when the coefficient is statistically significant. When the
#' effect is *not* significant and the narrow confidence intervals are
#' completely inside the ROPE, we accept (i.e. assume) practical equivalence,
#' else it is undecided.
#'
#' ## Levels of Confidence Intervals used for Equivalence Testing
#' For `rule = "classic"`, "narrow" confidence intervals are used for
#' equivalence testing. "Narrow" means, the the intervals is not 1 - alpha,
#' but 1 - 2 * alpha. Thus, if `ci = .95`, alpha is assumed to be 0.05
#' and internally a ci-level of 0.90 is used. `rule = "cet"` uses
#' both regular and narrow confidence intervals, while `rule = "bayes"`
#' only uses the regular intervals.
#'
#' ## p-Values
#' The equivalence p-value is the area of the (cumulative) confidence
#' distribution that is outside of the region of equivalence. It can be
#' interpreted as p-value for *rejecting* the alternative hypothesis and
#' *accepting* the "null hypothesis" (i.e. assuming practical equivalence). That
#' is, a high p-value means we reject the assumption of practical equivalence
#' and accept the alternative hypothesis.
#'
#' ## Second Generation p-Value (SGPV)
#' Second generation p-values (SGPV) were proposed as a statistic that
#' represents _the proportion of data-supported hypotheses that are also null
#' hypotheses_ _(Blume et al. 2018, Lakens and Delacre 2020)_. It represents the
#' proportion of the _full_ confidence interval range (assuming a normally or
#' t-distributed, equal-tailed interval, based on the model) that is inside the
#' ROPE. The SGPV ranges from zero to one. Higher values indicate that the
#' effect is more likely to be practically equivalent ("not of interest").
#'
#' Note that the assumed interval, which is used to calculate the SGPV, is an
#' estimation of the _full interval_ based on the chosen confidence level. For
#' example, if the 95% confidence interval of a coefficient ranges from -1 to 1,
#' the underlying _full (normally or t-distributed) interval_ approximately
#' ranges from -1.9 to 1.9, see also following code:
#'
#' ```
#' # simulate full normal distribution
#' out <- bayestestR::distribution_normal(10000, 0, 0.5)
#' # range of "full" distribution
#' range(out)
#' # range of 95% CI
#' round(quantile(out, probs = c(0.025, 0.975)), 2)
#' ```
#'
#' This ensures that the SGPV always refers to the general compatible parameter
#' space of coefficients, independent from the confidence interval chosen for
#' testing practical equivalence. Therefore, the SGPV of the _full interval_ is
#' similar to the ROPE coverage of Bayesian equivalence tests, see following
#' code:
#'
#' ```
#' library(bayestestR)
#' library(brms)
#' m <- lm(mpg ~ gear + wt + cyl + hp, data = mtcars)
#' m2 <- brm(mpg ~ gear + wt + cyl + hp, data = mtcars)
#' # SGPV for frequentist models
#' equivalence_test(m)
#' # similar to ROPE coverage of Bayesian models
#' equivalence_test(m2)
#' # similar to ROPE coverage of simulated draws / bootstrap samples
#' equivalence_test(simulate_model(m))
#' ```
#'
#' ## ROPE range
#' Some attention is required for finding suitable values for the ROPE limits
#' (argument `range`). See 'Details' in [bayestestR::rope_range()]
#' for further information.
#'
#' @inheritSection model_parameters Statistical inference - how to quantify evidence
#'
#' @note There is also a [`plot()`-method](https://easystats.github.io/see/articles/parameters.html)
#' implemented in the [**see**-package](https://easystats.github.io/see/).
#'
#' @references
#'
#' - Amrhein, V., Korner-Nievergelt, F., and Roth, T. (2017). The earth is
#' flat (p > 0.05): Significance thresholds and the crisis of unreplicable
#' research. PeerJ, 5, e3544. \doi{10.7717/peerj.3544}
#'
#' - Blume, J. D., D'Agostino McGowan, L., Dupont, W. D., & Greevy, R. A.
#' (2018). Second-generation p-values: Improved rigor, reproducibility, &
#' transparency in statistical analyses. PLOS ONE, 13(3), e0188299.
#' https://doi.org/10.1371/journal.pone.0188299
#'
#' - Campbell, H., & Gustafson, P. (2018). Conditional equivalence
#' testing: An alternative remedy for publication bias. PLOS ONE, 13(4),
#' e0195145. doi: 10.1371/journal.pone.0195145
#'
#' - Greenland S, Rafi Z, Matthews R, Higgs M. To Aid Scientific Inference,
#' Emphasize Unconditional Compatibility Descriptions of Statistics. (2022)
#' https://arxiv.org/abs/1909.08583v7 (Accessed November 10, 2022)
#'
#' - Kruschke, J. K. (2014). Doing Bayesian data analysis: A tutorial with
#' R, JAGS, and Stan. Academic Press
#'
#' - Kruschke, J. K. (2018). Rejecting or accepting parameter values in
#' Bayesian estimation. Advances in Methods and Practices in Psychological
#' Science, 1(2), 270-280. doi: 10.1177/2515245918771304
#'
#' - Lakens, D. (2017). Equivalence Tests: A Practical Primer for t Tests,
#' Correlations, and Meta-Analyses. Social Psychological and Personality
#' Science, 8(4), 355–362. doi: 10.1177/1948550617697177
#'
#' - Lakens, D. (2024). Improving Your Statistical Inferences (Version v1.5.1).
#' Retrieved from https://lakens.github.io/statistical_inferences/.
#' \doi{10.5281/ZENODO.6409077}
#'
#' - Lakens, D., and Delacre, M. (2020). Equivalence Testing and the Second
#' Generation P-Value. Meta-Psychology, 4.
#' https://doi.org/10.15626/MP.2018.933
#'
#' - Lakens, D., Scheel, A. M., and Isager, P. M. (2018). Equivalence Testing
#' for Psychological Research: A Tutorial. Advances in Methods and Practices
#' in Psychological Science, 1(2), 259–269. \doi{10.1177/2515245918770963}
#'
#' - Makowski, D., Ben-Shachar, M. S., Chen, S. H. A., and Lüdecke, D. (2019).
#' Indices of Effect Existence and Significance in the Bayesian Framework.
#' Frontiers in Psychology, 10, 2767. \doi{10.3389/fpsyg.2019.02767}
#'
#' - Pernet, C. (2017). Null hypothesis significance testing: A guide to
#' commonly misunderstood concepts and recommendations for good practice.
#' F1000Research, 4, 621. doi: 10.12688/f1000research.6963.5
#'
#' - Rafi Z, Greenland S. Semantic and cognitive tools to aid statistical
#' science: replace confidence and significance by compatibility and surprise.
#' BMC Medical Research Methodology (2020) 20:244.
#'
#' - Schweder T. Confidence is epistemic probability for empirical science.
#' Journal of Statistical Planning and Inference (2018) 195:116–125.
#' \doi{10.1016/j.jspi.2017.09.016}
#'
#' - Schweder T, Hjort NL. Frequentist analogues of priors and posteriors.
#' In Stigum, B. (ed.), Econometrics and the Philosophy of Economics: Theory
#' Data Confrontation in Economics, pp. 285-217. Princeton University Press,
#' Princeton, NJ, 2003
#'
#' - Vos P, Holbert D. Frequentist statistical inference without repeated sampling.
#' Synthese 200, 89 (2022). \doi{10.1007/s11229-022-03560-x}
#'
#' @return A data frame.
#' @examplesIf requireNamespace("sandwich")
#' data(qol_cancer)
#' model <- lm(QoL ~ time + age + education, data = qol_cancer)
#'
#' # default rule
#' equivalence_test(model)
#'
#' # using heteroscedasticity-robust standard errors
#' equivalence_test(model, vcov = "HC3")
#'
#' # conditional equivalence test
#' equivalence_test(model, rule = "cet")
#'
#' # plot method
#' if (require("see", quietly = TRUE)) {
#' result <- equivalence_test(model)
#' plot(result)
#' }
#' @export
equivalence_test.lm <- function(x,
range = "default",
ci = 0.95,
rule = "classic",
effects = "fixed",
vcov = NULL,
vcov_args = NULL,
verbose = TRUE,
...) {
rule <- insight::validate_argument(tolower(rule), c("bayes", "classic", "cet"))
out <- .equivalence_test_frequentist(
x,
range = range,
ci = ci,
rule = rule,
vcov = vcov,
vcov_args = vcov_args,
verbose,
...
)
if (is.null(attr(out, "pretty_names", exact = TRUE))) {
attr(out, "pretty_names") <- format_parameters(x)
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
attr(out, "rule") <- rule
class(out) <- c("equivalence_test_lm", "see_equivalence_test_lm", class(out))
out
}
# standard models, only fixed effects ----------------------
#' @export
equivalence_test.glm <- equivalence_test.lm
#' @export
equivalence_test.wbm <- equivalence_test.lm
#' @export
equivalence_test.lme <- equivalence_test.lm
#' @export
equivalence_test.gee <- equivalence_test.lm
#' @export
equivalence_test.gls <- equivalence_test.lm
#' @export
equivalence_test.feis <- equivalence_test.lm
#' @export
equivalence_test.felm <- equivalence_test.lm
#' @export
equivalence_test.mixed <- equivalence_test.lm
#' @export
equivalence_test.hurdle <- equivalence_test.lm
#' @export
equivalence_test.zeroinfl <- equivalence_test.lm
#' @export
equivalence_test.rma <- equivalence_test.lm
# mixed models, also random effects ----------------------
#' @export
equivalence_test.merMod <- function(x,
range = "default",
ci = 0.95,
rule = "classic",
effects = "fixed",
vcov = NULL,
vcov_args = NULL,
verbose = TRUE,
...) {
# ==== argument matching ====
rule <- insight::validate_argument(tolower(rule), c("bayes", "classic", "cet"))
effects <- insight::validate_argument(effects, c("fixed", "random"))
# ==== equivalent testing for fixed or random effects ====
if (effects == "fixed") {
out <- .equivalence_test_frequentist(
x,
range = range,
ci = ci,
rule = rule,
vcov = vcov,
vcov_args = vcov_args,
verbose,
...
)
} else {
out <- .equivalence_test_frequentist_random(x, range, ci, rule, verbose, ...)
}
# ==== result ====
if (is.null(attr(out, "pretty_names", exact = TRUE))) {
attr(out, "pretty_names") <- format_parameters(x)
}
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(x))
attr(out, "rule") <- rule
class(out) <- c("equivalence_test_lm", "see_equivalence_test_lm", class(out))
out
}
#' @export
equivalence_test.glmmTMB <- equivalence_test.merMod
#' @export
equivalence_test.MixMod <- equivalence_test.merMod
# Special classes -------------------------
#' @export
equivalence_test.parameters_simulate_model <- function(x,
range = "default",
ci = 0.95,
verbose = TRUE,
...) {
# ==== retrieve model, to define rope range for simulated model parameters ====
model <- .get_object(x)
if (all(range == "default") && !is.null(model)) {
range <- bayestestR::rope_range(model, verbose = verbose)
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error(
"`range` should be \"default\" or a vector of 2 numeric values (e.g., `c(-0.1, 0.1)`)."
)
}
# ==== classical equivalent testing for data frames ====
out <- equivalence_test(as.data.frame(x), range = range, ci = ci, verbose = verbose, ...)
if (is.null(attr(out, "pretty_names", exact = TRUE))) {
attr(out, "pretty_names") <- format_parameters(x)
}
attr(out, "object_name") <- attr(x, "object_name")
attr(out, "data") <- x
class(out) <- unique(c("equivalence_test", "see_equivalence_test", "equivalence_test_simulate_model", class(out)))
out
}
#' @export
equivalence_test.parameters_model <- function(x,
range = "default",
ci = 0.95,
rule = "classic",
verbose = TRUE,
...) {
model <- .get_object(x)
equivalence_test(x = model, range = range, ci = ci, rule = rule, verbose = verbose, ...)
}
#' @rdname equivalence_test.lm
#' @export
equivalence_test.ggeffects <- function(x,
range = "default",
rule = "classic",
test = "pairwise",
verbose = TRUE,
...) {
insight::check_if_installed("ggeffects")
# get attributes from ggeffects objects, so we have the original model and terms
focal <- attributes(x)$original.terms
obj_name <- attributes(x)$model.name
ci <- attributes(x)$ci.lvl
dof <- attributes(x)$df
x <- .get_ggeffects_model(x)
# validation check rope range
rule <- match.arg(tolower(rule), choices = c("bayes", "classic", "cet"))
range <- .check_rope_range(x, range, verbose)
out <- ggeffects::test_predictions(
x,
terms = focal,
test = test,
equivalence = range,
verbose = verbose,
...
)
out <- insight::standardize_names(out)
# we only have one type of CIs
conf_int <- conf_int2 <- as.data.frame(t(out[c("CI_low", "CI_high")]))
l <- Map(
function(ci_wide, ci_narrow) {
.equivalence_test_numeric(
ci = ci,
ci_wide,
ci_narrow,
range_rope = range,
rule = rule,
dof = dof,
verbose = verbose
)
}, conf_int, conf_int2
)
# bind to data frame
dat <- do.call(rbind, l)
# remove old CIs, bind results from equivalence test
out$CI_low <- out$CI_high <- NULL
out$CI <- ci
out <- cbind(out, dat)
# standardize column order
cols <- c(
"Estimate", "Contrast", "Slope", "Predicted", "CI", "CI_low", "CI_high",
"SGPV", "ROPE_low", "ROPE_high", "ROPE_Percentage", "ROPE_Equivalence", "p"
)
# order of shared columns
shared_order <- intersect(cols, colnames(out))
parameter_columns <- setdiff(colnames(out), shared_order)
# add remaining columns, sort
out <- out[c(parameter_columns, shared_order)]
attr(out, "object_name") <- obj_name
attr(out, "parameter_columns") <- parameter_columns
attr(out, "rule") <- rule
attr(out, "rope") <- range
class(out) <- c("equivalence_test_lm", "see_equivalence_test_ggeffects", "data.frame")
out
}
# helper -------------------
#' @keywords internal
.check_rope_range <- function(x, range, verbose) {
if (all(range == "default")) {
range <- bayestestR::rope_range(x, verbose = verbose)
if (is.list(range)) {
range <- range[[which.max(sapply(range, diff))]]
}
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error(
"`range` should be \"default\" or a vector of 2 numeric values (e.g., `c(-0.1, 0.1)`)."
)
}
range
}
#' @keywords internal
.equivalence_test_frequentist <- function(x,
range = "default",
ci = 0.95,
rule = "classic",
vcov = NULL,
vcov_args = NULL,
verbose = TRUE,
...) {
# ==== define rope range ====
range <- .check_rope_range(x, range, verbose)
if (length(ci) > 1) {
insight::format_alert("`ci` may only be of length 1. Using first ci-value now.")
ci <- ci[1]
}
# ==== check degrees of freedom ====
df_column <- grep("(df|df_error)", colnames(x))
if (length(df_column) > 0) {
dof <- unique(x[[df_column]])
if (length(dof) > 1) {
dof <- Inf
}
} else {
dof <- Inf
}
# ==== requested confidence intervals ====
params <- conf_int <- .ci_generic(x, ci = ci, vcov = vcov, vcov_args = vcov_args, ...)
conf_int <- as.data.frame(t(conf_int[, c("CI_low", "CI_high")]))
# ==== the "narrower" intervals (1-2*alpha) for CET-rules. ====
alpha <- 1 - ci
conf_int2 <- .ci_generic(x, ci = (ci - alpha), vcov = vcov, vcov_args = vcov_args, ...)
conf_int2 <- as.data.frame(t(conf_int2[, c("CI_low", "CI_high")]))
# ==== equivalence test for each parameter ====
l <- Map(
function(ci_wide, ci_narrow) {
.equivalence_test_numeric(
ci = ci,
ci_wide,
ci_narrow,
range_rope = range,
rule = rule,
dof = dof,
verbose = verbose
)
}, conf_int, conf_int2
)
dat <- do.call(rbind, l)
if ("Component" %in% colnames(params)) dat$Component <- params$Component
out <- data.frame(
Parameter = params$Parameter,
CI = ifelse(rule == "bayes", ci, ci - alpha),
dat,
stringsAsFactors = FALSE
)
# ==== (adjusted) p-values for tests ====
out$p <- .add_p_to_equitest(x, ci, range, vcov = vcov, vcov_args = vcov_args, ...)
attr(out, "rope") <- range
out
}
#' @keywords internal
.equivalence_test_frequentist_random <- function(x,
range = "default",
ci = 0.95,
rule = "classic",
verbose = TRUE,
...) {
if (all(range == "default")) {
range <- bayestestR::rope_range(x, verbose = verbose)
} else if (!all(is.numeric(range)) || length(range) != 2) {
insight::format_error(
"`range` should be \"default\" or a vector of 2 numeric values (e.g., `c(-0.1, 0.1)`)."
)
}
if (length(ci) > 1) {
if (isTRUE(verbose)) {
insight::format_alert("`ci` may only be of length 1. Using first ci-value now.")
}
ci <- ci[1]
}
params <- insight::get_parameters(x, effects = "random", component = "conditional", verbose = FALSE)
se <- standard_error(x, effects = "random", component = "conditional")
alpha <- (1 + ci) / 2
fac <- stats::qnorm(alpha)
alpha_narrow <- (1 + ci - (1 - ci)) / 2
fac_narrow <- stats::qnorm(alpha_narrow)
out <- do.call(rbind, lapply(names(params), function(np) {
est <- params[[np]][, "(Intercept)"]
std_err <- se[[np]][, "(Intercept)"]
d <- data.frame(
Parameter = rownames(params[[np]]),
Estimate = est,
CI = ifelse(rule == "bayes", ci, ci - (1 - ci)),
Group = np,
stringsAsFactors = FALSE
)
conf_int <- as.data.frame(t(data.frame(
CI_low = est - std_err * fac,
CI_high = est + std_err * fac
)))
conf_int2 <- as.data.frame(t(data.frame(
CI_low = est - std_err * fac_narrow,
CI_high = est + std_err * fac_narrow
)))
l <- Map(
function(ci_wide, ci_narrow) {
.equivalence_test_numeric(
ci = ci,
ci_wide,
ci_narrow,
range_rope = range,
rule = rule,
verbose = verbose
)
}, conf_int, conf_int2
)
dat <- do.call(rbind, l)
cbind(d, dat)
}))
attr(out, "rope") <- range
out
}
#' @keywords internal
.equivalence_test_numeric <- function(ci = 0.95,
ci_wide,
ci_narrow,
range_rope,
rule,
dof = Inf,
verbose) {
final_ci <- NULL
# ==== HDI+ROPE decision rule, by Kruschke ====
if (rule == "bayes") {
final_ci <- ci_wide
if (min(ci_wide) > max(range_rope) || max(ci_wide) < min(range_rope)) {
decision <- "Rejected"
} else if (max(ci_wide) <= max(range_rope) && min(ci_wide) >= min(range_rope)) {
decision <- "Accepted"
} else {
decision <- "Undecided"
}
}
# ==== Lakens' rule ====
if (rule == "classic") {
final_ci <- ci_narrow
if (all(ci_narrow < max(range_rope)) && all(ci_narrow > min(range_rope))) {
# narrow CI is fully inside ROPE - always accept
decision <- "Accepted"
} else if (min(ci_narrow) < 0 && max(ci_narrow) > 0) {
# non-significant results - undecided
decision <- "Undecided"
} else {
decision <- "Rejected"
}
}
# ==== CET rule ====
if (rule == "cet") {
final_ci <- ci_narrow
# significant result?
if (min(ci_wide) > 0 || max(ci_wide) < 0) {
decision <- "Rejected"
# non-significant results, all narrow CI inside ROPE
} else if (all(ci_narrow < max(range_rope)) && all(ci_narrow > min(range_rope))) {
decision <- "Accepted"
} else {
decision <- "Undecided"
}
}
data.frame(
CI_low = final_ci[1],
CI_high = final_ci[2],
SGPV = .rope_coverage(ci = ci, range_rope, ci_range = final_ci, dof = dof),
ROPE_low = range_rope[1],
ROPE_high = range_rope[2],
ROPE_Equivalence = decision,
stringsAsFactors = FALSE
)
}
# helper ---------------------
# this function simply takes the length of the range and calculates the proportion
# of that range that is inside the rope. However, this assumed a "flat", i.e.
# uniformly distributed interval, which is not accurate for standard confidence
# intervals. thus, we no longer use this function, but switch to ".rope_coverage()".
.sgpv <- function(range_rope, ci) {
diff_rope <- abs(diff(range_rope))
diff_ci <- abs(diff(ci))
# inside?
if (min(ci) >= min(range_rope) && max(ci) <= max(range_rope)) {
coverage <- 1
# outside?
} else if (max(ci) < min(range_rope) || min(ci) > max(range_rope)) {
coverage <- 0
# CI covers completely rope?
} else if (max(ci) > max(range_rope) && min(ci) < min(range_rope)) {
coverage <- diff_rope / diff_ci
# CI inside rope and outside max rope?
} else if (min(ci) >= min(range_rope) && max(ci) > max(range_rope)) {
diff_in_rope <- max(range_rope) - min(ci)
coverage <- diff_in_rope / diff_ci
# CI inside rope and outside min rope?
} else if (max(ci) <= max(range_rope) && min(ci) < min(range_rope)) {
diff_in_rope <- max(ci) - min(range_rope)
coverage <- diff_in_rope / diff_ci
}
coverage
}
# this function simulates a normal distribution, which approximately has the
# same range / limits as the confidence interval, thus indeed representing a
# normally distributed confidence interval. We then calculate the probability
# mass of this interval that is inside the ROPE.
.rope_coverage <- function(ci = 0.95, range_rope, ci_range, dof = Inf) {
out <- .generate_posterior_from_ci(ci, ci_range, dof = dof)
# compare: ci_range and range(out)
# The SGPV refers to the proportion of the confidence interval inside the
# full ROPE - thus, we set ci = 1 here
rc <- bayestestR::rope(out, range = range_rope, ci = 1)
rc$ROPE_Percentage
}
.generate_posterior_from_ci <- function(ci = 0.95, ci_range, dof = Inf, precision = 10000) {
# this function creates an approximate normal distribution that covers the
# CI-range, i.e. we "simulate" a posterior distribution from a frequentist CI
# sanity check - dof argument
if (is.null(dof)) {
dof <- Inf
}
# first we need the range of the CI (in units), also to calculate the mean of
# the normal distribution
diff_ci <- abs(diff(ci_range))
mean_dist <- ci_range[2] - (diff_ci / 2)
# then we need the critical values of the quantiles from the CI range
z_value <- stats::qt((1 + ci) / 2, df = dof)
# the range of Z-scores (from lower to upper quantile) gives us the range of
# the provided interval in terms of standard deviations. now we divide the
# known range of the provided CI (in units) by the z-score-range, which will
# give us the standard deviation of the distribution.
sd_dist <- diff_ci / diff(c(-1 * z_value, z_value))
# generate normal-distribution if we don't have t-distribution, or if
# we don't have necessary packages installed
if (is.infinite(dof) || !insight::check_if_installed("distributional", quietly = TRUE)) {
# tell user to install "distributional"
if (!is.infinite(dof)) {
insight::format_alert("For models with only few degrees of freedom, install the {distributional} package to increase accuracy of `p_direction()`, `p_significance()` and `equivalence_test()`.") # nolint
}
# we now know all parameters (mean and sd) to simulate a normal distribution
bayestestR::distribution_normal(n = precision, mean = mean_dist, sd = sd_dist)
} else {
insight::check_if_installed("distributional")
out <- distributional::dist_student_t(df = dof, mu = mean_dist, sigma = sd_dist)
sort(unlist(distributional::generate(out, times = precision), use.names = FALSE))
}
}
.add_p_to_equitest <- function(model, ci, range, vcov = NULL, vcov_args = NULL, ...) {
tryCatch(
{
params <- insight::get_parameters(model)
# degrees of freedom
dof <- insight::get_df(x = model, type = "wald")
# mu
params$mu <- params$Estimate * -1
# se
se <- standard_error(model, vcov = vcov, vcov_args = vcov_args, ...)
stats::pt((range[1] - params$mu) / se$SE, df = dof, lower.tail = TRUE) +
stats::pt((range[2] - params$mu) / se$SE, df = dof, lower.tail = FALSE)
},
error = function(e) {
NULL
}
)
}
# methods ----------------
#' @export
format.equivalence_test_lm <- function(x,
digits = 2,
ci_digits = digits,
p_digits = 3,
ci_width = NULL,
ci_brackets = NULL,
format = "text",
zap_small = FALSE,
...) {
# default brackets are parenthesis for HTML / MD
if ((is.null(ci_brackets) || isTRUE(ci_brackets)) && (identical(format, "html") || identical(format, "markdown"))) {
ci_brackets <- c("(", ")")
} else if (is.null(ci_brackets) || isTRUE(ci_brackets)) {
ci_brackets <- c("[", "]")
}
# main formatting
out <- insight::format_table(
x,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
ci_width = ci_width,
ci_brackets = ci_brackets,
zap_small = zap_small,
...
)
# format column names
colnames(out)[which(colnames(out) == "Equivalence (ROPE)")] <- "Equivalence"
out$ROPE <- NULL
# only show supported components
if ("Component" %in% colnames(out)) {
out <- out[out$Component %in% c("conditional", "count"), ]
}
out
}
#' @export
print.equivalence_test_lm <- function(x,
digits = 2,
ci_digits = digits,
p_digits = 3,
ci_brackets = NULL,
zap_small = FALSE,
...) {
orig_x <- x
rule <- attributes(x)$rule
if (is.null(rule)) {
insight::print_color("# Test for Practical Equivalence\n\n", "blue")
} else if (rule == "cet") {
insight::print_color("# Conditional Equivalence Testing\n\n", "blue")
} else if (rule == "classic") {
insight::print_color("# TOST-test for Practical Equivalence\n\n", "blue")
} else {
insight::print_color("# Test for Practical Equivalence\n\n", "blue")
}
.rope <- attr(x, "rope", exact = TRUE)
cat(sprintf(" ROPE: [%.*f %.*f]\n\n", digits, .rope[1], digits, .rope[2]))
# formatting
x <- format(x,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
ci_width = "auto",
ci_brackets = ci_brackets,
format = "text",
zap_small = zap_small,
...
)
if ("Group" %in% colnames(x)) {
out <- split(x, x$Group)
for (i in names(out)) {
insight::print_color(sprintf("Group: %s\n\n", i), "red")
cat(insight::export_table(out[[i]]))
}
} else {
cat(insight::export_table(x))
}
invisible(orig_x)
}
#' @export
plot.equivalence_test_lm <- function(x, ...) {
insight::check_if_installed("see")
NextMethod()
}
parameters/R/methods_ivreg.R 0000644 0001762 0000144 00000000252 14133222153 015573 0 ustar ligges users #' @export
p_value.ivreg <- p_value.default
#' @export
simulate_model.ivreg <- simulate_model.default
#' @export
standard_error.ivreg <- standard_error.default
parameters/R/factor_analysis.R 0000644 0001762 0000144 00000004400 14736731407 016134 0 ustar ligges users #' @rdname principal_components
#' @export
factor_analysis <- function(x,
n = "auto",
rotation = "none",
sort = FALSE,
threshold = NULL,
standardize = TRUE,
cor = NULL,
...) {
UseMethod("factor_analysis")
}
#' @export
factor_analysis.data.frame <- function(x,
n = "auto",
rotation = "none",
sort = FALSE,
threshold = NULL,
standardize = TRUE,
cor = NULL,
...) {
# Standardize
if (standardize && is.null(cor)) {
x <- datawizard::standardize(x, ...)
}
# N factors
n <- .get_n_factors(x, n = n, type = "FA", rotation = rotation, cor = cor)
.factor_analysis_rotate(
x,
n,
rotation = rotation,
sort = sort,
threshold = threshold,
cor = cor,
...
)
}
#' @keywords internal
.factor_analysis_rotate <- function(x,
n,
rotation,
sort = FALSE,
threshold = NULL,
cor = NULL,
...) {
if (!inherits(x, "data.frame")) {
insight::format_error("`x` must be a data frame.")
}
# rotate loadings
if (!requireNamespace("psych", quietly = TRUE)) {
insight::format_error(sprintf("Package `psych` required for `%s`-rotation.", rotation))
}
# Pass cor if available
if (is.null(cor)) {
out <- model_parameters(
psych::fa(x, nfactors = n, rotate = rotation, ...),
sort = sort,
threshold = threshold
)
} else {
out <- model_parameters(
psych::fa(
cor,
nfactors = n,
rotate = rotation,
n.obs = nrow(x),
...
),
sort = sort,
threshold = threshold
)
}
attr(out, "dataset") <- x
out
}
parameters/R/dof.R 0000644 0001762 0000144 00000013011 14716604200 013505 0 ustar ligges users #' Degrees of Freedom (DoF)
#'
#' Estimate or extract degrees of freedom of models parameters.
#'
#' @param model A statistical model.
#' @param method Type of approximation for the degrees of freedom. Can be one of
#' the following:
#'
#' + `"residual"` (aka `"analytical"`) returns the residual degrees of
#' freedom, which usually is what [`stats::df.residual()`] returns. If a
#' model object has no method to extract residual degrees of freedom, these
#' are calculated as `n-p`, i.e. the number of observations minus the number
#' of estimated parameters. If residual degrees of freedom cannot be extracted
#' by either approach, returns `Inf`.
#' + `"wald"` returns residual (aka analytical) degrees of freedom for models
#' with t-statistic, `1` for models with Chi-squared statistic, and `Inf` for
#' all other models. Also returns `Inf` if residual degrees of freedom cannot
#' be extracted.
#' + `"normal"` always returns `Inf`.
#' + `"model"` returns model-based degrees of freedom, i.e. the number of
#' (estimated) parameters.
#' + For mixed models, can also be `"ml1"` (or `"m-l-1"`, approximation of
#' degrees of freedom based on a "m-l-1" heuristic as suggested by _Elff et
#' al. 2019_) or `"between-within"` (or `"betwithin"`).
#' + For mixed models of class `merMod`, `type` can also be `"satterthwaite"`
#' or `"kenward-roger"` (or `"kenward"`). See 'Details'.
#'
#' Usually, when degrees of freedom are required to calculate p-values or
#' confidence intervals, `type = "wald"` is likely to be the best choice in
#' most cases.
#' @param ... Currently not used.
#'
#' @note
#' In many cases, `degrees_of_freedom()` returns the same as `df.residuals()`,
#' or `n-k` (number of observations minus number of parameters). However,
#' `degrees_of_freedom()` refers to the model's *parameters* degrees of freedom
#' of the distribution for the related test statistic. Thus, for models with
#' z-statistic, results from `degrees_of_freedom()` and `df.residuals()` differ.
#' Furthermore, for other approximation methods like `"kenward"` or
#' `"satterthwaite"`, each model parameter can have a different degree of
#' freedom.
#'
#' @examplesIf require("lme4", quietly = TRUE)
#' model <- lm(Sepal.Length ~ Petal.Length * Species, data = iris)
#' dof(model)
#'
#' model <- glm(vs ~ mpg * cyl, data = mtcars, family = "binomial")
#' dof(model)
#' \donttest{
#' model <- lmer(Sepal.Length ~ Petal.Length + (1 | Species), data = iris)
#' dof(model)
#'
#' if (require("rstanarm", quietly = TRUE)) {
#' model <- stan_glm(
#' Sepal.Length ~ Petal.Length * Species,
#' data = iris,
#' chains = 2,
#' refresh = 0
#' )
#' dof(model)
#' }
#' }
#' @export
degrees_of_freedom <- function(model, method = "analytical", ...) {
insight::get_df(x = model, type = method, ...)
}
#' @rdname degrees_of_freedom
#' @export
dof <- degrees_of_freedom
# Helper, check args ------------------------------
.dof_method_ok <- function(model, method, type = "df_method", verbose = TRUE, ...) {
if (is.null(method)) {
return(TRUE)
}
method <- tolower(method)
# exceptions 1
if (inherits(model, c("polr", "glm", "svyglm"))) {
if (method %in% c(
"analytical", "any", "fit", "profile", "residual",
"wald", "nokr", "likelihood", "normal"
)) {
return(TRUE)
} else {
if (verbose) {
insight::format_alert(sprintf("`%s` must be one of \"wald\", \"residual\" or \"profile\". Using \"wald\" now.", type)) # nolint
}
return(FALSE)
}
}
# exceptions 2
if (inherits(model, c("phylolm", "phyloglm"))) {
if (method %in% c("analytical", "any", "fit", "residual", "wald", "nokr", "normal", "boot")) {
return(TRUE)
} else {
if (verbose) {
insight::format_alert(sprintf("`%s` must be one of \"wald\", \"normal\" or \"boot\". Using \"wald\" now.", type)) # nolint
}
return(FALSE)
}
}
info <- insight::model_info(model, verbose = FALSE)
if (!is.null(info) && isFALSE(info$is_mixed) && method == "boot") {
if (verbose) {
insight::format_alert(sprintf("`%s=boot` only works for mixed models of class `merMod`. To bootstrap this model, use `bootstrap=TRUE, ci_method=\"bcai\"`.", type)) # nolint
}
return(TRUE)
}
if (is.null(info) || !info$is_mixed) {
if (!(method %in% c("analytical", "any", "fit", "betwithin", "nokr", "wald", "ml1", "profile", "boot", "uniroot", "residual", "normal"))) { # nolint
if (verbose) {
insight::format_alert(sprintf("`%s` must be one of \"residual\", \"wald\", \"normal\", \"profile\", \"boot\", \"uniroot\", \"betwithin\" or \"ml1\". Using \"wald\" now.", type)) # nolint
}
return(FALSE)
}
return(TRUE)
}
if (!(method %in% c("analytical", "any", "fit", "satterthwaite", "betwithin", "kenward", "kr", "nokr", "wald", "ml1", "profile", "boot", "uniroot", "residual", "normal"))) { # nolint
if (verbose) {
insight::format_alert(sprintf("`%s` must be one of \"residual\", \"wald\", \"normal\", \"profile\", \"boot\", \"uniroot\", \"kenward\", \"satterthwaite\", \"betwithin\" or \"ml1\". Using \"wald\" now.", type)) # nolint
}
return(FALSE)
}
if (!info$is_linear && method %in% c("satterthwaite", "kenward", "kr")) {
if (verbose) {
insight::format_alert(sprintf("`%s`-degrees of freedoms are only available for linear mixed models.", method))
}
return(FALSE)
}
return(TRUE)
}
parameters/R/methods_pam.R 0000644 0001762 0000144 00000000601 14717111737 015247 0 ustar ligges users #' @export
model_parameters.pam <- function(model, data = NULL, clusters = NULL, ...) {
if (is.null(data)) data <- as.data.frame(model$data)
if (is.null(clusters)) clusters <- model$clustering
params <- .cluster_centers_params(data, clusters, ...)
attr(params, "model") <- model
attr(params, "type") <- "pam"
attr(params, "title") <- "K-Medoids"
params
}
parameters/R/methods_fitdistr.R 0000644 0001762 0000144 00000001545 14507235543 016331 0 ustar ligges users #' @export
model_parameters.fitdistr <- function(model,
exponentiate = FALSE,
verbose = TRUE,
...) {
out <- data.frame(
Parameter = names(model$estimate),
Coefficient = as.vector(model$estimate),
SE = as.vector(model$sd),
stringsAsFactors = FALSE
)
# exponentiate coefficients and SE/CI, if requested
out <- .exponentiate_parameters(out, model, exponentiate)
class(out) <- c("parameters_model", "see_parameters_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.fitdistr <- function(model, ...) {
data.frame(
Parameter = names(model$estimate),
SE = as.vector(model$sd),
stringsAsFactors = FALSE
)
}
parameters/R/methods_mfx.R 0000644 0001762 0000144 00000023626 14736731407 015303 0 ustar ligges users # model parameters ---------------------
#' @export
model_parameters.logitor <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = TRUE,
p_adjust = NULL,
verbose = TRUE,
...) {
model_parameters.default(
model$fit,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
...
)
}
#' @export
model_parameters.poissonirr <- model_parameters.logitor
#' @export
model_parameters.negbinirr <- model_parameters.logitor
#' @export
model_parameters.poissonmfx <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "all",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "marginal")
)
out <- .model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Component"),
standardize = standardize,
exponentiate = exponentiate,
component = component,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
model_parameters.logitmfx <- model_parameters.poissonmfx
#' @export
model_parameters.probitmfx <- model_parameters.poissonmfx
#' @export
model_parameters.negbinmfx <- model_parameters.poissonmfx
#' @export
model_parameters.betaor <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "conditional",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("conditional", "precision", "all")
)
model_parameters.betareg(
model$fit,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
component = component,
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
...
)
}
#' @export
model_parameters.betamfx <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "all",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision", "marginal")
)
out <- .model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Component"),
standardize = standardize,
exponentiate = exponentiate,
component = component,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
# ci ------------------
#' @export
ci.logitor <- function(x, ci = 0.95, method = NULL, ...) {
.ci_generic(model = x$fit, ci = ci, method = method, ...)
}
#' @export
ci.poissonirr <- ci.logitor
#' @export
ci.negbinirr <- ci.logitor
#' @export
ci.poissonmfx <- function(x, ci = 0.95, component = "all", method = NULL, ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "marginal")
)
.ci_generic(model = x, ci = ci, component = component, method = method, ...)
}
#' @export
ci.negbinmfx <- ci.poissonmfx
#' @export
ci.logitmfx <- ci.poissonmfx
#' @export
ci.probitmfx <- ci.poissonmfx
#' @export
ci.betaor <- function(x, ci = 0.95, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
.ci_generic(model = x$fit, ci = ci, dof = Inf, component = component)
}
#' @export
ci.betamfx <- function(x,
ci = 0.95,
method = NULL,
component = "all",
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision", "marginal")
)
.ci_generic(model = x, ci = ci, component = component, method = method, ...)
}
# standard error ------------------
#' @export
standard_error.negbin <- standard_error.default
#' @export
standard_error.logitor <- function(model, ...) {
standard_error.default(model$fit, ...)
}
#' @export
standard_error.poissonirr <- standard_error.logitor
#' @export
standard_error.negbinirr <- standard_error.logitor
#' @export
standard_error.poissonmfx <- function(model, component = "all", ...) {
parms <- insight::get_parameters(model, component = "all")
cs <- stats::coef(summary(model$fit))
se <- c(as.vector(model$mfxest[, 2]), as.vector(cs[, 2]))
out <- .data_frame(
Parameter = parms$Parameter,
SE = se,
Component = parms$Component
)
component <- insight::validate_argument(
component,
c("all", "conditional", "marginal")
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
standard_error.logitmfx <- standard_error.poissonmfx
#' @export
standard_error.probitmfx <- standard_error.poissonmfx
#' @export
standard_error.negbinmfx <- standard_error.poissonmfx
#' @export
standard_error.betaor <- function(model, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
standard_error.betareg(model$fit, component = component, ...)
}
#' @export
standard_error.betamfx <- function(model, component = "all", ...) {
parms <- insight::get_parameters(model, component = "all")
cs <- do.call(rbind, stats::coef(summary(model$fit)))
se <- c(as.vector(model$mfxest[, 2]), as.vector(cs[, 2]))
out <- .data_frame(
Parameter = parms$Parameter,
SE = se,
Component = parms$Component
)
component <- insight::validate_argument(
component,
c("all", "conditional", "precision", "marginal")
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
# p values ------------------
#' @export
p_value.poissonmfx <- function(model, component = "all", ...) {
parms <- insight::get_parameters(model, component = "all")
cs <- stats::coef(summary(model$fit))
p <- c(as.vector(model$mfxest[, 4]), as.vector(cs[, 4]))
out <- .data_frame(
Parameter = parms$Parameter,
p = p,
Component = parms$Component
)
component <- insight::validate_argument(
component,
c("all", "conditional", "marginal")
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
#' @export
p_value.logitor <- function(model, method = NULL, ...) {
p_value.default(model$fit, method = method, ...)
}
#' @export
p_value.poissonirr <- p_value.logitor
#' @export
p_value.negbinirr <- p_value.logitor
#' @export
p_value.logitmfx <- p_value.poissonmfx
#' @export
p_value.probitmfx <- p_value.poissonmfx
#' @export
p_value.negbinmfx <- p_value.poissonmfx
#' @export
p_value.betaor <- function(model, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
p_value.betareg(model$fit, component = component, ...)
}
#' @export
p_value.betamfx <- function(model, component = "all", ...) {
parms <- insight::get_parameters(model, component = "all")
cs <- do.call(rbind, stats::coef(summary(model$fit)))
p <- c(as.vector(model$mfxest[, 4]), as.vector(cs[, 4]))
out <- .data_frame(
Parameter = parms$Parameter,
p = p,
Component = parms$Component
)
component <- insight::validate_argument(
component,
c("all", "conditional", "precision", "marginal")
)
if (component != "all") {
out <- out[out$Component == component, ]
}
out
}
# simulate model ------------------
#' @export
simulate_model.betaor <- function(model, iterations = 1000, component = "all", ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "precision")
)
simulate_model.betareg(model$fit,
iterations = iterations,
component = component,
...
)
}
#' @export
simulate_model.betamfx <- simulate_model.betaor
parameters/R/cluster_performance.R 0000644 0001762 0000144 00000005152 14717111737 017017 0 ustar ligges users #' Performance of clustering models
#'
#' Compute performance indices for clustering solutions.
#'
#' @inheritParams model_parameters.hclust
#'
#' @examples
#' # kmeans
#' model <- kmeans(iris[1:4], 3)
#' cluster_performance(model)
#'
#' # hclust
#' data <- iris[1:4]
#' model <- hclust(dist(data))
#' clusters <- cutree(model, 3)
#' cluster_performance(model, data, clusters)
#'
#' # Retrieve performance from parameters
#' params <- model_parameters(kmeans(iris[1:4], 3))
#' cluster_performance(params)
#' @export
cluster_performance <- function(model, ...) {
UseMethod("cluster_performance")
}
#' @export
cluster_performance.kmeans <- function(model, ...) {
out <- as.data.frame(model[c("totss", "betweenss", "tot.withinss")])
colnames(out) <- c("Sum_Squares_Total", "Sum_Squares_Between", "Sum_Squares_Within")
out$R2 <- out$Sum_Squares_Between / out$Sum_Squares_Total
row.names(out) <- NULL
class(out) <- c("performance_model", class(out))
out
}
#' @rdname cluster_performance
#' @export
cluster_performance.hclust <- function(model, data, clusters, ...) {
if (is.null(data)) {
insight::format_error(
"This function requires the data used to compute the clustering to be provided via `data` as it is not accessible from the clustering object itself."
)
}
if (is.null(clusters)) {
insight::format_error(
"This function requires a vector of clusters assignments of same length as data to be passed, as it is not contained in the clustering object itself."
)
}
params <- model_parameters(model, data = data, clusters = clusters, ...)
cluster_performance(params)
}
#' @export
cluster_performance.dbscan <- function(model, data, ...) {
if (is.null(data)) {
insight::format_error(
"This function requires the data used to compute the clustering to be provided via `data` as it is not accessible from the clustering object itself."
)
}
params <- model_parameters(model, data = data, ...)
cluster_performance(params)
}
# Base --------------------------------------------------------------------
#' @export
cluster_performance.parameters_clusters <- function(model, ...) {
valid <- model$Cluster != 0 & model$Cluster != "0" # Valid clusters
out <- data.frame(
Sum_Squares_Total = attributes(model)$Sum_Squares_Total,
Sum_Squares_Between = attributes(model)$Sum_Squares_Between,
Sum_Squares_Within = sum(model$Sum_Squares[valid], na.rm = TRUE)
)
out$R2 <- out$Sum_Squares_Between / out$Sum_Squares_Total
class(out) <- c("performance_model", class(out))
out
}
parameters/R/standard_error_satterthwaite.R 0000644 0001762 0000144 00000000407 14415527411 020727 0 ustar ligges users #' @rdname p_value_satterthwaite
#' @export
se_satterthwaite <- function(model) {
UseMethod("se_satterthwaite")
}
#' @export
se_satterthwaite.default <- function(model) {
# check for valid input
.is_model_valid(model)
standard_error(model)
}
parameters/R/print.compare_parameters.R 0000644 0001762 0000144 00000006766 14716604200 017764 0 ustar ligges users #' @title Print comparisons of model parameters
#' @name print.compare_parameters
#'
#' @description A `print()`-method for objects from [`compare_parameters()`].
#'
#' @param x An object returned by [`compare_parameters()`].
#' @param engine Character string, naming the package or engine to be used for
#' printing into HTML or markdown format. Currently supported `"gt"` (or
#' `"default"`) to use the *gt* package to print to HTML and the default easystats
#' engine to create markdown tables. If `engine = "tt"`, the *tinytable* package
#' is used for printing to HTML or markdown. Not all `print()` methods support
#' the `"tt"` engine yet. If a specific `print()` method has no `engine` argument,
#' `insight::export_table()` is used, which uses *gt* for HTML printing.
#' @inheritParams print.parameters_model
#' @inheritSection print.parameters_model Global Options to Customize Messages and Tables when Printing
#'
#' @return Invisibly returns the original input object.
#'
#' @examplesIf require("gt", quietly = TRUE)
#' \donttest{
#' data(iris)
#' lm1 <- lm(Sepal.Length ~ Species, data = iris)
#' lm2 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris)
#'
#' # custom style
#' result <- compare_parameters(lm1, lm2, select = "{estimate}{stars} ({se})")
#' print(result)
#'
#' # custom style, in HTML
#' result <- compare_parameters(lm1, lm2, select = "{estimate}
({se})|{p}")
#' print_html(result)
#' }
#' @export
print.compare_parameters <- function(x,
split_components = TRUE,
caption = NULL,
subtitle = NULL,
footer = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
zap_small = FALSE,
groups = NULL,
column_width = NULL,
ci_brackets = c("[", "]"),
select = NULL,
...) {
# save original input
orig_x <- x
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", p_digits)
}
# get attributes
if (missing(select)) {
select <- attributes(x)$output_style
}
if (missing(groups)) {
groups <- attributes(x)$parameter_groups
}
formatted_table <- format(
x,
select = select,
split_components = split_components,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
ci_width = "auto",
ci_brackets = ci_brackets,
format = "text",
groups = groups,
zap_small = zap_small,
...
)
# if we have multiple components, we can align colum width across components here
if (!is.null(column_width) && all(column_width == "fixed") && is.list(formatted_table)) {
column_width <- .find_min_colwidth(formatted_table)
}
cat(insight::export_table(
formatted_table,
format = "text",
caption = caption,
subtitle = subtitle,
footer = footer,
empty_line = "-",
width = column_width,
...
))
invisible(orig_x)
}
parameters/R/cluster_centers.R 0000644 0001762 0000144 00000010311 14473626002 016145 0 ustar ligges users #' Find the cluster centers in your data
#'
#' For each cluster, computes the mean (or other indices) of the variables. Can be used
#' to retrieve the centers of clusters. Also returns the within Sum of Squares.
#'
#' @param data A data.frame.
#' @param clusters A vector with clusters assignments (must be same length as rows in data).
#' @param fun What function to use, `mean` by default.
#' @param ... Other arguments to be passed to or from other functions.
#'
#' @return A dataframe containing the cluster centers. Attributes include
#' performance statistics and distance between each observation and its
#' respective cluster centre.
#'
#'
#' @examples
#' k <- kmeans(iris[1:4], 3)
#' cluster_centers(iris[1:4], clusters = k$cluster)
#' cluster_centers(iris[1:4], clusters = k$cluster, fun = median)
#' @export
cluster_centers <- function(data, clusters, fun = mean, ...) {
# Get n obs
params <- data.frame(table(clusters))
names(params) <- c("Cluster", "n_Obs")
# Get Within clusters sum of squares (WCSS)
ss <- .cluster_centers_SS(data, clusters)
params$Sum_Squares <- ss$WSS
# Get Cluster Centers
centers <- stats::aggregate(data, list(Cluster = clusters), fun)
params <- merge(params, centers, by = "Cluster")
# Get distance of observations from cluster
# Add attributes
attr(params, "Sum_Squares_Total") <- ss$TSS
attr(params, "Sum_Squares_Between") <- ss$BSS
attr(params, "variance") <- ss$BSS / ss$TSS
attr(params, "scale") <- vapply(data, stats::sd, numeric(1))
attr(params, "distance") <- .cluster_centers_distance(data, clusters, centers, attributes(params)$scale)
params
}
# Performance -------------------------------------------------------------
#' @keywords internal
.cluster_centers_params <- function(data, clusters, ...) {
# This function actually wraps *around* the exported cluster_centers()
# to be used within the different model_parameters() functions for clusters
params <- cluster_centers(data = data, clusters = clusters, ...)
# Long means
means <- datawizard::reshape_longer(params,
select = 4:ncol(params),
values_to = "Mean",
names_to = "Variable"
)
attr(params, "variance") <- attributes(params)$variance
attr(params, "Sum_Squares_Between") <- attributes(params)$Sum_Squares_Between
attr(params, "Sum_Squares_Total") <- attributes(params)$Sum_Squares_Total
attr(params, "scale") <- attributes(params)$scale
attr(params, "distance") <- attributes(params)$distance
attr(params, "scores") <- attributes(params)$scores
attr(params, "means") <- means
class(params) <- c("parameters_clusters", class(params))
params
}
# Distance ----------------------------------------------------------------
#' @keywords internal
.cluster_centers_distance <- function(data, clusters, centers, scale) {
dis <- NULL
for (c in unique(clusters)) {
center <- centers[centers$Cluster == c, ]
center$Cluster <- NULL # Remove column
d <- apply(data[clusters == c, ], 1, function(x) {
z <- x - center[names(data)]
z <- z / scale
sqrt(sum((z)^2))
})
dis <- c(dis, d)
}
dis
}
# Performance -------------------------------------------------------------
#' @keywords internal
.cluster_centers_SS <- function(data, clusters) {
# https://stackoverflow.com/questions/68714612/compute-between-clusters-sum-of-squares-bcss-and-total-sum-of-squares-manually
# total sum of squares
TSS <- sum(scale(data, scale = FALSE)^2)
# Within clusters sum of squares (WCSS)
WSS <- sapply(split(data, clusters), function(x) sum(scale(x, scale = FALSE)^2))
# Between clusters sum of squares
BSS <- TSS - sum(WSS)
# Compute BSS directly (without TSS to double check)
gmeans <- sapply(split(data, clusters), colMeans)
means <- colMeans(data)
BSS2 <- sum(colSums((gmeans - means)^2) * table(clusters))
# Double check
if (BSS2 - BSS > 1e-05) {
insight::format_error("The between sum of squares computation went wrong. Please open an issue at {.url https://github.com/easystats/parameters/issues} so we can fix the bug (provide an example and mention that `BSS != BSS2`).")
}
list(WSS = WSS, BSS = BSS, TSS = TSS)
}
parameters/R/convert_efa_to_cfa.R 0000644 0001762 0000144 00000007150 14736731407 016566 0 ustar ligges users #' Conversion between EFA results and CFA structure
#'
#' Enables a conversion between Exploratory Factor Analysis (EFA) and
#' Confirmatory Factor Analysis (CFA) `lavaan`-ready structure.
#'
#' @param model An EFA model (e.g., a `psych::fa` object).
#' @param names Vector containing dimension names.
#' @param max_per_dimension Maximum number of variables to keep per dimension.
#' @inheritParams principal_components
#'
#' @examplesIf require("psych") && require("lavaan")
#' \donttest{
#' library(parameters)
#' data(attitude)
#' efa <- psych::fa(attitude, nfactors = 3)
#'
#' model1 <- efa_to_cfa(efa)
#' model2 <- efa_to_cfa(efa, threshold = 0.3)
#' model3 <- efa_to_cfa(efa, max_per_dimension = 2)
#'
#' suppressWarnings(anova(
#' lavaan::cfa(model1, data = attitude),
#' lavaan::cfa(model2, data = attitude),
#' lavaan::cfa(model3, data = attitude)
#' ))
#' }
#' @return Converted index.
#' @export
convert_efa_to_cfa <- function(model, ...) {
UseMethod("convert_efa_to_cfa")
}
#' @rdname convert_efa_to_cfa
#' @inheritParams model_parameters.principal
#' @export
convert_efa_to_cfa.fa <- function(model,
threshold = "max",
names = NULL,
max_per_dimension = NULL,
...) {
.efa_to_cfa(model_parameters(model, threshold = threshold, ...),
names = names,
max_per_dimension = max_per_dimension,
...
)
}
#' @export
convert_efa_to_cfa.fa.ci <- convert_efa_to_cfa.fa
#' @export
convert_efa_to_cfa.parameters_efa <- function(model,
threshold = NULL,
names = NULL,
max_per_dimension = NULL,
...) {
if (!is.null(threshold)) {
model <- model_parameters(attributes(model)$model, threshold = threshold, ...)
}
.efa_to_cfa(model, names = names, max_per_dimension = max_per_dimension, ...)
}
#' @export
convert_efa_to_cfa.parameters_pca <- convert_efa_to_cfa.parameters_efa
#' @rdname convert_efa_to_cfa
#' @export
efa_to_cfa <- convert_efa_to_cfa
#' @keywords internal
.efa_to_cfa <- function(loadings, names = NULL, max_per_dimension = NULL, ...) {
loadings <- attributes(loadings)$loadings_long
# Get dimension names
if (is.null(names)) {
names <- unique(loadings$Component)
}
# Catch error
if (length(names) != insight::n_unique(loadings$Component)) {
insight::format_error(
paste0(
"The `names` vector must be of same length as the number of dimensions, in this case ",
length(unique(loadings$Component)),
"."
)
)
}
cfa <- NULL
# Iterate over dimensions
for (i in seq_along(names)) {
# Find correct subset
items <- loadings[loadings$Component == unique(loadings$Component)[i], ]
# Find corresponding items
items <- as.character(loadings[loadings$Component == unique(loadings$Component)[i], "Variable"])
# Subset if need be to keep only a certain number
if (!is.null(max_per_dimension) && max_per_dimension > 0) {
items <- as.character(stats::na.omit(items[1:max_per_dimension]))
}
# Append that list
cfa <- c(cfa, paste0(names[i], " =~ ", paste(items, collapse = " + ")))
}
cfa <- paste0(cfa, collapse = "\n")
cfa <- paste0("# Latent variables\n", cfa)
class(cfa) <- c("cfa_model", class(cfa))
cfa
}
#' @export
print.cfa_model <- function(x, ...) {
cat(x)
invisible(x)
}
parameters/R/methods_bamlss.R 0000644 0001762 0000144 00000004531 14717111737 015761 0 ustar ligges users #' @export
model_parameters.bamlss <- function(model,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
component = "all",
exponentiate = FALSE,
standardize = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
# Processing
params <- .extract_parameters_bayesian(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = NULL,
diagnostic = NULL,
priors = FALSE,
effects = "all",
component = component,
standardize = standardize,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
params <- .add_pretty_names(params, model)
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(params,
model,
ci,
exponentiate,
ci_method = ci_method,
verbose = verbose,
...
)
attr(params, "parameter_info") <- insight::clean_parameters(model)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- unique(c("parameters_model", "see_parameters_model", class(params)))
params
}
#' @export
standard_error.bamlss <- function(model,
component = c("all", "conditional", "location", "distributional", "auxilliary"),
...) {
component <- match.arg(component)
params <- insight::get_parameters(model, component = component, ...)
.data_frame(
Parameter = colnames(params),
SE = unname(sapply(params, stats::sd, na.rm = TRUE))
)
}
#' @export
p_value.bamlss <- p_value.BFBayesFactor
parameters/R/5_simulate_model.R 0000644 0001762 0000144 00000017317 14736731407 016215 0 ustar ligges users #' @title Simulated draws from model coefficients
#' @name simulate_model
#'
#' @description Simulate draws from a statistical model to return a data frame
#' of estimates.
#'
#' @param model Statistical model (no Bayesian models).
#' @param component Should all parameters, parameters for the conditional model,
#' for the zero-inflation part of the model, or the dispersion model be returned?
#' Applies to models with zero-inflation and/or dispersion component. `component`
#' may be one of `"conditional"`, `"zi"`, `"zero-inflated"`, `"dispersion"` or
#' `"all"` (default). May be abbreviated.
#' @param ... Arguments passed to [`insight::get_varcov()`], e.g. to allow simulated
#' draws to be based on heteroscedasticity consistent variance covariance matrices.
#' @inheritParams bootstrap_model
#' @inheritParams p_value
#'
#' @inheritSection model_parameters.zcpglm Model components
#'
#' @return A data frame.
#'
#' @seealso [`simulate_parameters()`], [`bootstrap_model()`], [`bootstrap_parameters()`]
#'
#' @details
#' ## Technical Details
#' `simulate_model()` is a computationally faster alternative
#' to `bootstrap_model()`. Simulated draws for coefficients are based
#' on a multivariate normal distribution (`MASS::mvrnorm()`) with mean
#' `mu = coef(model)` and variance `Sigma = vcov(model)`.
#'
#' ## Models with Zero-Inflation Component
#' For models from packages **glmmTMB**, **pscl**, **GLMMadaptive** and
#' **countreg**, the `component` argument can be used to specify
#' which parameters should be simulated. For all other models, parameters
#' from the conditional component (fixed effects) are simulated. This may
#' include smooth terms, but not random effects.
#'
#' @examples
#' model <- lm(Sepal.Length ~ Species * Petal.Width + Petal.Length, data = iris)
#' head(simulate_model(model))
#' \donttest{
#' if (require("glmmTMB", quietly = TRUE)) {
#' model <- glmmTMB(
#' count ~ spp + mined + (1 | site),
#' ziformula = ~mined,
#' family = poisson(),
#' data = Salamanders
#' )
#' head(simulate_model(model))
#' head(simulate_model(model, component = "zero_inflated"))
#' }
#' }
#' @export
simulate_model <- function(model, iterations = 1000, ...) {
UseMethod("simulate_model")
}
# Models with single component only -----------------------------------------
#' @rdname simulate_model
#' @export
simulate_model.default <- function(model, iterations = 1000, component = "all", ...) {
# check for valid input
.is_model_valid(model)
out <- .simulate_model(model, iterations, component = "conditional", effects = "fixed", ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
simulate_model.lm <- simulate_model.default
#' @export
simulate_model.glmmadmb <- simulate_model.default
#' @export
simulate_model.cglm <- simulate_model.default
#' @export
simulate_model.cpglm <- simulate_model.default
#' @export
simulate_model.cpglmm <- simulate_model.default
#' @export
simulate_model.feglm <- simulate_model.default
#' @export
simulate_model.fixest <- simulate_model.default
#' @export
simulate_model.iv_robust <- simulate_model.default
#' @export
simulate_model.rq <- simulate_model.default
#' @export
simulate_model.crq <- simulate_model.default
#' @export
simulate_model.nlrq <- simulate_model.default
#' @export
simulate_model.speedglm <- simulate_model.default
#' @export
simulate_model.speedlm <- simulate_model.default
#' @export
simulate_model.glm <- simulate_model.default
#' @export
simulate_model.glmRob <- simulate_model.default
#' @export
simulate_model.lmRob <- simulate_model.default
#' @export
simulate_model.gls <- simulate_model.default
#' @export
simulate_model.lme <- simulate_model.default
#' @export
simulate_model.crch <- simulate_model.default
#' @export
simulate_model.biglm <- simulate_model.default
#' @export
simulate_model.plm <- simulate_model.default
#' @export
simulate_model.flexsurvreg <- simulate_model.default
#' @export
simulate_model.LORgee <- simulate_model.default
#' @export
simulate_model.feis <- simulate_model.default
#' @export
simulate_model.lmrob <- simulate_model.default
#' @export
simulate_model.glmrob <- simulate_model.default
#' @export
simulate_model.merMod <- simulate_model.default
#' @export
simulate_model.gamlss <- simulate_model.default
#' @export
simulate_model.lm_robust <- simulate_model.default
#' @export
simulate_model.coxme <- simulate_model.default
#' @export
simulate_model.geeglm <- simulate_model.default
#' @export
simulate_model.gee <- simulate_model.default
#' @export
simulate_model.clm <- simulate_model.default
#' @export
simulate_model.polr <- simulate_model.default
#' @export
simulate_model.coxph <- simulate_model.default
#' @export
simulate_model.logistf <- simulate_model.default
#' @export
simulate_model.flic <- simulate_model.default
#' @export
simulate_model.flac <- simulate_model.default
#' @export
simulate_model.truncreg <- simulate_model.default
#' @export
simulate_model.glimML <- simulate_model.default
#' @export
simulate_model.lrm <- simulate_model.default
#' @export
simulate_model.psm <- simulate_model.default
#' @export
simulate_model.ols <- simulate_model.default
#' @export
simulate_model.rms <- simulate_model.default
#' @export
simulate_model.vglm <- simulate_model.default
#' @export
simulate_model.censReg <- simulate_model.default
#' @export
simulate_model.survreg <- simulate_model.default
#' @export
simulate_model.multinom <- simulate_model.default
#' @export
simulate_model.brmultinom <- simulate_model.default
#' @export
simulate_model.bracl <- simulate_model.default
# helper -----------------------------------------
.simulate_model <- function(model,
iterations,
component = "conditional",
effects = "fixed",
...) {
if (is.null(iterations)) iterations <- 1000
params <- insight::get_parameters(model, effects = effects, component = component, verbose = FALSE)
beta_mu <- stats::setNames(params$Estimate, params$Parameter) # Transform to named vector
# "..." allow specification of vcov-args (#784)
varcov <- insight::get_varcov(model, component = component, effects = effects, ...)
as.data.frame(.mvrnorm(n = iterations, mu = beta_mu, Sigma = varcov))
## Alternative approach, similar to arm::sim()
# k <- length(insight::find_parameters(model, effects = "fixed", component = "conditional", flatten = TRUE))
# n <- insight::n_obs(model)
# beta.cov <- stats::vcov(model) / stats::sigma(model)
# s <- vector("double", iterations)
# b <- array(NA, c(100, k))
# for (i in 1:iterations) {
# s[i] <- stats::sigma(model) * sqrt((n - k) / rchisq(1, n - k))
# b[i,] <- .mvrnorm(n = 1, mu = beta_mu, Sigma = beta.cov * s[i] ^ 2)
# }
}
.mvrnorm <- function(n = 1, mu, Sigma, tol = 1e-06) {
p <- length(mu)
if (!all(dim(Sigma) == c(p, p))) {
insight::format_error(
"Incompatible arguments to calculate multivariate normal distribution."
)
}
eS <- eigen(Sigma, symmetric = TRUE)
ev <- eS$values
if (!all(ev >= -tol * abs(ev[1L]))) {
insight::format_error("`Sigma` is not positive definite.")
}
X <- drop(mu) + eS$vectors %*% diag(sqrt(pmax(ev, 0)), p) %*% t(matrix(stats::rnorm(p * n), n))
nm <- names(mu)
dn <- dimnames(Sigma)
if (is.null(nm) && !is.null(dn)) {
nm <- dn[[1L]]
}
dimnames(X) <- list(nm, NULL)
if (n == 1) {
drop(X)
} else {
t(X)
}
}
parameters/R/methods_weightit.R 0000644 0001762 0000144 00000001200 14716604200 016301 0 ustar ligges users # model parameters -------------------
#' @export
model_parameters.ordinal_weightit <- model_parameters.clm2
#' @export
model_parameters.multinom_weightit <- model_parameters.bracl
# CI ---------------------
#' @export
ci.ordinal_weightit <- ci.clm2
#' @export
ci.multinom_weightit <- ci.bracl
# standard errors -----------------
#' @export
standard_error.ordinal_weightit <- standard_error.clm2
#' @export
standard_error.multinom_weightit <- standard_error.bracl
# p values ----------------
#' @export
p_value.ordinal_weightit <- p_value.clm2
#' @export
p_value.multinom_weightit <- p_value.bracl
parameters/R/methods_svy2lme.R 0000644 0001762 0000144 00000005540 14761570351 016102 0 ustar ligges users #' @export
model_parameters.svy2lme <- function(model,
ci = 0.95,
effects = "all",
include_sigma = FALSE,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
dots <- list(...)
# which component to return?
effects <- match.arg(effects, choices = c("fixed", "random", "all"))
params <- params_variance <- NULL
if (effects %in% c("fixed", "all")) {
# Processing
fun_args <- list(
model,
ci = ci,
ci_method = "wald",
standardize = NULL,
p_adjust = NULL,
wb_component = FALSE,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
include_sigma = include_sigma,
include_info = FALSE,
vcov = NULL,
vcov_args = NULL
)
fun_args <- c(fun_args, dots)
params <- do.call(".extract_parameters_mixed", fun_args)
params$Effects <- "fixed"
}
att <- attributes(params)
if (effects %in% c("random", "all")) {
params_variance <- .extract_random_variances(
model,
ci = ci,
effects = effects
)
}
# merge random and fixed effects, if necessary
if (!is.null(params) && !is.null(params_variance)) {
params$Level <- NA
params$Group <- ""
params <- params[match(colnames(params_variance), colnames(params))]
}
params <- rbind(params, params_variance)
# remove empty column
if (!is.null(params$Level) && all(is.na(params$Level))) {
params$Level <- NULL
}
# due to rbind(), we lose attributes from "extract_parameters()",
# so we add those attributes back here...
if (!is.null(att)) {
attributes(params) <- utils::modifyList(att, attributes(params))
}
params <- .add_model_parameters_attributes(
params,
model,
ci = ci,
exponentiate = FALSE,
bootstrap = FALSE,
iterations = 1000,
ci_method = "wald",
p_adjust = NULL,
verbose = verbose,
include_info = FALSE,
group_level = FALSE,
wb_component = FALSE,
...
)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- c("parameters_model", "see_parameters_model", class(params))
params
}
#' @export
standard_error.svy2lme <- function(model, ...) {
.data_frame(
Parameter = .remove_backticks_from_string(colnames(model$Vbeta)),
SE = as.vector(sqrt(diag(model$Vbeta)))
)
}
#' @export
p_value.svy2lme <- function(model, ...) {
stat <- insight::get_statistic(model)
p <- 2 * stats::pnorm(abs(stat$Statistic), lower.tail = FALSE)
.data_frame(
Parameter = stat$Parameter,
p = as.vector(p)
)
}
parameters/R/methods_bggm.R 0000644 0001762 0000144 00000000164 14030655331 015401 0 ustar ligges users #' @export
model_parameters.BGGM <- model_parameters.bayesQR
#' @export
p_value.BGGM <- p_value.BFBayesFactor
parameters/R/methods_gamm4.R 0000644 0001762 0000144 00000000654 14355245205 015503 0 ustar ligges users #' @export
ci.gamm4 <- function(x, ci = 0.95, ...) {
x <- x$gam
class(x) <- c("gam", "lm", "glm")
ci(x, ci = ci, ...)
}
#' @export
standard_error.gamm4 <- function(model, ...) {
model <- model$gam
class(model) <- c("gam", "lm", "glm")
standard_error(model)
}
#' @export
p_value.gamm4 <- function(model, ...) {
model <- model$gam
class(model) <- c("gam", "lm", "glm")
p_value(model)
}
parameters/R/methods_brms.R 0000644 0001762 0000144 00000026420 14761600422 015435 0 ustar ligges users #' @title Parameters from Bayesian Models
#' @name model_parameters.brmsfit
#'
#' @description
#' Model parameters from Bayesian models. This function internally calls
#' [`bayestestR::describe_posterior()`] to get the relevant information for
#' the output.
#'
#' @param model Bayesian model (including SEM from **blavaan**. May also be
#' a data frame with posterior samples, however, `as_draws` must be set to
#' `TRUE` (else, for data frames `NULL` is returned).
#' @param ci Credible Interval (CI) level. Default to `0.95` (`95%`). See
#' [bayestestR::ci()] for further details.
#' @param group_level Logical, for multilevel models (i.e. models with random
#' effects) and when `effects = "all"` or `effects = "random"`,
#' include the parameters for each group level from random effects. If
#' `group_level = FALSE` (the default), only information on SD and COR
#' are shown.
#' @param component Which type of parameters to return, such as parameters for the
#' conditional model, the zero-inflation part of the model, the dispersion
#' term, or other auxiliary parameters be returned? Applies to models with
#' zero-inflation and/or dispersion formula, or if parameters such as `sigma`
#' should be included. May be abbreviated. Note that the *conditional*
#' component is also called *count* or *mean* component, depending on the
#' model. There are three convenient shortcuts: `component = "all"` returns
#' all possible parameters. If `component = "location"`, location parameters
#' such as `conditional`, `zero_inflated`, or `smooth_terms`, are returned
#' (everything that are fixed or random effects - depending on the `effects`
#' argument - but no auxiliary parameters). For `component = "distributional"`
#' (or `"auxiliary"`), components like `sigma`, `dispersion`, or `beta`
#' (and other auxiliary parameters) are returned.
#' @param as_draws Logical, if `TRUE` and `model` is of class `data.frame`,
#' the data frame is treated as posterior samples and handled similar to
#' Bayesian models. All arguments in `...` are passed to
#' `model_parameters.draws()`.
#' @inheritParams model_parameters.default
#' @inheritParams bayestestR::describe_posterior
#' @inheritParams insight::get_parameters
#'
#' @seealso [insight::standardize_names()] to rename columns into a consistent,
#' standardized naming scheme.
#'
#' @note When `standardize = "refit"`, columns `diagnostic`, `bf_prior` and
#' `priors` refer to the *original* `model`. If `model` is a data frame,
#' arguments `diagnostic`, `bf_prior` and `priors` are ignored.
#'
#' There is also a
#' [`plot()`-method](https://easystats.github.io/see/articles/parameters.html)
#' implemented in the [**see**-package](https://easystats.github.io/see/).
#'
#' @inheritSection model_parameters Confidence intervals and approximation of degrees of freedom
#'
#' @inheritSection model_parameters.zcpglm Model components
#'
#' @examplesIf require("rstanarm")
#' \donttest{
#' library(parameters)
#' model <- suppressWarnings(stan_glm(
#' Sepal.Length ~ Petal.Length * Species,
#' data = iris, iter = 500, refresh = 0
#' ))
#' model_parameters(model)
#' }
#' @return A data frame of indices related to the model's parameters.
#' @export
model_parameters.brmsfit <- function(model,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
bf_prior = NULL,
diagnostic = c("ESS", "Rhat"),
priors = FALSE,
effects = "fixed",
component = "all",
exponentiate = FALSE,
standardize = NULL,
group_level = FALSE,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
modelinfo <- insight::model_info(model, verbose = FALSE)
# Bayesian meta analysis
if (!insight::is_multivariate(model) && isTRUE(modelinfo$is_meta)) {
params <- .model_parameters_brms_meta(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
diagnostic = diagnostic,
priors = priors,
exponentiate = exponentiate,
standardize = standardize,
keep_parameters = keep,
drop_parameters = drop,
...
)
} else if (effects %in% c("total", "random_total")) {
# group level total effects (coef())
params <- .group_level_total(model, centrality, dispersion, ci, ci_method, test, rope_range, rope_ci, ...)
params$Effects <- "total"
class(params) <- c("parameters_coef", "see_parameters_coef", class(params))
return(params)
} else {
# Processing
params <- .extract_parameters_bayesian(
model,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
bf_prior = bf_prior,
diagnostic = diagnostic,
priors = priors,
effects = effects,
component = component,
standardize = standardize,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
if (!(effects == "fixed" && component == "conditional")) {
random_effect_levels <- which(params$Effects == "random" & grepl("^(?!sd_|cor_)(.*)", params$Parameter, perl = TRUE) & !(params$Parameter %in% c("car", "sdcar")))
if (length(random_effect_levels) && isFALSE(group_level)) params <- params[-random_effect_levels, ]
}
# add prettified names as attribute. Furthermore, group column is added
params <- .add_pretty_names(params, model)
# exponentiate coefficients and SE/CI, if requested
params <- .exponentiate_parameters(params, model, exponentiate)
params <- .add_model_parameters_attributes(params,
model,
ci,
exponentiate,
ci_method = ci_method,
group_level = group_level,
verbose = verbose,
...
)
attr(params, "parameter_info") <- insight::clean_parameters(model)
attr(params, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(params) <- unique(c("parameters_model", "see_parameters_model", class(params)))
}
params
}
# brms meta analysis -------
.model_parameters_brms_meta <- function(model,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = "pd",
rope_range = "default",
rope_ci = 0.95,
diagnostic = c("ESS", "Rhat"),
priors = FALSE,
exponentiate = FALSE,
standardize = NULL,
keep_parameters = NULL,
drop_parameters = NULL,
verbose = TRUE,
...) {
# parameters
smd <- insight::get_parameters(model, effects = "fixed", component = "conditional")
studies <- insight::get_parameters(model, effects = "random", parameters = "^(?!sd_)")
studies[] <- lapply(studies, function(i) i + smd[[1]])
tau <- insight::get_parameters(model, effects = "random", parameters = "^sd_")
params <- bayestestR::describe_posterior(
cbind(studies, smd),
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
...
)
params_diagnostics <- bayestestR::diagnostic_posterior(
model,
effects = "all",
diagnostic = diagnostic,
...
)
params_tau <- bayestestR::describe_posterior(
tau,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
rope_range = rope_range,
rope_ci = rope_ci,
...
)
# add weights
params$Weight <- 1 / c(insight::get_response(model)[[2]], NA)
# merge description with diagnostic
params <- merge(params, params_diagnostics, by = "Parameter", all.x = TRUE, sort = FALSE)
# Renaming
re_name <- insight::find_random(model, flatten = TRUE)
study_names <- gsub(sprintf("r_%s\\[(.*)\\]", re_name[1]), "\\1", colnames(studies))
# replace dots by white space
study_names <- gsub(".", " ", study_names, fixed = TRUE)
# remove "Intercept"
study_names <- insight::trim_ws(gsub(",Intercept", "", study_names, fixed = TRUE))
cleaned_parameters <- c(study_names, "Overall", "tau")
# components
params$Component <- "Studies"
params_tau$Component <- "tau"
# merge with tau
params <- merge(params, params_tau, all = TRUE, sort = FALSE)
# reorder columns
ci_column <- which(colnames(params) == "CI_high")
weight_column <- which(colnames(params) == "Weight")
first_cols <- c(1:ci_column, weight_column)
params <- params[, c(first_cols, seq_len(ncol(params))[-first_cols])]
# filter parameters, if requested
if (!is.null(keep_parameters) || !is.null(drop_parameters)) {
params <- .filter_parameters(params,
keep = keep_parameters,
drop = drop_parameters,
verbose = verbose
)
}
# add attributes
attr(params, "tau") <- params_tau
attr(params, "pretty_names") <- cleaned_parameters
attr(params, "cleaned_parameters") <- cleaned_parameters
attr(params, "ci") <- ci
attr(params, "ci_method") <- ci_method
attr(params, "exponentiate") <- exponentiate
attr(params, "model_class") <- class(model)
attr(params, "is_bayes_meta") <- TRUE
attr(params, "study_weights") <- params$Weight
attr(params, "data") <- cbind(studies, smd, tau)
class(params) <- unique(c("parameters_brms_meta", "see_parameters_brms_meta", class(params)))
params
}
#' @export
standard_error.brmsfit <- function(model,
effects = "fixed",
component = "all",
...) {
effects <- insight::validate_argument(
effects,
c("fixed", "random")
)
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated")
)
params <- insight::get_parameters(model, effects = effects, component = component, ...)
.data_frame(
Parameter = colnames(params),
SE = unname(sapply(params, stats::sd, na.rm = TRUE))
)
}
#' @export
p_value.brmsfit <- p_value.BFBayesFactor
parameters/R/methods_mixor.R 0000644 0001762 0000144 00000005626 14507235543 015643 0 ustar ligges users #' @export
model_parameters.mixor <- function(model,
ci = 0.95,
effects = "all",
bootstrap = FALSE,
iterations = 1000,
standardize = NULL,
exponentiate = FALSE,
include_sigma = FALSE,
p_adjust = NULL,
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
# standardize only works for fixed effects...
if (!is.null(standardize) && standardize != "refit") {
if (!missing(effects) && effects != "fixed" && verbose) {
insight::format_warning(
"Standardizing coefficients only works for fixed effects of the mixed model."
)
}
effects <- "fixed"
}
out <- .model_parameters_generic(
model = model,
ci = ci,
bootstrap = bootstrap,
iterations = iterations,
merge_by = c("Parameter", "Effects"),
standardize = standardize,
exponentiate = exponentiate,
effects = effects,
include_sigma = include_sigma,
keep_parameters = keep,
drop_parameters = drop,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
ci.mixor <- function(x, ci = 0.95, effects = "all", ...) {
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
.ci_generic(model = x, ci = ci, dof = Inf, effects = effects, ...)
}
#' @export
standard_error.mixor <- function(model, effects = "all", ...) {
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
stats <- model$Model[, "Std. Error"]
parms <- insight::get_parameters(model, effects = effects)
.data_frame(
Parameter = parms$Parameter,
SE = stats[parms$Parameter],
Effects = parms$Effects
)
}
#' @export
p_value.mixor <- function(model, effects = "all", ...) {
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
stats <- model$Model[, "P(>|z|)"]
parms <- insight::get_parameters(model, effects = effects)
.data_frame(
Parameter = parms$Parameter,
p = stats[parms$Parameter],
Effects = parms$Effects
)
}
#' @export
simulate_model.mixor <- function(model, iterations = 1000, effects = "all", ...) {
effects <- match.arg(effects, choices = c("all", "fixed", "random"))
out <- .simulate_model(model, iterations, component = "conditional", effects = effects, ...)
class(out) <- c("parameters_simulate_model", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
parameters/R/standard_error_kenward.R 0000644 0001762 0000144 00000000505 14037763760 017502 0 ustar ligges users #' @rdname p_value_kenward
#' @export
se_kenward <- function(model) {
.check_REML_fit(model)
vcov_adj <- .vcov_kenward_ajusted(model)
params <- insight::get_parameters(model, effects = "fixed")
.data_frame(
Parameter = params$Parameter,
SE = abs(as.vector(sqrt(diag(as.matrix(vcov_adj)))))
)
}
parameters/R/methods_robmixglm.R 0000644 0001762 0000144 00000000575 14355245205 016500 0 ustar ligges users #' @export
standard_error.robmixglm <- function(model, ...) {
se <- stats::na.omit(.get_se_from_summary(model))
.data_frame(
Parameter = names(se),
SE = as.vector(se)
)
}
#' @export
p_value.robmixglm <- function(model, ...) {
p <- stats::na.omit(.get_pval_from_summary(model))
.data_frame(
Parameter = names(p),
p = as.vector(p)
)
}
parameters/R/methods_lqmm.R 0000644 0001762 0000144 00000005723 14736731407 015455 0 ustar ligges users #' @export
model_parameters.lqmm <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
p_adjust = NULL,
verbose = TRUE,
...) {
# Processing
if (bootstrap) {
parameters <- bootstrap_parameters(
model,
iterations = iterations,
ci = ci,
...
)
} else {
parameters <- .extract_parameters_lqmm(
model,
ci = ci,
p_adjust = p_adjust,
verbose = verbose,
...
)
}
parameters <- .add_model_parameters_attributes(
parameters,
model,
ci,
exponentiate = FALSE,
p_adjust = p_adjust,
verbose = verbose,
...
)
attr(parameters, "object_name") <- insight::safe_deparse_symbol(substitute(model))
class(parameters) <- c("parameters_model", "see_parameters_model", class(parameters))
parameters
}
#' @export
model_parameters.lqm <- model_parameters.lqmm
#' @export
ci.lqmm <- function(x, ...) {
out <- model_parameters(x, ...)
as.data.frame(out[c("Parameter", "CI_low", "CI_high")])
}
#' @export
ci.lqm <- ci.lqmm
#' @export
standard_error.lqmm <- function(model, ...) {
out <- model_parameters(model, ...)
as.data.frame(out[c("Parameter", "SE")])
}
#' @export
standard_error.lqm <- standard_error.lqmm
#' @export
p_value.lqmm <- function(model, ...) {
out <- model_parameters(model, ...)
as.data.frame(out[c("Parameter", "p")])
}
#' @export
p_value.lqm <- p_value.lqmm
# helper ------------------
.extract_parameters_lqmm <- function(model, ci, p_adjust, verbose = TRUE, ...) {
cs <- summary(model)
parameters <- insight::get_parameters(model)
if (is.list(cs$tTable)) {
summary_table <- do.call(rbind, cs$tTable)
} else {
summary_table <- cs$tTable
}
# ==== Coefficient, SE and test statistic
parameters$Coefficient <- parameters$Estimate
parameters$SE <- summary_table[, 2]
parameters$t <- parameters$Estimate / parameters$SE
# ==== DF
parameters$df_error <- tryCatch(
{
if (!is.null(cs$rdf)) {
cs$rdf
} else {
attr(cs$B, "R") - 1
}
},
error = function(e) {
Inf
}
)
# ==== Conf Int
parameters$CI_low <- parameters$Coefficient - stats::qt((1 + ci) / 2, df = parameters$df_error) * parameters$SE
parameters$CI_high <- parameters$Coefficient + stats::qt((1 + ci) / 2, df = parameters$df_error) * parameters$SE
# ==== p-value
parameters$p <- summary_table[, 5]
if (!is.null(p_adjust)) {
parameters <- .p_adjust(parameters, p_adjust, model, verbose)
}
# ==== Reorder
col_order <- c("Parameter", "Coefficient", "SE", "CI_low", "CI_high", "t", "df_error", "p", "Component")
parameters[col_order[col_order %in% names(parameters)]]
}
parameters/R/methods_sarlm.R 0000644 0001762 0000144 00000001235 14317274256 015616 0 ustar ligges users #' @export
p_value.Sarlm <- function(model, ...) {
stat <- insight::get_statistic(model)
.data_frame(
Parameter = stat$Parameter,
p = 2 * stats::pnorm(abs(stat$Statistic), lower.tail = FALSE)
)
}
#' @export
ci.Sarlm <- function(x, ci = 0.95, ...) {
.ci_generic(model = x, ci = ci, ...)
}
#' @export
standard_error.Sarlm <- function(model, ...) {
params <- insight::get_parameters(model)
s <- summary(model)
# add rho, if present
if (!is.null(s$rho)) {
rho <- as.numeric(s$rho.se)
} else {
rho <- NULL
}
.data_frame(
Parameter = params$Parameter,
SE = c(rho, as.vector(s$Coef[, 2]))
)
}
parameters/R/format_parameters.R 0000644 0001762 0000144 00000040263 14736731407 016475 0 ustar ligges users #' @title Parameter names formatting
#' @name format_parameters
#'
#' @description This functions formats the names of model parameters (coefficients)
#' to make them more human-readable.
#'
#' @param model A statistical model.
#' @param brackets A character vector of length two, indicating the opening and closing brackets.
#' @param ... Currently not used.
#'
#' @section Interpretation of Interaction Terms:
#' Note that the *interpretation* of interaction terms depends on many
#' characteristics of the model. The number of parameters, and overall
#' performance of the model, can differ *or not* between `a * b`,
#' `a : b`, and `a / b`, suggesting that sometimes interaction terms
#' give different parameterizations of the same model, but other times it gives
#' completely different models (depending on `a` or `b` being factors
#' of covariates, included as main effects or not, etc.). Their interpretation
#' depends of the full context of the model, which should not be inferred
#' from the parameters table alone - rather, we recommend to use packages
#' that calculate estimated marginal means or marginal effects, such as
#' \CRANpkg{modelbased}, \CRANpkg{emmeans}, \CRANpkg{ggeffects}, or
#' \CRANpkg{marginaleffects}. To raise awareness for this issue, you may use
#' `print(...,show_formula=TRUE)` to add the model-specification to the output
#' of the [`print()`][print.parameters_model] method for `model_parameters()`.
#'
#' @examples
#' model <- lm(Sepal.Length ~ Species * Sepal.Width, data = iris)
#' format_parameters(model)
#'
#' model <- lm(Sepal.Length ~ Petal.Length + (Species / Sepal.Width), data = iris)
#' format_parameters(model)
#'
#' model <- lm(Sepal.Length ~ Species + poly(Sepal.Width, 2), data = iris)
#' format_parameters(model)
#'
#' model <- lm(Sepal.Length ~ Species + poly(Sepal.Width, 2, raw = TRUE), data = iris)
#' format_parameters(model)
#' @return A (names) character vector with formatted parameter names. The value
#' names refer to the original names of the coefficients.
#' @export
format_parameters <- function(model, ...) {
UseMethod("format_parameters")
}
#' @rdname format_parameters
#' @export
format_parameters.default <- function(model, brackets = c("[", "]"), ...) {
# check for valid input
.is_model_valid(model)
.safe(.format_parameter_default(model, brackets = brackets, ...))
}
#' @export
format_parameters.parameters_model <- function(model, ...) {
if (!is.null(attributes(model)$pretty_names)) {
model$Parameter <- attributes(model)$pretty_names[model$Parameter]
}
model
}
# Utilities ---------------------------------------------------------------
.format_parameter_default <- function(model, effects = "fixed", brackets = c("[", "]"), ...) {
original_names <- parameter_names <- insight::find_parameters(model, effects = effects, flatten = TRUE)
# save some time, if model info is passed as argument
dot_args <- list(...)
if (is.null(dot_args$model_info)) {
info <- insight::model_info(model, verbose = FALSE)
} else {
info <- dot_args$model_info
}
## TODO remove is.list() when insight 0.8.3 on CRAN
if (is.null(info) || !is.list(info)) {
info <- list(family = "unknown", link_function = "unknown")
}
# quick fix, for multivariate response models, we use
# info from first model only
if (insight::is_multivariate(model) && !"is_zero_inflated" %in% names(info) && !inherits(model, c("vgam", "vglm"))) {
info <- info[[1]]
}
# Type-specific changes
types <- parameters_type(model)
if (is.null(types)) {
return(NULL)
}
types$Parameter <- .clean_parameter_names(types$Parameter, full = TRUE)
# special handling hurdle- and zeroinfl-models ---------------------
if (isTRUE(info$is_zero_inflated) || isTRUE(info$is_hurdle)) {
parameter_names <- gsub("^(count_|zero_)", "", parameter_names)
types$Parameter <- gsub("^(count_|zero_)", "", types$Parameter)
}
# special handling polr ---------------------
if (inherits(model, "polr")) {
original_names <- gsub("Intercept: ", "", original_names, fixed = TRUE)
parameter_names <- gsub("Intercept: ", "", parameter_names, fixed = TRUE)
}
# special handling bracl ---------------------
if (inherits(model, "bracl")) {
parameter_names <- gsub("(.*):(.*)", "\\2", parameter_names)
}
# special handling DirichletRegModel ---------------------
dirich_names <- NULL
if (inherits(model, "DirichletRegModel")) {
cf <- stats::coef(model)
if (model$parametrization == "common") {
pattern <- paste0("(", paste(model$varnames, collapse = "|"), ")\\.(.*)")
dirich_names <- parameter_names <- gsub(pattern, "\\2", names(unlist(cf)))
} else {
dirich_names <- parameter_names <- gsub("(.*)\\.(.*)\\.(.*)", "\\3", names(unlist(cf)))
}
original_names <- parameter_names
if (!is.null(dirich_names)) {
types$Parameter <- dirich_names
}
}
# remove "as.factor()", "log()" etc. from parameter names
parameter_names <- .clean_parameter_names(parameter_names)
for (i in seq_len(nrow(types))) {
name <- types$Parameter[i]
if (types$Type[i] %in% c("interaction", "nested", "simple")) {
# Interaction or nesting
# for "serp" models, coefficients end with ":1", ":2", etc. - we need
# to take this into account when splitting the name into components.
if (inherits(model, "serp")) {
pattern <- "(:(?![0-9]+$))"
components <- unlist(strsplit(name, pattern, perl = TRUE), use.names = FALSE)
} else {
components <- unlist(strsplit(name, ":", fixed = TRUE), use.names = FALSE)
}
is_nested <- types$Type[i] == "nested"
is_simple <- types$Type[i] == "simple"
for (j in seq_along(components)) {
if (components[j] %in% types$Parameter) {
type <- types[types$Parameter == components[j], ]
## TODO check if this is ok...
# for models with multiple response categories, we might have same
# variable for each response, thus we have multiple rows here,
# where only one row is required.
if (nrow(type) > 1) type <- type[1, ]
components[j] <- .format_parameter(
components[j],
variable = type$Variable,
type = type$Type,
level = type$Level,
brackets = brackets
)
} else if (components[j] %in% types$Secondary_Parameter) {
type <- types[!is.na(types$Secondary_Parameter) & types$Secondary_Parameter == components[j], ]
components[j] <- .format_parameter(
components[j],
variable = type[1, ]$Secondary_Variable,
type = type[1, ]$Secondary_Type,
level = type[1, ]$Secondary_Level,
brackets = brackets
)
}
}
parameter_names[i] <- .format_interaction(
components = components,
type = types[i, "Type"],
is_nested = is_nested,
is_simple = is_simple,
...
)
} else {
# No interaction
type <- types[i, ]
parameter_names[i] <- .format_parameter(
name,
variable = type$Variable,
type = type$Type,
level = type$Level,
brackets = brackets
)
}
}
# do some final formatting, like replacing underscores or dots with whitespace.
parameter_names <- gsub("(\\.|_)(?![^\\[]*\\])", " ", parameter_names, perl = TRUE)
# remove double spaces
parameter_names <- gsub(" ", " ", parameter_names, fixed = TRUE)
# "types$Parameter" here is cleaned, i.e. patterns like "log()", "as.factor()"
# etc. are removed. However, these patterns are needed in "format_table()",
# code-line x$Parameter <- attributes(x)$pretty_names[x$Parameter]
# when we use "types$Parameter" here, matching of pretty names does not work,
# so output will be NA resp. blank fields... Thus, I think we should use
# the original parameter-names here.
names(parameter_names) <- original_names # types$Parameter
parameter_names
}
#' @keywords internal
.format_parameter <- function(name, variable, type, level, brackets = brackets) {
# Factors
if (type == "factor") {
name <- .format_factor(name = name, variable = variable, brackets = brackets)
}
# Polynomials
if (type %in% c("poly", "poly_raw")) {
name <- .format_poly(name = name, variable = variable, type = type, degree = level, brackets = brackets)
}
# Splines
if (type == "spline") {
name <- .format_poly(name = name, variable = variable, type = type, degree = level, brackets = brackets)
}
# log-transformation
if (type == "logarithm") {
name <- .format_log(name = name, variable = variable, type = type, brackets = brackets)
}
# exp-transformation
if (type == "exponentiation") {
name <- .format_log(name = name, variable = variable, type = type, brackets = brackets)
}
# log-transformation
if (type == "squareroot") {
name <- .format_log(name = name, variable = variable, type = type, brackets = brackets)
}
# As Is
if (type == "asis") {
name <- variable
}
# Smooth
if (type == "smooth") {
name <- gsub("^smooth_(.*)\\[(.*)\\]", "\\2", name)
name <- gsub("s(", "Smooth term (", name, fixed = TRUE)
}
# Ordered
if (type == "ordered") {
name <- paste(variable, level)
}
name
}
#' @keywords internal
.format_interaction <- function(components,
type,
is_nested = FALSE,
is_simple = FALSE,
interaction_mark = NULL,
...) {
# sep <- ifelse(is_nested | is_simple, " : ", " * ")
# sep <- ifelse(is_nested, " / ", " * ")
# sep <- ifelse(is_simple, " : ", ifelse(is_nested, " / ", " * "))
if (is.null(interaction_mark)) {
if (.unicode_symbols()) {
sep <- "\u00D7"
} else {
sep <- "*"
}
} else {
sep <- interaction_mark
}
# either use argument, or override with options
sep <- paste0(" ", getOption("parameters_interaction", insight::trim_ws(sep)), " ")
if (length(components) > 2) {
if (type == "interaction") {
components <- paste0(
"(",
paste(utils::head(components, -1), collapse = sep),
")",
sep,
utils::tail(components, 1)
)
} else {
components <- paste(components, collapse = sep)
}
} else {
components <- paste(components, collapse = sep)
}
components
}
# format classes -----------------------------
#' @keywords internal
.format_factor <- function(name, variable, brackets = c("[", "]")) {
level <- sub(variable, "", name, fixed = TRUE)
# special handling for "cut()"
pattern_cut_right <- "^\\((.*),(.*)\\]$"
pattern_cut_left <- "^\\[(.*),(.*)\\)$"
if (all(grepl(pattern_cut_right, level))) {
lower_bounds <- gsub(pattern_cut_right, "\\1", level)
upper_bounds <- gsub(pattern_cut_right, "\\2", level)
level <- paste0(">", as.numeric(lower_bounds), "-", upper_bounds)
} else if (all(grepl(pattern_cut_left, level))) {
lower_bounds <- gsub(pattern_cut_left, "\\1", level)
upper_bounds <- gsub(pattern_cut_left, "\\2", level)
level <- paste0(lower_bounds, "-<", as.numeric(upper_bounds))
}
paste0(variable, " ", brackets[1], level, brackets[2])
}
#' @keywords internal
.format_poly <- function(name, variable, type, degree, brackets = c("[", "]")) {
paste0(variable, " ", brackets[1], format_order(as.numeric(degree), textual = FALSE), " degree", brackets[2])
}
#' @keywords internal
.format_log <- function(name, variable, type, brackets = c("[", "]")) {
paste0(variable, " ", brackets[1], gsub("(.*)\\((.*)\\)", "\\1", name), brackets[2])
}
#' @keywords internal
.format_ordered <- function(degree, brackets = c("[", "]")) {
switch(degree,
.L = paste0(brackets[1], "linear", brackets[2]),
.Q = paste0(brackets[1], "quadratic", brackets[2]),
.C = paste0(brackets[1], "cubic", brackets[2]),
paste0(
brackets[1],
parameters::format_order(as.numeric(gsub("^", "", degree, fixed = TRUE)), textual = FALSE),
" degree",
brackets[2]
)
)
}
# replace pretty names with value labels, when present ---------------
.format_value_labels <- function(params, model = NULL) {
pretty_labels <- NULL
if (is.null(model)) {
model <- .get_object(params)
}
# validation check
if (!is.null(model) && insight::is_regression_model(model) && !is.data.frame(model)) {
# get data, but exclude response - we have no need for that label
mf <- insight::get_data(model, source = "mf", verbose = FALSE)
# sanity check - any labels?
has_labels <- vapply(mf, function(i) !is.null(attr(i, "labels", exact = TRUE)), logical(1))
# if we don't have labels, we try to get data from environment
if (!any(has_labels)) {
mf <- insight::get_data(model, source = "environment", verbose = FALSE)
}
resp <- insight::find_response(model, combine = FALSE)
mf <- mf[, setdiff(colnames(mf), resp), drop = FALSE]
# return variable labels, and for factors, add labels for each level
lbs <- lapply(colnames(mf), function(i) {
vec <- mf[[i]]
if (is.factor(vec)) {
variable_label <- attr(vec, "label", exact = TRUE)
value_labels <- names(attr(vec, "labels", exact = TRUE))
if (is.null(variable_label)) {
variable_label <- i
}
if (is.null(value_labels)) {
value_labels <- levels(vec)
}
out <- paste0(variable_label, " [", value_labels, "]")
} else {
out <- attr(vec, "label", exact = TRUE)
}
if (is.null(out)) {
i
} else {
out
}
})
# coefficient names (not labels)
preds <- lapply(colnames(mf), function(i) {
if (is.character(mf[[i]])) {
mf[[i]] <- as.factor(mf[[i]])
}
if (is.factor(mf[[i]])) {
i <- paste0(i, levels(mf[[i]]))
}
i
})
# name elements
names(lbs) <- names(preds) <- colnames(mf)
pretty_labels <- .safe(stats::setNames(
unlist(lbs, use.names = FALSE),
unlist(preds, use.names = FALSE)
))
# retrieve pretty names attribute
pn <- attributes(params)$pretty_names
# replace former pretty names with labels, if we have any labels
# (else, default pretty names are returned)
if (!is.null(pretty_labels)) {
# check if we have any interactions, and if so, create combined labels
interactions <- pn[grepl(":", names(pn), fixed = TRUE)]
if (length(interactions)) {
labs <- NULL
for (i in names(interactions)) {
# extract single coefficient names from interaction term
out <- unlist(strsplit(i, ":", fixed = TRUE))
# combine labels
labs <- c(labs, paste(sapply(out, function(l) pretty_labels[l]), collapse = " * "))
}
# add interaction terms to labels string
names(labs) <- names(interactions)
pretty_labels <- c(pretty_labels, labs)
}
# make sure "invalid" labels are ignored
common_labels <- intersect(names(pretty_labels), names(pn))
pn[common_labels] <- pretty_labels[common_labels]
}
pretty_labels <- pn
}
# missing labels return original parameter name (e.g., variance components in mixed models)
out <- stats::setNames(params$Parameter, params$Parameter)
pretty_labels <- pretty_labels[names(pretty_labels) %in% params$Parameter]
out[match(names(pretty_labels), params$Parameter)] <- pretty_labels
out
}
# helper -------------------
.unicode_symbols <- function() {
# symbols only work on windows from R 4.2 and higher
win_os <- tryCatch(
{
si <- Sys.info()
if (is.null(si["sysname"])) {
FALSE
} else {
si["sysname"] == "Windows" || startsWith(R.version$os, "mingw")
}
},
error = function(e) {
TRUE
}
)
l10n_info()[["UTF-8"]] && ((win_os && getRversion() >= "4.2") || (!win_os && getRversion() >= "4.0"))
}
parameters/R/methods_aod.R 0000644 0001762 0000144 00000006662 14761570351 015252 0 ustar ligges users # classes: .glimML
## TODO add ci_method later?
#################### .glimML ------
#' @title Parameters from special models
#' @name model_parameters.glimML
#'
#' @description
#' Parameters from special regression models not listed under one of the
#' previous categories yet.
#'
#' @param component Model component for which parameters should be shown. May be
#' one of `"conditional"`, `"precision"` (e.g. **betareg**), `"scale"` (e.g.
#' **ordinal**), `"extra"` (e.g. **glmx**), `"marginal"` (e.g. **mfx**),
#' `"conditional"` or `"full"` (for `MuMIn::model.avg()`) or `"all"`. See section
#' _Model components_ for an overview of possible options for `component`.
#' @inheritParams model_parameters.default
#' @inheritParams model_parameters.brmsfit
#' @inheritParams simulate_model
#'
#' @seealso [insight::standardize_names()] to rename columns into a consistent,
#' standardized naming scheme.
#'
#' @inheritSection model_parameters.zcpglm Model components
#'
#' @examples
#' library(parameters)
#' if (require("brglm2", quietly = TRUE)) {
#' data("stemcell")
#' model <- bracl(
#' research ~ as.numeric(religion) + gender,
#' weights = frequency,
#' data = stemcell,
#' type = "ML"
#' )
#' model_parameters(model)
#' }
#' @return A data frame of indices related to the model's parameters.
#' @export
model_parameters.glimML <- function(model,
ci = 0.95,
bootstrap = FALSE,
iterations = 1000,
component = "conditional",
standardize = NULL,
exponentiate = FALSE,
p_adjust = NULL,
include_info = getOption("parameters_info", FALSE),
keep = NULL,
drop = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("conditional", "random", "dispersion", "all")
)
if (component == "all") {
merge_by <- c("Parameter", "Component")
} else {
merge_by <- "Parameter"
}
# dispersion is just an alias...
if (component == "dispersion") {
component <- "random"
}
out <- .model_parameters_generic(
model = model,
ci = ci,
component = component,
bootstrap = bootstrap,
iterations = iterations,
merge_by = "Parameter",
standardize = standardize,
exponentiate = exponentiate,
p_adjust = p_adjust,
keep_parameters = keep,
drop_parameters = drop,
include_info = include_info,
verbose = verbose,
...
)
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
out
}
#' @export
standard_error.glimML <- function(model, ...) {
insight::check_if_installed("aod")
s <- methods::slot(aod::summary(model), "Coef")
se <- s[, 2]
.data_frame(
Parameter = .remove_backticks_from_string(rownames(s)),
SE = as.vector(se)
)
}
#' @export
p_value.glimML <- function(model, ...) {
insight::check_if_installed("aod")
s <- methods::slot(aod::summary(model), "Coef")
p <- s[, 4]
.data_frame(
Parameter = .remove_backticks_from_string(rownames(s)),
p = as.vector(p)
)
}
parameters/R/print_md.R 0000644 0001762 0000144 00000036242 14736731407 014600 0 ustar ligges users # normal print ----------------------------
#' @rdname print.parameters_model
#' @export
print_md.parameters_model <- function(x,
pretty_names = TRUE,
split_components = TRUE,
select = NULL,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
footer_digits = 3,
ci_brackets = c("(", ")"),
show_sigma = FALSE,
show_formula = FALSE,
zap_small = FALSE,
groups = NULL,
include_reference = FALSE,
verbose = TRUE,
...) {
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", p_digits)
}
if (missing(footer_digits)) {
footer_digits <- .additional_arguments(x, "footer_digits", footer_digits)
}
# check options ---------------
# check if pretty names should be replaced by value labels
# (if we have labelled data)
if (isTRUE(getOption("parameters_labels", FALSE)) || identical(pretty_names, "labels")) {
attr(x, "pretty_names") <- attr(x, "pretty_labels", exact = TRUE)
pretty_names <- TRUE
}
# select which columns to print
if (is.null(select)) {
select <- getOption("parameters_select")
}
# table caption
table_caption <- .print_caption(x, caption, format = "markdown")
# main table
formatted_table <- .print_core(
x = x,
pretty_names = pretty_names,
split_components = split_components,
select = select,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
zap_small = zap_small,
ci_width = NULL,
ci_brackets = ci_brackets,
format = "markdown",
groups = groups,
include_reference = include_reference,
...
)
# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
}
# footer
footer_stats <- .print_footer(
x,
digits = footer_digits,
show_sigma = show_sigma,
show_formula = show_formula,
format = "markdown"
)
# check if footer should be printed at all. can be FALSE, or "" to suppress footer
if (isFALSE(footer)) {
footer <- ""
}
if (!identical(footer, "")) {
if (is.null(footer)) {
footer <- footer_stats
} else {
footer <- paste0("\n", footer, "\n", footer_stats)
}
}
insight::export_table(
formatted_table,
format = "markdown",
caption = table_caption,
subtitle = subtitle,
footer = footer,
align = "firstleft",
...
)
}
#' @export
print_md.parameters_brms_meta <- print_md.parameters_model
#' @export
print_md.parameters_simulate <- print_md.parameters_model
# compare parameters -------------------------
#' @rdname print.compare_parameters
#' @export
print_md.compare_parameters <- function(x,
digits = 2,
ci_digits = digits,
p_digits = 3,
caption = NULL,
subtitle = NULL,
footer = NULL,
select = NULL,
split_components = TRUE,
ci_brackets = c("(", ")"),
zap_small = FALSE,
groups = NULL,
engine = "tt",
...) {
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", p_digits)
}
# get attributes
if (missing(select) || is.null(select)) {
select <- attributes(x)$output_style
}
if (missing(groups)) {
groups <- attributes(x)$parameter_groups
}
# markdown engine?
engine <- match.arg(engine, c("tt", "default"))
formatted_table <- format(
x,
select = select,
split_components = split_components,
digits = digits,
ci_digits = ci_digits,
p_digits = p_digits,
ci_width = NULL,
ci_brackets = ci_brackets,
format = "markdown",
zap_small = zap_small,
groups = groups,
engine = engine
)
# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
}
if (identical(engine, "tt")) {
# retrieve output format - print_md() may be called from print_html()
dots <- list(...)
if (identical(dots$outformat, "html")) {
outformat <- "html"
} else {
outformat <- "markdown"
}
.export_table_tt(
x,
formatted_table,
groups,
caption = caption,
footer = footer,
outformat = outformat
)
} else {
insight::export_table(
formatted_table,
format = "markdown",
caption = caption,
subtitle = subtitle,
footer = footer
)
}
}
# SEM print ----------------------------
#' @export
print_md.parameters_sem <- function(x,
digits = 2,
ci_digits = digits,
p_digits = 3,
ci_brackets = c("(", ")"),
...) {
# check if user supplied digits attributes
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
}
if (missing(ci_digits)) {
ci_digits <- .additional_arguments(x, "ci_digits", digits)
}
if (missing(p_digits)) {
p_digits <- .additional_arguments(x, "p_digits", p_digits)
}
formatted_table <- format(
x = x,
digits = digits,
ci_digits,
p_digits = p_digits,
format = "markdown",
ci_width = NULL,
ci_brackets = ci_brackets,
...
)
insight::export_table(formatted_table, format = "markdown", align = "firstleft", ...)
}
# PCA / EFA / CFA ----------------------------
#' @export
print_md.parameters_efa_summary <- function(x, digits = 3, ...) {
table_caption <- "(Explained) Variance of Components"
if ("Parameter" %in% names(x)) {
x$Parameter <- c("Eigenvalues", "Variance Explained", "Variance Explained (Cumulative)", "Variance Explained (Proportion)") # nolint
} else if ("Component" %in% names(x)) {
names(x) <- c("Component", "Eigenvalues", "Variance Explained", "Variance Explained (Cumulative)", "Variance Explained (Proportion)") # nolint
}
insight::export_table(x, digits = digits, format = "markdown", caption = table_caption, align = "firstleft")
}
#' @export
print_md.parameters_pca_summary <- print_md.parameters_efa_summary
#' @export
print_md.parameters_efa <- function(x, digits = 2, sort = FALSE, threshold = NULL, labels = NULL, ...) {
.print_parameters_cfa_efa(
x,
threshold = threshold,
sort = sort,
format = "markdown",
digits = digits,
labels = labels,
...
)
}
#' @export
print_md.parameters_pca <- print_md.parameters_efa
# Equivalence test ----------------------------
#' @export
print_md.equivalence_test_lm <- function(x,
digits = 2,
ci_brackets = c("(", ")"),
zap_small = FALSE,
...) {
rule <- attributes(x)$rule
rope <- attributes(x)$rope
if (is.null(rule)) {
table_caption <- "Test for Practical Equivalence"
} else if (rule == "cet") {
table_caption <- "Conditional Equivalence Testing"
} else if (rule == "classic") {
table_caption <- "TOST-test for Practical Equivalence"
} else {
table_caption <- "Test for Practical Equivalence"
}
if ("Component" %in% colnames(x)) {
x <- x[x$Component %in% c("conditional", "count"), ]
}
formatted_table <- insight::format_table(
x,
pretty_names = TRUE,
digits = digits,
ci_width = NULL,
ci_brackets = ci_brackets,
zap_small = zap_small,
...
)
colnames(formatted_table)[which(colnames(formatted_table) == "Equivalence (ROPE)")] <- "H0"
formatted_table$ROPE <- NULL
# col_order <- c("Parameter", "H0", "% in ROPE", colnames(formatted_table)[grepl(" CI$", colnames(formatted_table))])
# col_order <- c(col_order, setdiff(colnames(formatted_table), col_order))
# formatted_table <- formatted_table[col_order]
# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
}
if (!is.null(rope)) {
names(formatted_table)[names(formatted_table) == "% in ROPE"] <- sprintf("%% in ROPE (%.*f, %.*f)", digits, rope[1], digits, rope[2]) # nolint
}
insight::export_table(formatted_table, format = "markdown", caption = table_caption, align = "firstleft")
}
# distribution print ----------------------------
#' @export
print_md.parameters_distribution <- function(x, digits = 2, ci_brackets = c("(", ")"), ...) {
formatted_table <- format(
x = x,
digits = digits,
format = "markdown",
ci_width = NULL,
ci_brackets = ci_brackets,
...
)
insight::export_table(formatted_table, format = "markdown", align = "firstleft", ...)
}
# helper -----------------------
.export_table_tt <- function(x, formatted_table, groups, caption = NULL, footer = NULL, outformat = "markdown") {
insight::check_if_installed("tinytable", minimum_version = "0.1.0")
row_groups <- NULL
# check if we have a list of tables
if (!is.data.frame(formatted_table) && is.list(formatted_table) && length(formatted_table) > 1) {
# sanity check - cannot combine multiple tables when we have groups
if (!is.null(groups)) {
insight::format_error("Cannot combine multiple tables when groups are present.")
}
# add table caption as group variable, and bind tables
# we then extract row headers based on values in the group indices
formatted_table <- lapply(formatted_table, function(i) {
i$group <- attr(i, "table_caption")
i
})
# bind tables
formatted_table <- do.call(rbind, formatted_table)
# find positions for sub headers
row_groups <- as.list(which(!duplicated(formatted_table$group)))
names(row_groups) <- formatted_table$group[unlist(row_groups)]
# remove no longer needed group variable
formatted_table$group <- NULL
}
# we need to find out which columns refer to which model, in order to
# add a column heading for each model
models <- attributes(x)$model_names
col_names <- gsub("(.*) \\((.*)\\)$", "\\2", colnames(formatted_table))
col_groups <- sapply(models, function(i) which(i == col_names), simplify = FALSE)
# clean column names. These still contain the model name
colnames(formatted_table) <- gsub("(.*) \\((.*)\\)$", "\\1", colnames(formatted_table))
# check if we have column spans at all?
if (all(lengths(col_groups) == 1)) {
col_groups <- NULL
}
# group rows?
if (!is.null(groups)) {
# make sure we have numeric indices for groups
groups <- lapply(groups, function(g) {
if (is.character(g)) {
# if groups were provided as parameter names, we find the row position
# by matching the parameter name
match(g, formatted_table$Parameter)
} else {
# else, we assume that the group is a row position
g
}
})
# sanity check - do all rows match a parameter?
group_indices <- unlist(groups, use.names = FALSE)
if (anyNA(group_indices) || any(group_indices < 1) || any(group_indices > nrow(formatted_table))) {
insight::format_error("Some group indices do not match any parameter.")
}
# if row indices are not sorted, we need to resort the parameters data frame
if (is.unsorted(unlist(groups))) {
new_rows <- c(unlist(groups), setdiff(seq_len(nrow(formatted_table)), unlist(groups)))
formatted_table <- formatted_table[new_rows, ]
# we need to update indices in groups as well. Therefore, we need to convert
# list of row indices into a vector with row indices, then subtract the
# differences of old and new row positions, and then split that vector into
# a list again
groups <- stats::setNames(unlist(groups), rep(names(groups), lengths(groups)))
groups <- groups - (unlist(groups) - sort(unlist(groups)))
groups <- split(unname(groups), factor(names(groups), levels = unique(names(groups))))
}
# find matching rows for groups
row_groups <- lapply(seq_along(groups), function(i) {
g <- groups[[i]]
if (is.character(g)) {
# if groups were provided as parameter names, we find the row position
# by matching the parameter name
g <- match(g, formatted_table$Parameter)[1]
} else {
# else, we assume that the group is a row position
g <- g[1]
}
g
})
# set element names
names(row_groups) <- names(groups)
if (identical(outformat, "markdown")) {
# for markdown, format italic
names(row_groups) <- paste0("*", names(row_groups), "*")
}
}
# replace NA in formatted_table by ""
formatted_table[is.na(formatted_table)] <- ""
# create base table
out <- tinytable::tt(formatted_table, notes = footer, caption = caption)
# insert sub header rows and column spans, if we have them
if (!(is.null(row_groups) && is.null(col_groups))) {
out <- tinytable::group_tt(out, i = row_groups, j = col_groups)
}
out@output <- outformat
out
}
parameters/R/extract_random_variances.R 0000644 0001762 0000144 00000077134 14761570351 020033 0 ustar ligges users .extract_random_variances <- function(model, ...) {
UseMethod(".extract_random_variances")
}
# default method -------------------
.extract_random_variances.default <- function(model,
ci = 0.95,
effects = "random",
component = "conditional",
ci_method = NULL,
ci_random = NULL,
verbose = FALSE,
...) {
out <- suppressWarnings(
.extract_random_variances_helper(
model,
ci = ci,
effects = effects,
component = component,
ci_method = ci_method,
ci_random = ci_random,
verbose = verbose,
...
)
)
# check for errors
if (is.null(out) && isTRUE(verbose)) {
insight::format_warning("Something went wrong when calculating random effects parameters. Only showing model's fixed effects now. You may use `effects=\"fixed\"` to speed up the call to `model_parameters()`.") # nolint
}
out
}
# glmmTMB -------------------
.extract_random_variances.glmmTMB <- function(model,
ci = 0.95,
effects = "random",
component = "all",
ci_method = NULL,
ci_random = NULL,
verbose = FALSE,
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "zero_inflated", "zi", "dispersion")
)
out <- suppressWarnings(
.extract_random_variances_helper(
model,
ci = ci,
effects = effects,
component = "conditional",
ci_method = ci_method,
ci_random = ci_random,
verbose = verbose,
...
)
)
# check for errors
if (is.null(out)) {
if (isTRUE(verbose)) {
insight::format_warning("Something went wrong when calculating random effects parameters. Only showing model's fixed effects now. You may use `effects=\"fixed\"` to speed up the call to `model_parameters()`.") # nolint
}
return(NULL)
}
out$Component <- "conditional"
if (insight::model_info(model, verbose = FALSE)$is_zero_inflated && !is.null(insight::find_random(model)$zero_inflated_random)) { # nolint
zi_var <- suppressWarnings(
.extract_random_variances_helper(
model,
ci = ci,
effects = effects,
component = "zi",
ci_method = ci_method,
ci_random = ci_random,
verbose = FALSE,
...
)
)
# bind if any zi-components could be extracted
if (!is.null(zi_var)) {
zi_var$Component <- "zero_inflated"
out <- rbind(out, zi_var)
}
}
# filter
if (component != "all") {
if (component == "zi") {
component <- "zero_inflated"
}
out <- out[out$Component == component, ]
}
out
}
# GLMMadpative -------------------
.extract_random_variances.MixMod <- .extract_random_variances.glmmTMB
# svy2lme ------------------------
.extract_random_variances.svy2lme <- function(model, ci = 0.95, effects = "random", ...) {
s <- sqrt(as.vector(model$s2))
stdev <- matrix(s * sqrt(diag(model$L)), ncol = 1)
vcnames <- c(paste0("SD (", model$znames, ")"), "SD (Observations)")
grp_names <- names(model$znames)
if (is.null(grp_names)) {
grp_names <- model$znames
}
out <- data.frame(
Parameter = vcnames,
Level = NA,
Coefficient = c(as.vector(stdev), s),
SE = NA,
CI_low = NA,
CI_high = NA,
t = NA,
df_error = NA,
p = NA,
Effects = "random",
Group = c(grp_names, "Residual"),
stringsAsFactors = FALSE
)
# fix intercept names
out$Parameter <- gsub("(Intercept)", "Intercept", out$Parameter, fixed = TRUE)
if (effects == "random") {
out[c("t", "df_error", "p")] <- NULL
}
rownames(out) <- NULL
out
}
# workhorse ------------------------
.extract_random_variances_helper <- function(model,
ci = 0.95,
effects = "random",
component = "conditional",
ci_method = NULL,
ci_random = NULL,
verbose = FALSE,
...) {
varcorr <- .get_variance_information(model, component)
if (!inherits(model, "lme")) {
class(varcorr) <- "VarCorr.merMod"
}
# return varcorr matrix
re_data <- as.data.frame(varcorr, order = "lower.tri")
# extract parameters from SD and COR separately, for sorting
re_sd_intercept <- re_data$var1 == "(Intercept)" & is.na(re_data$var2) & re_data$grp != "Residual"
re_sd_slope <- re_data$var1 != "(Intercept)" & is.na(re_data$var2) & re_data$grp != "Residual"
re_cor_intercept <- re_data$var1 == "(Intercept)" & !is.na(re_data$var2) & re_data$grp != "Residual"
re_cor_slope <- re_data$var1 != "(Intercept)" & !is.na(re_data$var2) & re_data$grp != "Residual"
re_sigma <- re_data$grp == "Residual"
# merge to sorted data frame
out <- rbind(
re_data[re_sd_intercept, ],
re_data[re_sd_slope, ],
re_data[re_cor_intercept, ],
re_data[re_cor_slope, ],
re_data[re_sigma, ]
)
out$Parameter <- NA
# rename SD
sds <- !is.na(out$var1) & is.na(out$var2)
if (any(sds)) {
out$Parameter[sds] <- paste0("SD (", out$var1[sds], ")")
}
# rename correlations
corrs <- !is.na(out$var2)
if (any(corrs)) {
out$Parameter[corrs] <- paste0("Cor (", out$var1[corrs], "~", out$var2[corrs], ")")
}
# rename sigma
sigma_res <- out$grp == "Residual"
if (any(sigma_res)) {
out$Parameter[sigma_res] <- "SD (Observations)"
}
# rename columns
out <- datawizard::data_rename(
out,
select = c("grp", "sdcor"),
replacement = c("Group", "Coefficient")
)
# fix names for uncorrelated slope-intercepts
pattern <- paste0("(", paste(insight::find_random(model, flatten = TRUE), collapse = "|"), ")\\.\\d+$")
out$Group <- gsub(pattern, "\\1", out$Group)
# remove non-used columns
out$var1 <- NULL
out$var2 <- NULL
out$grp <- NULL
out$vcov <- NULL
out$sdcor <- NULL
# fix intercept names
out$Parameter <- gsub("(Intercept)", "Intercept", out$Parameter, fixed = TRUE)
stat_column <- gsub("-statistic", "", insight::find_statistic(model), fixed = TRUE)
# to match rbind
out[[stat_column]] <- NA
out$SE <- NA
out$df_error <- NA
out$p <- NA
out$Level <- NA
out$CI <- NA
out$Effects <- "random"
if (length(ci) == 1) {
ci_cols <- c("CI_low", "CI_high")
} else {
ci_cols <- NULL
for (i in ci) {
ci_low <- paste0("CI_low_", i)
ci_high <- paste0("CI_high_", i)
ci_cols <- c(ci_cols, ci_low, ci_high)
}
}
out[ci_cols] <- NA
# variances to SD (sqrt), except correlations and Sigma
corr_param <- startsWith(out$Parameter, "Cor ")
sigma_param <- out$Parameter == "SD (Observations)"
# add confidence intervals?
if (!is.null(ci) && !all(is.na(ci)) && length(ci) == 1 && !isFALSE(ci_random)) {
out <- .random_sd_ci(model, out, ci_method, ci, ci_random, corr_param, sigma_param, component, verbose = verbose)
}
out <- out[c("Parameter", "Level", "Coefficient", "SE", ci_cols, stat_column, "df_error", "p", "Effects", "Group")]
if (effects == "random") {
out[c(stat_column, "df_error", "p", "CI")] <- NULL
}
rownames(out) <- NULL
out
}
#' @export
as.data.frame.VarCorr.lme <- function(x, row.names = NULL, optional = FALSE, ...) {
# retrieve RE SD and COR
stddevs <- sapply(x[, "StdDev"], as.numeric)
if ("Corr" %in% colnames(x)) {
corrs <- suppressWarnings(sapply(x[, "Corr"], as.numeric))
} else {
corrs <- NULL
}
grps <- endsWith(names(stddevs), " =")
# for multiple grouping factors, split at each group
if (any(grps)) {
from <- which(grps)
to <- c(which(grps) - 1, length(grps))[-1]
out_sd <- do.call(rbind, lapply(seq_along(from), function(i) {
values <- stddevs[from[i]:to[i]]
.data_frame(
grp = gsub("(.*) =$", "\\1", names(values[1])),
var1 = names(values[-1]),
var2 = NA_character_,
sdcor = unname(values[-1])
)
}))
if (is.null(corrs)) {
out_cor <- NULL
} else {
out_cor <- do.call(rbind, lapply(seq_along(from), function(i) {
values <- corrs[from[i]:to[i]]
.data_frame(
grp = gsub("(.*) =$", "\\1", names(values[1])),
var1 = "(Intercept)",
var2 = names(values[-1]),
sdcor = unname(values[-1])
)
}))
}
} else {
out_sd <- .data_frame(
grp = gsub("(.*) =(.*)", "\\1", attributes(x)$title),
var1 = names(stddevs),
var2 = NA_character_,
sdcor = unname(stddevs)
)
if (is.null(corrs)) {
out_cor <- NULL
} else {
out_cor <- .data_frame(
grp = gsub("(.*) =(.*)", "\\1", attributes(x)$title),
var1 = "(Intercept)",
var2 = names(corrs),
sdcor = unname(corrs)
)
}
}
out_sd$grp[out_sd$var1 == "Residual"] <- "Residual"
out_sd$var1[out_sd$grp == "Residual"] <- NA_character_
out_sd$var2[out_sd$grp == "Residual"] <- NA_character_
out_cor <- out_cor[!is.na(out_cor$sdcor), ]
rbind(out_sd, out_cor)
}
# extract CI for random SD ------------------------
.random_sd_ci <- function(model,
out,
ci_method,
ci, ci_random,
corr_param,
sigma_param,
component = NULL,
verbose = FALSE) {
## TODO needs to be removed once MCM > 0.1.5 is on CRAN
if (startsWith(insight::safe_deparse(insight::get_call(model)), "mcm_lmer")) {
return(out)
}
# heuristic to check whether CIs for random effects should be computed or
# not. If `ci_random=NULL`, we check model complexity and decide whether to
# go on or not. For models with larger samples sized or more complex random
# effects, this might be quite time consuming.
if (is.null(ci_random)) {
# check sample size, don't compute by default when larger than 1000
n_obs <- insight::n_obs(model)
if (n_obs >= 1000) {
return(out)
}
# check complexity of random effects
re <- insight::find_random(model, flatten = TRUE)
rs <- insight::find_random_slopes(model)
# quit if if random slopes and larger sample size or more than 1 grouping factor
if (!is.null(rs) && (n_obs >= 500 || length(re) > 1)) {
return(out)
}
# quit if if than two grouping factors
if (length(re) > 2) {
return(out)
}
}
if (inherits(model, c("merMod", "glmerMod", "lmerMod"))) {
# lme4 - boot and profile
if (!is.null(ci_method) && ci_method %in% c("profile", "boot")) {
out <- tryCatch(
{
var_ci <- as.data.frame(suppressWarnings(stats::confint(
model,
parm = "theta_",
oldNames = FALSE,
method = ci_method,
level = ci
)))
colnames(var_ci) <- c("CI_low", "CI_high")
rn <- row.names(var_ci)
rn <- gsub("sd_(.*)(\\|)(.*)", "\\1: \\3", rn)
rn <- gsub("|", ":", rn, fixed = TRUE)
rn <- gsub("[\\(\\)]", "", rn)
rn <- gsub("cor_(.*)\\.(.*)", "cor \\2", rn)
var_ci_corr_param <- startsWith(rn, "cor ")
var_ci_sigma_param <- rn == "sigma"
out$CI_low[!corr_param & !sigma_param] <- var_ci$CI_low[!var_ci_corr_param & !var_ci_sigma_param]
out$CI_high[!corr_param & !sigma_param] <- var_ci$CI_high[!var_ci_corr_param & !var_ci_sigma_param]
if (any(sigma_param) && any(var_ci_sigma_param)) {
out$CI_low[sigma_param] <- var_ci$CI_low[var_ci_sigma_param]
out$CI_high[sigma_param] <- var_ci$CI_high[var_ci_sigma_param]
}
if (any(corr_param) && any(var_ci_corr_param)) {
out$CI_low[corr_param] <- var_ci$CI_low[var_ci_corr_param]
out$CI_high[corr_param] <- var_ci$CI_high[var_ci_corr_param]
}
out
},
error = function(e) {
if (isTRUE(verbose)) {
insight::format_alert(
"Cannot compute profiled standard errors and confidence intervals for random effects parameters.",
"Your model may suffer from singularity (see '?lme4::isSingular' and '?performance::check_singularity').",
"You may try to impose a prior on the random effects parameters, e.g. using the {.pkg glmmTMB} package."
)
}
out
}
)
} else if (!is.null(ci_method)) {
# lme4 - wald / normal CI
merDeriv_loaded <- isNamespaceLoaded("merDeriv")
# detach on exit
on.exit(
if (!merDeriv_loaded) {
.unregister_vcov()
},
add = TRUE,
after = FALSE
)
# Wald based CIs
# see https://stat.ethz.ch/pipermail/r-sig-mixed-models/2022q1/029985.html
if (all(suppressMessages(insight::check_if_installed(c("merDeriv", "lme4"), quietly = TRUE)))) {
# this may fail, so wrap in try-catch
out <- tryCatch(
{
# vcov from full model. the parameters from vcov have a different
# order, so we need to restore the "original" order of random effect
# parameters using regex to match the naming patterns (of the column
# names from the vcov)
vv <- stats::vcov(model, full = TRUE, ranpar = "sd")
# only keep random effect variances
cov_columns <- grepl("(^cov_|residual)", colnames(vv))
vv <- vv[cov_columns, cov_columns, drop = FALSE]
# iterate random effect variables
re_groups <- setdiff(unique(out$Group), "Residual")
# create data frame with group and parameter names and SE
var_ci <- do.call(rbind, lapply(re_groups, function(i) {
pattern <- paste0("^cov_", i, "\\.(.*)")
re_group_columns <- grepl(pattern, colnames(vv))
vv_sub <- as.matrix(vv[re_group_columns, re_group_columns, drop = FALSE])
cn <- gsub(pattern, "\\1", colnames(vv_sub))
.data_frame(Group = i, Parameter = cn, SE = sqrt(diag(vv_sub)))
}))
# add residual variance
res_column <- which(colnames(vv) == "residual")
if (length(res_column)) {
var_ci <- rbind(
var_ci,
.data_frame(
Group = "Residual",
Parameter = "SD (Observations)",
SE = sqrt(vv[res_column, res_column, drop = TRUE])
)
)
}
# renaming
var_ci$Parameter[var_ci$Parameter == "(Intercept)"] <- "SD (Intercept)"
# correlations
var_ci_corr_param <- grepl("(.*)\\.\\(Intercept\\)", var_ci$Parameter)
if (any(var_ci_corr_param)) {
rnd_slope_terms <- gsub("(.*)\\.\\(Intercept\\)", "\\1", var_ci$Parameter[var_ci_corr_param])
var_ci$Parameter[var_ci_corr_param] <- paste0("Cor (Intercept~", rnd_slope_terms, ")")
}
# correlations w/o intercept? usually only for factors
# or: correlation among slopes. we need to recover the (categorical)
# term names from our prepared data frame, then match vcov-names
rnd_slope_corr <- grepl("^Cor \\((?!Intercept~)", out$Parameter, perl = TRUE)
if (any(rnd_slope_corr)) {
for (gr in setdiff(unique(out$Group), "Residual")) {
rnd_slope_corr_grp <- rnd_slope_corr & out$Group == gr
dummy <- gsub("Cor \\((.*)~(.*)\\)", "\\2.\\1", out$Parameter[rnd_slope_corr_grp])
var_ci$Parameter[var_ci$Group == gr][match(dummy, var_ci$Parameter[var_ci$Group == gr])] <- out$Parameter[rnd_slope_corr_grp] # nolint
}
}
# remaining
var_ci_others <- !grepl("^(Cor|SD) (.*)", var_ci$Parameter)
var_ci$Parameter[var_ci_others] <- gsub("(.*)", "SD (\\1)", var_ci$Parameter[var_ci_others])
# merge with random effect coefficients
out$.sort_id <- seq_len(nrow(out))
tmp <- merge(
datawizard::data_remove(out, "SE", verbose = FALSE),
var_ci,
all.x = TRUE,
sort = FALSE
)
tmp <- tmp[order(tmp$.sort_id), ]
out$SE <- tmp$SE
out$.sort_id <- NULL
# ensure correlation CI are within -1/1 bounds
var_ci_corr_param <- startsWith(out$Parameter, "Cor ")
if (any(var_ci_corr_param)) {
coefs <- out$Coefficient[var_ci_corr_param]
delta_se <- out$SE[var_ci_corr_param] / (1 - coefs^2)
out$CI_low[var_ci_corr_param] <- tanh(atanh(coefs) - stats::qnorm(0.975) * delta_se)
out$CI_high[var_ci_corr_param] <- tanh(atanh(coefs) + stats::qnorm(0.975) * delta_se)
}
# Wald CI, based on delta-method.
# SD is chi square distributed. So it has a long tail. CIs should
# therefore be asymmetrical. log(SD) is normally distributed.
# Also, if the SD is small, then the CI might go negative
coefs <- out$Coefficient[!var_ci_corr_param]
delta_se <- out$SE[!var_ci_corr_param] / coefs
out$CI_low[!var_ci_corr_param] <- exp(log(coefs) - stats::qnorm(0.975) * delta_se)
out$CI_high[!var_ci_corr_param] <- exp(log(coefs) + stats::qnorm(0.975) * delta_se)
# warn if singular fit
if (isTRUE(verbose) && insight::check_if_installed("performance", quietly = TRUE) && isTRUE(performance::check_singularity(model))) { # nolint
insight::format_alert(
"Your model may suffer from singularity (see see `?lme4::isSingular` and `?performance::check_singularity`).", # nolint
"Some of the standard errors and confidence intervals of the random effects parameters are probably not meaningful!", # nolint
"You may try to impose a prior on the random effects parameters, e.g. using the {.pkg glmmTMB} package." # nolint
)
}
out
},
error = function(e) {
if (isTRUE(verbose)) {
if (grepl("nAGQ of at least 1 is required", e$message, fixed = TRUE)) {
insight::format_alert("Argument `nAGQ` needs to be larger than 0 to compute confidence intervals for random effect parameters.") # nolint
}
if (grepl("Multiple cluster variables detected.", e$message, fixed = TRUE)) {
insight::format_alert("Confidence intervals for random effect parameters are currently not supported for multiple grouping variables.") # nolint
}
if (grepl("exactly singular", e$message, fixed = TRUE) ||
grepl("computationally singular", e$message, fixed = TRUE) ||
grepl("Exact singular", e$message, fixed = TRUE)) {
insight::format_alert(
"Cannot compute standard errors and confidence intervals for random effects parameters.",
"Your model may suffer from singularity (see see `?lme4::isSingular` and `?performance::check_singularity`).", # nolint
"You may try to impose a prior on the random effects parameters, e.g. using the {.pkg glmmTMB} package." # nolint
)
}
}
out
}
)
} else if (isTRUE(verbose)) {
insight::format_alert("Package 'merDeriv' needs to be installed to compute confidence intervals for random effect parameters.") # nolint
}
}
} else if (inherits(model, "glmmTMB")) {
# glmmTMB random-effects-CI
## TODO "profile" seems to be less stable, so only wald?
out <- tryCatch(
{
var_ci <- rbind(
as.data.frame(suppressWarnings(stats::confint(model, parm = "theta_", method = "wald", level = ci))),
as.data.frame(suppressWarnings(stats::confint(model, parm = "sigma", method = "wald", level = ci)))
)
colnames(var_ci) <- c("CI_low", "CI_high", "not_used")
var_ci$Component <- "conditional"
var_ci$Parameter <- row.names(var_ci)
if (utils::packageVersion("glmmTMB") > "1.1.3") {
var_ci$Component[startsWith(var_ci$Parameter, "zi.")] <- "zi"
# remove cond/zi prefix
var_ci$Parameter <- gsub("^(cond\\.|zi\\.)(.*)", "\\2", var_ci$Parameter)
# copy RE group
var_ci$Group <- gsub("(.*)\\|(.*)$", "\\2", var_ci$Parameter)
var_ci$Parameter <- gsub("(.*)\\|(.*)$", "\\1", var_ci$Parameter)
var_ci$Group[rownames(var_ci) == "sigma"] <- "Residual"
} else {
# regex-pattern to find conditional and ZI components
group_factor <- insight::find_random(model, flatten = TRUE)
group_factor2 <- paste0("(", paste(group_factor, collapse = "|"), ")")
pattern <- paste0("^(zi\\.|", group_factor2, "\\.zi\\.)")
zi_rows <- grepl(pattern, var_ci$Parameter)
if (any(zi_rows)) {
var_ci$Component[zi_rows] <- "zi"
}
# add Group
var_ci$Group <- NA
if (length(group_factor) > 1) {
var_ci$Group[var_ci$Component == "conditional"] <- gsub(paste0("^", group_factor2, "\\.cond\\.(.*)"), "\\1", var_ci$Parameter[var_ci$Component == "conditional"]) # nolint
var_ci$Group[var_ci$Component == "zi"] <- gsub(paste0("^", group_factor2, "\\.zi\\.(.*)"), "\\1", var_ci$Parameter[var_ci$Component == "zi"]) # nolint
} else {
var_ci$Group <- group_factor
# check if sigma was properly identified
if (!"sigma" %in% var_ci$Group && "sigma" %in% rownames(var_ci)) {
var_ci$Group[rownames(var_ci) == "sigma"] <- "Residual"
}
}
# remove cond/zi prefix
pattern <- paste0("^(cond\\.|zi\\.|", group_factor, "\\.cond\\.|", group_factor, "\\.zi\\.)(.*)")
for (p in pattern) {
var_ci$Parameter <- gsub(p, "\\2", var_ci$Parameter)
}
}
# fix SD and Cor names
var_ci$Parameter <- gsub(".Intercept.", "(Intercept)", var_ci$Parameter, fixed = TRUE)
var_ci$Parameter <- gsub("^(Std\\.Dev\\.)(.*)", "SD \\(\\2\\)", var_ci$Parameter)
var_ci$Parameter <- gsub("^Cor\\.(.*)\\.(.*)", "Cor \\(\\2~\\1\\)", var_ci$Parameter)
# minor cleaning
var_ci$Parameter <- gsub("((", "(", var_ci$Parameter, fixed = TRUE)
var_ci$Parameter <- gsub("))", ")", var_ci$Parameter, fixed = TRUE)
var_ci$Parameter <- gsub(")~", "~", var_ci$Parameter, fixed = TRUE)
# fix sigma
var_ci$Parameter[var_ci$Parameter == "sigma"] <- "SD (Observations)"
var_ci$Group[var_ci$Group == "sigma"] <- "Residual"
# remove unused columns (that are added back after merging)
out$CI_low <- NULL
out$CI_high <- NULL
# filter component
var_ci <- var_ci[var_ci$Component == component, ]
var_ci$not_used <- NULL
var_ci$Component <- NULL
# check results - warn user
if (isTRUE(verbose)) {
missing_ci <- any(is.na(var_ci$CI_low) | is.na(var_ci$CI_high))
singular_fit <- insight::check_if_installed("performance", quietly = TRUE) & isTRUE(performance::check_singularity(model)) # nolint
if (singular_fit) {
insight::format_alert(
"Your model may suffer from singularity (see `?lme4::isSingular` and `?performance::check_singularity`).",
"Some of the confidence intervals of the random effects parameters are probably not meaningful!",
"You may try to impose a prior on the random effects parameters, e.g. using the {.pkg glmmTMB} package." # nolint
)
} else if (missing_ci) {
insight::format_alert(
"Your model may suffer from singularity (see `?lme4::isSingular` and `?performance::check_singularity`).",
"Some of the confidence intervals of the random effects parameters could not be calculated or are probably not meaningful!", # nolint
"You may try to impose a prior on the random effects parameters, e.g. using the {.pkg glmmTMB} package." # nolint
)
}
}
# merge and sort
out$.sort_id <- seq_len(nrow(out))
out <- merge(out, var_ci, sort = FALSE, all.x = TRUE)
out <- out[order(out$.sort_id), ]
out$.sort_id <- NULL
out
},
error = function(e) {
if (isTRUE(verbose)) {
insight::format_alert(
"Cannot compute confidence intervals for random effects parameters.",
"Your model may suffer from singularity (see `?lme4::isSingular` and `?performance::check_singularity`)."
)
}
out
}
)
}
out
}
# Extract Variance and Correlation Components ----
# store essential information about variance components...
# basically, this function should return lme4::VarCorr(x)
.get_variance_information <- function(model, model_component = "conditional") {
# reason to be installed
reason <- "to compute random effect variances for mixed models"
# installed?
insight::check_if_installed("lme4", reason = reason)
if (inherits(model, "lme")) {
insight::check_if_installed("nlme", reason = reason)
}
if (inherits(model, "clmm")) {
insight::check_if_installed("ordinal", reason = reason)
}
if (inherits(model, "brmsfit")) {
insight::check_if_installed("brms", reason = reason)
}
if (inherits(model, "cpglmm")) {
insight::check_if_installed("cplm", reason = reason)
}
if (inherits(model, "rstanarm")) {
insight::check_if_installed("rstanarm", reason = reason)
}
# stanreg
# ---------------------------
if (inherits(model, "stanreg")) {
varcorr <- lme4::VarCorr(model)
# GLMMapdative
# ---------------------------
} else if (inherits(model, "MixMod")) {
vc1 <- vc2 <- NULL
re_names <- insight::find_random(model)
vc_cond <- !startsWith(colnames(model$D), "zi_")
if (any(vc_cond)) {
vc1 <- model$D[vc_cond, vc_cond, drop = FALSE]
attr(vc1, "stddev") <- sqrt(diag(vc1))
attr(vc1, "correlation") <- stats::cov2cor(model$D[vc_cond, vc_cond, drop = FALSE])
}
vc_zi <- startsWith(colnames(model$D), "zi_")
if (any(vc_zi)) {
colnames(model$D) <- gsub("^zi_(.*)", "\\1", colnames(model$D))
rownames(model$D) <- colnames(model$D)
vc2 <- model$D[vc_zi, vc_zi, drop = FALSE]
attr(vc2, "stddev") <- sqrt(diag(vc2))
attr(vc2, "correlation") <- stats::cov2cor(model$D[vc_zi, vc_zi, drop = FALSE])
}
vc1 <- list(vc1)
names(vc1) <- re_names[[1]]
attr(vc1, "sc") <- sqrt(insight::get_deviance(model, verbose = FALSE) / insight::get_df(model, type = "residual", verbose = FALSE)) # nolint
attr(vc1, "useSc") <- TRUE
if (!is.null(vc2)) {
vc2 <- list(vc2)
names(vc2) <- re_names[[2]]
attr(vc2, "sc") <- sqrt(insight::get_deviance(model, verbose = FALSE) / insight::get_df(model, type = "residual", verbose = FALSE)) # nolint
attr(vc2, "useSc") <- FALSE
}
varcorr <- insight::compact_list(list(vc1, vc2))
names(varcorr) <- c("cond", "zi")[seq_along(varcorr)]
# joineRML
# ---------------------------
} else if (inherits(model, "mjoint")) {
re_names <- insight::find_random(model, flatten = TRUE)
varcorr <- summary(model)$D
attr(varcorr, "stddev") <- sqrt(diag(varcorr))
attr(varcorr, "correlation") <- stats::cov2cor(varcorr)
varcorr <- list(varcorr)
names(varcorr) <- re_names[1]
attr(varcorr, "sc") <- model$coef$sigma2[[1]]
attr(varcorr, "useSc") <- TRUE
# nlme
# ---------------------------
} else if (inherits(model, "lme")) {
varcorr <- lme4::VarCorr(model)
# ordinal
# ---------------------------
} else if (inherits(model, "clmm")) {
varcorr <- ordinal::VarCorr(model)
attr(varcorr, "useSc") <- FALSE
# glmmadmb
# ---------------------------
} else if (inherits(model, "glmmadmb")) {
varcorr <- lme4::VarCorr(model)
# brms
# ---------------------------
} else if (inherits(model, "brmsfit")) {
varcorr <- lapply(names(lme4::VarCorr(model)), function(i) {
element <- lme4::VarCorr(model)[[i]]
if (i != "residual__") {
if (is.null(element$cov)) {
out <- as.matrix(drop(element$sd[, 1])^2)
colnames(out) <- rownames(out) <- gsub("Intercept", "(Intercept)", rownames(element$sd), fixed = TRUE)
} else {
out <- as.matrix(drop(element$cov[, 1, ]))
colnames(out) <- rownames(out) <- gsub("Intercept", "(Intercept)", rownames(element$cov), fixed = TRUE)
}
attr(out, "sttdev") <- element$sd[, 1]
} else {
out <- NULL
}
out
})
varcorr <- insight::compact_list(varcorr)
names(varcorr) <- setdiff(names(lme4::VarCorr(model)), "residual__")
attr(varcorr, "sc") <- lme4::VarCorr(model)$residual__$sd[1, 1]
# cpglmm
# ---------------------------
} else if (inherits(model, "cpglmm")) {
varcorr <- cplm::VarCorr(model)
attr(varcorr, "useSc") <- FALSE
# lme4 / glmmTMB
# ---------------------------
} else {
varcorr <- lme4::VarCorr(model)
}
# for glmmTMB, tell user that dispersion model is ignored
if (inherits(model, c("glmmTMB", "MixMod"))) {
if (is.null(model_component) || model_component == "conditional") {
varcorr <- .collapse_cond(varcorr)
} else {
varcorr <- .collapse_zi(varcorr)
}
}
varcorr
}
# glmmTMB returns a list of model information, one for conditional
# and one for zero-inflation part, so here we "unlist" it, returning
# only the conditional part.
.collapse_cond <- function(x) {
if (is.list(x) && "cond" %in% names(x)) {
x[["cond"]]
} else {
x
}
}
.collapse_zi <- function(x) {
if (is.list(x) && "zi" %in% names(x)) {
x[["zi"]]
} else {
x
}
}
# this is used to only temporarily load merDeriv and to point registered
# methods from merDeriv to lme4-methods. if merDeriv was loaded before,
# nothing will be changed. If merDeriv was not loaded, vcov-methods registered
# by merDeriv will be re-registered to use lme4::vcov.merMod. This is no problem,
# because *if* useres load merDeriv later manually, merDeriv-vcov-methods will
# be registered again.
.unregister_vcov <- function() {
unloadNamespace("merDeriv")
suppressWarnings(suppressMessages(registerS3method("vcov", "lmerMod", method = lme4::vcov.merMod)))
suppressWarnings(suppressMessages(registerS3method("vcov", "glmerMod", method = lme4::vcov.merMod)))
}
parameters/R/methods_pscl.R 0000644 0001762 0000144 00000013513 14736731407 015444 0 ustar ligges users # .zeroinfl, .hurdle, .zerocount
# model parameters -----------------
#' @export
model_parameters.zeroinfl <- model_parameters.zcpglm
#' @export
model_parameters.hurdle <- model_parameters.zcpglm
#' @export
model_parameters.zerocount <- model_parameters.zcpglm
# ci -----------------
#' @export
ci.zeroinfl <- function(x,
ci = 0.95,
dof = NULL,
method = "wald",
component = "all",
verbose = TRUE,
...) {
method <- tolower(method)
method <- insight::validate_argument(
method,
c("wald", "normal", "residual", "robust")
)
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated")
)
if (is.null(.check_component(x, component, verbose = verbose))) {
return(NULL)
}
# all other
.ci_generic(model = x, ci = ci, dof = dof, method = method, component = component, ...)
}
#' @export
ci.hurdle <- ci.zeroinfl
#' @export
ci.zerocount <- ci.zeroinfl
# standard error -----------------
#' @export
standard_error.zeroinfl <- function(model,
component = "all",
method = NULL,
verbose = TRUE,
...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated")
)
if (is.null(.check_component(model, component, verbose = verbose))) {
return(NULL)
}
robust <- !is.null(method) && method == "robust"
if (.check_vcov_args(robust, ...)) {
return(standard_error.default(model, component = component, ...))
}
cs <- insight::compact_list(stats::coef(summary(model)))
x <- lapply(names(cs), function(i) {
if (i == "count") {
comp <- "conditional"
} else {
comp <- "zi"
}
stats <- cs[[i]]
# remove log(theta)
theta <- grepl("Log(theta)", rownames(stats), fixed = TRUE)
if (any(theta)) {
stats <- stats[!theta, ]
}
.data_frame(
Parameter = insight::find_parameters(model, effects = "fixed", component = comp, flatten = TRUE),
SE = as.vector(stats[, 2]),
Component = comp
)
})
se <- do.call(rbind, x)
se$Component <- .rename_values(se$Component, "cond", "conditional")
se$Component <- .rename_values(se$Component, "zi", "zero_inflated")
.filter_component(se, component)
}
#' @export
standard_error.hurdle <- standard_error.zeroinfl
#' @export
standard_error.zerocount <- standard_error.zeroinfl
# p values -----------------------
#' @export
p_value.zeroinfl <- function(model, component = "all", method = NULL, verbose = TRUE, ...) {
component <- insight::validate_argument(
component,
c("all", "conditional", "zi", "zero_inflated")
)
if (is.null(.check_component(model, component, verbose = verbose))) {
return(NULL)
}
robust <- !is.null(method) && method == "robust"
if (.check_vcov_args(robust, ...)) {
return(p_value.default(model, component = component, ...))
}
cs <- insight::compact_list(stats::coef(summary(model)))
x <- lapply(names(cs), function(i) {
if (i == "count") {
comp <- "conditional"
} else {
comp <- "zi"
}
stats <- cs[[i]]
# remove log(theta)
theta <- grepl("Log(theta)", rownames(stats), fixed = TRUE)
if (any(theta)) {
stats <- stats[!theta, ]
}
.data_frame(
Parameter = insight::find_parameters(model, effects = "fixed", component = comp, flatten = TRUE),
p = as.vector(stats[, 4]),
Component = comp
)
})
p <- do.call(rbind, x)
p$Component <- .rename_values(p$Component, "cond", "conditional")
p$Component <- .rename_values(p$Component, "zi", "zero_inflated")
.filter_component(p, component)
}
#' @export
p_value.hurdle <- p_value.zeroinfl
#' @export
p_value.zerocount <- p_value.zeroinfl
# simulate model -----------------
#' @export
simulate_model.zeroinfl <- simulate_model.glmmTMB
#' @export
simulate_model.hurdle <- simulate_model.zeroinfl
#' @export
simulate_model.zerocount <- simulate_model.zeroinfl
# simulate paramaters -----------------
#' @export
simulate_parameters.zeroinfl <- function(model,
iterations = 1000,
centrality = "median",
ci = 0.95,
ci_method = "quantile",
test = "p-value",
...) {
data <- simulate_model(model, iterations = iterations, ...)
out <-
.summary_bootstrap(
data = data,
test = test,
centrality = centrality,
ci = ci,
ci_method = ci_method,
...
)
params <- insight::get_parameters(model)
if ("Effects" %in% colnames(params) && insight::n_unique(params$Effects) > 1) {
out$Effects <- params$Effects
}
if ("Component" %in% colnames(params) && insight::n_unique(params$Component) > 1) {
out$Component <- params$Component
}
if (inherits(model, c("zeroinfl", "hurdle", "zerocount"))) {
out$Parameter <- gsub("^(count_|zero_)", "", out$Parameter)
}
class(out) <- c("parameters_simulate", "see_parameters_simulate", class(out))
attr(out, "object_name") <- insight::safe_deparse_symbol(substitute(model))
attr(out, "iterations") <- iterations
attr(out, "ci") <- ci
attr(out, "ci_method") <- ci_method
attr(out, "centrality") <- centrality
out
}
#' @export
simulate_parameters.hurdle <- simulate_parameters.zeroinfl
#' @export
simulate_parameters.zerocount <- simulate_parameters.zeroinfl
parameters/R/methods_wrs2.R 0000644 0001762 0000144 00000023455 14507235543 015402 0 ustar ligges users #' Parameters from robust statistical objects in `WRS2`
#'
#' @param model Object from `WRS2` package.
#' @param ... Arguments passed to or from other methods.
#' @inheritParams model_parameters.default
#'
#' @examples
#' if (require("WRS2") && packageVersion("WRS2") >= "1.1.3") {
#' model <- t1way(libido ~ dose, data = viagra)
#' model_parameters(model)
#' }
#' @return A data frame of indices related to the model's parameters.
#' @export
# anova ----------------------
model_parameters.t1way <- function(model, keep = NULL, verbose = TRUE, ...) {
parameters <- .extract_wrs2_t1way(model)
parameters <- .add_htest_parameters_attributes(parameters, model, ...)
class(parameters) <- c("parameters_model", "see_parameters_model", class(parameters))
parameters
}
.extract_wrs2_t1way <- function(model) {
fcall <- insight::safe_deparse(model$call)
# effect sizes are by default contained for `t1way` but not `rmanova`
if (grepl("^(t1way|WRS2::t1way)", fcall)) {
data.frame(
`F` = model$test,
df = model$df1,
df_error = model$df2,
p = model$p.value,
Method = "A heteroscedastic one-way ANOVA for trimmed means",
Estimate = model$effsize,
CI = 1 - model$alpha,
CI_low = model$effsize_ci[1],
CI_high = model$effsize_ci[2],
Effectsize = "Explanatory measure of effect size",
stringsAsFactors = FALSE
)
} else if (grepl("^(rmanova|WRS2::rmanova)", fcall)) {
data.frame(
`F` = model$test,
df = model$df1,
df_error = model$df2,
p = model$p.value,
Method = "A heteroscedastic one-way repeated measures ANOVA for trimmed means",
stringsAsFactors = FALSE
)
}
}
#' @export
model_parameters.med1way <- function(model, verbose = TRUE, ...) {
parameters <- .extract_wrs2_med1way(model)
parameters <- .add_htest_parameters_attributes(parameters, model, ...)
class(parameters) <- c("parameters_model", "see_parameters_model", class(parameters))
parameters
}
.extract_wrs2_med1way <- function(model) {
data.frame(
`F` = model$test,
`Critical value` = model$crit.val,
p = model$p.value,
Method = "Heteroscedastic one-way ANOVA for medians",
stringsAsFactors = FALSE
)
}
#' @export
model_parameters.dep.effect <- function(model,
keep = NULL,
verbose = TRUE,
...) {
parameters <- .extract_wrs2_dep.effect(model, keep = keep)
class(parameters) <- c("parameters_model", "see_parameters_model", class(parameters))
parameters
}
.extract_wrs2_dep.effect <- function(model, keep = NULL, ...) {
out <- as.data.frame(model)
out$Parameter <- c(attributes(out)$row.names)
# effectsize descriptions
out$Effectsize <- c(
"Algina-Keselman-Penfield robust standardized difference", # AKP
"Quantile shift based on the median of the distribution of difference scores", # QS (median)
"Quantile shift based on the trimmed mean of the distribution of X-Y", # QStr
"P(X