Skip to content

Commit

Permalink
fixes
Browse files Browse the repository at this point in the history
  • Loading branch information
@strengejacke
strengejacke committed May 10, 2024
1 parent 70ce5f2 commit 8cfa72e
Show file tree
Hide file tree
Showing 9 changed files with 15 additions and 213 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,10 +30,10 @@ Suggests:
car,
coin,
ggplot2,
lme4,
MASS,
pscl,
pwr,
sjPlot,
survey,
testthat
URL: https://strengejacke.github.io/sjstats/
Expand Down
11 changes: 0 additions & 11 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,21 +19,15 @@ S3method(plot,sj_inequ_trend)
S3method(predict,svyglm.nb)
S3method(print,sj_anova_stat)
S3method(print,sj_chi2gof)
S3method(print,sj_grpmean)
S3method(print,sj_htest_chi)
S3method(print,sj_htest_kw)
S3method(print,sj_htest_mwu)
S3method(print,sj_mwu)
S3method(print,sj_outliers)
S3method(print,sj_resample)
S3method(print,sj_ttest)
S3method(print,sj_wcor)
S3method(print,sj_wmwu)
S3method(print,sj_xtab_stat)
S3method(print,sj_xtab_stat2)
S3method(print,svyglm.nb)
S3method(print,svyglm.zip)
S3method(print,tidy_stan)
S3method(residuals,svyglm.nb)
S3method(terms,svyglm.nb)
S3method(weighted_correlation,default)
Expand Down Expand Up @@ -111,11 +105,6 @@ importFrom(bayestestR,equivalence_test)
importFrom(datawizard,weighted_mean)
importFrom(datawizard,weighted_median)
importFrom(datawizard,weighted_sd)
importFrom(insight,export_table)
importFrom(insight,format_p)
importFrom(insight,format_value)
importFrom(insight,link_inverse)
importFrom(insight,print_color)
importFrom(performance,mse)
importFrom(performance,rmse)
importFrom(stats,family)
185 changes: 0 additions & 185 deletions R/S3-methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,6 @@ print.svyglm.nb <- function(x, se = c("robust", "model"), digits = 4, ...) {
}



#' @export
print.svyglm.zip <- function(x, se = c("robust", "model"), digits = 4, ...) {
se <- match.arg(se)
Expand All @@ -47,7 +46,6 @@ print.svyglm.zip <- function(x, se = c("robust", "model"), digits = 4, ...) {
}



tidy_svyglm.nb <- function(x, digits = 4, v_se = c("robust", "model")) {
v_se <- match.arg(v_se)

Expand All @@ -70,7 +68,6 @@ tidy_svyglm.nb <- function(x, digits = 4, v_se = c("robust", "model")) {
}



tidy_svyglm.zip <- function(x, digits = 4, v_se = c("robust", "model")) {
v_se <- match.arg(v_se)

Expand All @@ -92,44 +89,38 @@ tidy_svyglm.zip <- function(x, digits = 4, v_se = c("robust", "model")) {
}



#' @export
model.frame.svyglm.nb <- function(formula, ...) {
pred <- attr(formula, "nb.terms", exact = TRUE)
formula$design$variables[intersect(pred, colnames(formula$design$variables))]
}



#' @export
model.frame.svyglm.zip <- function(formula, ...) {
pred <- attr(formula, "zip.terms", exact = TRUE)
formula$design$variables[intersect(pred, colnames(formula$design$variables))]
}


#' @importFrom stats family
#' @export
family.svyglm.nb <- function(object, ...) {
attr(object, "family", exact = TRUE)
}



#' @export
formula.svyglm.nb <- function(x, ...) {
attr(x, "nb.formula", exact = TRUE)
}



#' @export
formula.svyglm.zip <- function(x, ...) {
attr(x, "zip.formula", exact = TRUE)
}



#' @export
predict.svyglm.nb <- function(object, newdata = NULL,
type = c("link", "response", "terms"),
Expand Down Expand Up @@ -212,51 +203,18 @@ deviance.svyglm.nb <- function(object, ...) {
}


#' @export
print.tidy_stan <- function(x, ...) {
insight::print_color("\nSummary Statistics of Stan-Model\n\n", "blue")
digits <- attr(x, "digits")

for (i in x) {
insight::print_color(paste0("# ", attr(i, "main_title")), "blue")
cat(" ")
insight::print_color(attr(i, "sub_title"), "red")
cat("\n\n")
rem <- which(colnames(i) %in% c("Parameter", "Group", "Response", "Function"))
i <- i[, -rem]
colnames(i)[1] <- "Parameter"
i$ESS <- as.character(i$ESS)
i$pd <- sprintf("%.1f%%", 100 * i$pd)
i[] <- lapply(i, function(.j) {
if (is.numeric(.j)) .j <- sprintf("%.*f", digits, .j)
.j
})
print.data.frame(i, quote = FALSE, row.names = FALSE)
cat("\n\n")
}
}


clean_term_name <- function(x) {
x <- insight::trim_ws(x)
format(x, width = max(nchar(x)))
}


#' @export
as.integer.sj_resample <- function(x, ...) {
x$id
}



#' @export
as.data.frame.sj_resample <- function(x, ...) {
x$data[x$id, , drop = FALSE]
}



#' @export
print.sj_resample <- function(x, ...) {
n <- length(x$id)
Expand All @@ -275,7 +233,6 @@ print.sj_resample <- function(x, ...) {
}



#' @export
plot.sj_inequ_trend <- function(x, ...) {
.data <- NULL
Expand Down Expand Up @@ -319,78 +276,6 @@ plot.sj_inequ_trend <- function(x, ...) {
}


#' @export
print.sj_mwu <- function(x, ...) {
insight::print_color("\n# Mann-Whitney-U-Test\n\n", "blue")
# get data
.dat <- x$df
# print to console
for (i in seq_len(nrow(.dat))) {
# get value labels
l1 <- .dat[i, "grp1.label"]
l2 <- .dat[i, "grp2.label"]
# do we have value labels?
if (!is.null(l1) && !is.na(l1) %% !is.null(l2) && !is.na(l2)) {
insight::print_color(
sprintf(
"Groups %i = %s (n = %i) | %i = %s (n = %i):\n",
.dat[i, "grp1"],
l1,
.dat[i, "grp1.n"],
.dat[i, "grp2"],
l2,
.dat[i, "grp2.n"]
), "cyan"
)
} else {
insight::print_color(
sprintf("Groups (%i|%i), n = %i/%i:\n",
.dat[i, "grp1"], .dat[i, "grp2"],
.dat[i, "grp1.n"], .dat[i, "grp2.n"]),
"cyan"
)
}

cat(sprintf(
" U = %.3f, W = %.3f, %s, Z = %.3f\n",
.dat[i, "u"], .dat[i, "w"], insight::format_p(.dat[i, "p"]), .dat[i, "z"]
))

string_es <- "effect-size r"
string_r <- sprintf("%.3f", .dat[i, "r"])
string_group1 <- sprintf("rank-mean(%i)", .dat[i, "grp1"])
string_group2 <- sprintf("rank-mean(%i)", .dat[i, "grp2"])
string_rm1 <- sprintf("%.2f", .dat[i, "rank.mean.grp1"])
string_rm2 <- sprintf("%.2f", .dat[i, "rank.mean.grp2"])

space1 <- max(nchar(c(string_es, string_group1, string_group2)))
space2 <- max(nchar(c(string_r, string_rm1, string_rm2)))

cat(
sprintf(" %*s = %*s\n", space1, string_es, space2 + 1, string_r),
sprintf(" %*s = %*s\n", space1, string_group1, space2, string_rm1),
sprintf(" %*s = %*s\n\n", space1, string_group2, space2, string_rm2)
)
}

# if we have more than 2 groups, also perfom kruskal-wallis-test
if (length(unique(stats::na.omit(x$data$grp))) > 2) {
insight::print_color("# Kruskal-Wallis-Test\n\n", "blue")
kw <- stats::kruskal.test(x$data$dv, x$data$grp)
cat(sprintf("chi-squared = %.3f\n", kw$statistic))
cat(sprintf("df = %i\n", kw$parameter))
cat(paste(insight::format_p(kw$p.value, stars = TRUE), "\n"))
}
}


#' @export
print.sj_outliers <- function(x, ...) {
print(x$result, ...)
}


#' @importFrom insight format_p
#' @export
print.sj_xtab_stat <- function(x, ...) {
# get length of method name, to align output
Expand All @@ -414,63 +299,6 @@ print.sj_xtab_stat <- function(x, ...) {
}



#' @export
print.sj_xtab_stat2 <- function(x, ...) {
# get length of method name, to align output
l <- max(nchar(c(x$stat.name, "p-value", "Observations")))

# headline
insight::print_color(paste0("\n# ", x$method, "\n\n"), "blue")

# print test statistic
cat(sprintf(" %*s: %.4f\n", l, x$stat.name, x$estimate))
cat(sprintf(" %*s: %g\n", l, "df", x$df))
cat(sprintf(" %*s: %s\n", l, "p-value", insight::format_p(x$p.value, stars = TRUE, name = NULL)))
cat(sprintf(" %*s: %g\n", l, "Observations", x$n_obs))
}



#' @export
print.sj_grpmean <- function(x, ...) {
cat("\n")
print_grpmean(x, digits = attributes(x)$digits, ...)
}


#' @importFrom insight export_table print_color format_value format_p
print_grpmean <- function(x, digits = NULL, ...) {
# headline
insight::print_color(sprintf(
"# Grouped Means for %s by %s\n\n",
attr(x, "dv.label", exact = TRUE),
attr(x, "grp.label", exact = TRUE)
), "blue")

if (is.null(digits)) {
digits <- 2
}

x$mean <- insight::format_value(x$mean, digits = digits)
x$std.dev <- insight::format_value(x$std.dev, digits = digits)
x$std.error <- insight::format_value(x$std.error, digits = digits)
x$p.value <- insight::format_p(x$p.value, name = NULL)

colnames(x) <- c("Category", "Mean", "N", "SD", "SE", "p")
cat(insight::export_table(x))

# statistics
cat(sprintf(
"\nAnova: R2=%.3f; adj.R2=%.3f; F=%.3f; p=%.3f\n",
attr(x, "r2", exact = TRUE),
attr(x, "adj.r2", exact = TRUE),
attr(x, "fstat", exact = TRUE),
attr(x, "p.value", exact = TRUE)
))
}


#' @export
print.sj_chi2gof <- function(x, ...) {
insight::print_color("\n# Chi-squared Goodness-of-Fit Test\n\n", "blue")
Expand Down Expand Up @@ -538,18 +366,6 @@ print.sj_ttest <- function(x, ...) {
}


#' @export
print.sj_wmwu <- function(x, ...) {
insight::print_color(sprintf("\n# %s\n", x$method), "blue")

group <- attr(x, "group.name", exact = TRUE)
xn <- attr(x, "x.name", exact = TRUE)

insight::print_color(sprintf("\n comparison of %s by %s\n", xn, group), "cyan")
cat(sprintf(" Chisq=%.2f df=%i p-value=%.3f\n\n", x$statistic, as.integer(x$parameter), x$p.value))
}


#' @export
print.sj_wcor <- function(x, ...) {
insight::print_color(sprintf("\nWeighted %s\n\n", x$method), "blue")
Expand All @@ -565,7 +381,6 @@ print.sj_wcor <- function(x, ...) {
}


#' @importFrom insight export_table
#' @export
print.sj_anova_stat <- function(x, digits = 3, ...) {
x$p.value <- insight::format_p(x$p.value, name = NULL)
Expand Down
2 changes: 1 addition & 1 deletion R/boot_ci.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@
#' @param data A data frame that containts the vector with bootstrapped
#' estimates, or directly the vector (see 'Examples').
#' @param ci.lvl Numeric, the level of the confidence intervals.
#' @param Select Optional, unquoted names of variables (as character vector)
#' @param select Optional, unquoted names of variables (as character vector)
#' with bootstrapped estimates. Required, if either `data` is a data frame
#' (and no vector), and only selected variables from `data` should be processed.
#' @param method Character vector, indicating if confidence intervals should be
Expand Down
2 changes: 1 addition & 1 deletion R/helpfunctions.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@ get_glm_family <- function(fit) {
# create logical for family
binom_fam <- fitfam %in% c("binomial", "quasibinomial")
poisson_fam <- fitfam %in% c("poisson", "quasipoisson") ||
grepl("negative binomial", fitfram, ignore.case = TRUE, fixed = TRUE)
grepl("negative binomial", fitfam, ignore.case = TRUE, fixed = TRUE)

list(is_bin = binom_fam, is_pois = poisson_fam, is_logit = logit_link)
}
Expand Down
8 changes: 3 additions & 5 deletions R/se_ybar.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,11 +12,9 @@
#'
#' @references Gelman A, Hill J. 2007. Data analysis using regression and multilevel/hierarchical models. Cambridge, New York: Cambridge University Press
#'
#' @examples
#' if (require("lme4")) {
#' fit <- lmer(Reaction ~ 1 + (1 | Subject), sleepstudy)
#' se_ybar(fit)
#' }
#' @examplesIf require("lme4")
#' fit <- lmer(Reaction ~ 1 + (1 | Subject), sleepstudy)
#' se_ybar(fit)
#' @export
se_ybar <- function(fit) {
# get model icc
Expand Down
2 changes: 1 addition & 1 deletion R/select_helpers.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,5 +31,5 @@ obj_has_name <- function(x, name) {
}

obj_has_rownames <- function(x) {
!identical(as.character(1:nrow(x)), rownames(x))
!identical(as.character(seq_len(nrow(x))), rownames(x))
}
Loading

0 comments on commit 8cfa72e

Please sign in to comment.