#' Tbll_desc
#'
#' @param ... an prepare_data2
#' @param caption besser mit Output verwenden
#' @param include.n,include.nr,include.total,include.multiresponse weitere param
#' @param include.test,include.normality.tests Test
#' @param include.label Labels ja-nein
#' @param exclude,exclude.level,max_factor_length fuer factor
#' @param include.custom eigene Funktion mit (x, by, fun) return kann ein Vector oder eine Matrix sein
#' function(x , by, ...){
#' x <- scale(as.numeric(x))
#' diff(sapply(split(x, by), mean, na.rm=TRUE))})
#' @param include.value vector oder data.frame in exact der reihenfolge wie die meassure-variablen.
#' @return data.frame
#' @export
#' @examples
#'
#' Tbll_desc(
#' warpbreaks,
#' "H1",
#' breaks,
#' tension,
#' by = ~ wool,
#' include.total = TRUE,
#' include.n = FALSE,
#' include.test = TRUE)
#'
#'
#' warpbreaks2 <- Label(warpbreaks,
#' breaks = "The number of breaks",
#' wool = "The type of wool",
#' tension = "The level of tension")
#' warpbreaks2$tension2 <- as.numeric(warpbreaks2$tension)
#'
#' warpbreaks2 %>%
#' Tbll_desc(breaks + tension ~ wool)
#' warpbreaks2 %>%
#' Tbll_desc_long(breaks + tension ~ wool)
#' Tbll_corr(breaks ~ tension2, warpbreaks2, groups = ~ wool)
#'
#' Tbll_xtabs( ~ tension + wool, warpbreaks2, include.label = FALSE)
#'
#' lm1 <- lm(breaks ~ wool + tension, data = warpbreaks2)
#' lm2 <- lm(breaks ~ wool * tension, data = warpbreaks2)
#'
#' # aufruf von APA_Table()
#' Tbll_reg(
#' lm1,
#' lm2,
#' include.p = FALSE,
#' include.ci = TRUE,
#' include.se = FALSE,
#' caption = "Regression Table"
#' )
#'
#' # aufruf von APA2()
#' Tbll_reg(lm1, lm2)
#'
#'
#' Tbll_desc(
#' warpbreaks,
#' # "H1",
#' breaks,
#' tension,
#' by = ~ wool,
#' # include.total = TRUE,
#' # include.n = FALSE,
#' include.test = TRUE,
#' include.value = c(breaks = "ES = 26", tension = "OR = .0256")
#'
#' )
#'
#' Tbll_desc(
#' warpbreaks,
#' # "H1",
#' breaks,
#' tension,
#' by = ~ wool,
#' # include.total = TRUE,
#' # include.n = FALSE,
#' include.test = TRUE,
#' include.value = data.frame(ES=1:2, OR= 3:4)
#'
#' )
#'
Tbll_desc <- function (...,
caption="",
include.label=TRUE,
include.n = TRUE,
include.nr = FALSE,
include.total = FALSE,
include.test = FALSE,
include.normality.tests=FALSE,
include.multiresponse=FALSE,
include.custom = NULL,
include.value = NULL,
include.ci=FALSE,
digits=NULL
) {
note<-""
rslt_all <- NULL
ans <- NULL
if( include.ci ){
cat("\ninclude.ci wird über die options() gesteuert!\n\n")
cat('set_my_options(mittelwert=list( mean.style="ci" ))')
cat("\n")
cat('set_my_options(prozent=list( style="%ci" ))')
cat("\n")
stop( "include.ci=TRUE" )
}
X <- stp25formula::prepare_data2(...)
n <- length(X$measure.vars)
any_missing_measure <-
sapply(X$data[X$measure.vars],
function(x) length(na.omit(x)))
if(!include.label)
X$row_name <- X$measure.vars
if ( include.n & sum(any_missing_measure[X$measure!="header"]-X$N) == 0 ) {
# keine fehlenden dann nur erste Zeile mit N
include.n <- FALSE
include.nr <- TRUE
}
if (include.multiresponse){
# wegen Formel und weil hie auch Zhlen kommen
if(!is.null(digits)) X$digits <- rep(0, length(X$digits))
X$measure <- rep("multi", length(X$measure))
}
# start der eigendlichen funktion
# 1. Mittelweret mit purrr::pmap
#
if (is.null(X$group.vars) | include.total) {
rslt_all <-
list_rbind(purrr::pmap(
list(
x = X$data[X$measure.vars],
digits = X$digits,
measure = X$measure,
row_name = X$row_name
),
.calc_desc_mean
))
if (include.total)
names(rslt_all)[3:4] <-
paste0("Total_", names(rslt_all)[3:4])
}
if (!is.null(X$group.vars)) {
if (length(X$group.vars) > 1) {
X$data$group <- interaction2(X$data[X$group.vars])
caption <- paste(paste(X$group.vars, collapse=", "), caption)
X$group.vars <- "group"
} else { caption <- paste( X$group.vars, caption) }
data <-
split(X$data[X$measure.vars], X$data[[X$group.vars]])
# gruppe einzeln auswerten
for (i in names(data)) {
ans_i <-
list_rbind(purrr::pmap(
list(
x = data[[i]],
digits = X$digits,
measure = X$measure,
row_name = X$row_name
),
.calc_desc_mean
))
if (is.null(ans))
ans <- ans_i[1:2]
names(ans_i) <- paste0(i, "_", names(ans_i))
ans <- cbind(ans, ans_i[-c(1:2)])
}
if (include.total)
rslt_all <- cbind(rslt_all, ans[-c(1:2)])
else
rslt_all <- ans
# print(ans)
}
# print(rslt_all)
if (include.nr) {
if (is.null(X$group.vars)) {
#cat("\nis.null\n")
n.out <- c("(N)", "", "", X$N)
names(n.out) <- names(rslt_all)
rslt_all <- rbind(n.out, rslt_all)
}
else {
tsum <- table(X$data[[X$group.vars]])
if (include.total) {
#cat("\nif\n")
n.out <- c("(N)", rep("", ncol(rslt_all) + 4))
n.out[ stringr::str_ends(names(rslt_all), "_m") ] <-
as.character(c(sum(tsum), as.vector(tsum)))
# n.out[grep("_m", names(rslt_all))] <-
# as.character(c(sum(tsum), as.vector(tsum)))
} else{
# cat("\nelse\n")
n.out <- c("(N)", rep("", ncol(rslt_all) + 2))
n.out[stringr::str_ends(names(rslt_all), "_m")] <- as.character(tsum)
# n.out[grep("_m", names(rslt_all))] <- as.character(tsum)
}
rslt_all <- rbind(n.out, rslt_all)
}
}
# cat("\n nach include.nr\n")
# print(rslt_all)
if (!include.n) {
length.out <- if(is.null(X$group.vars)) 1 else nlevels(X$data[[X$group.vars]]) + include.total
rslt_all <-
rslt_all[-(seq(
from = 3,
by = 2,
length.out = length.out
))]
names(rslt_all) <- gsub("_m$", "", names(rslt_all))
}
#cat("\n nach include.n\n")
#print(rslt_all)
# Eigene Funktion fun(x, by, measure, measure.test)
# return vector ode matrix
# die länge ist gleich wie bei measure oder die anzahl an factoren
#
if (!is.null(include.custom)) {
rslt_custom <- NULL
# schleife statt purrr::pmap weil es einfacher lesbar ist
for (i in seq_len(n)) {
if (is.null(X$group.vars))
tmp <- do.call(
include.custom, # include.custom ist eine function
list(
X$data[[X$measure.vars[i]]],
measure = X$measure[i],
measure.test = X$measure.test[i]
)
)
else
tmp <- do.call(
include.custom,
list(
X$data[[X$measure.vars[i]]],
X$data[[X$group.vars[1]]],
measure = X$measure[i],
measure.test = X$measure.test[i]
)
)
# tmp kann ein vector der laenge 1 oder eine matrix sein
if (is.vector(tmp)) {
if (X$measure[i] != "factor") {
rslt_custom <- append(rslt_custom, tmp)
}
else if (X$measure[i] == "factor" & length(tmp) == 1) {
rslt_custom <- append(rslt_custom, tmp)
rslt_custom <-
append(rslt_custom, rep("", nlevels(X$data[[X$measure.vars[i]]])))
} else if (X$measure[i] == "factor" &
length(tmp) == nlevels(X$data[[X$measure.vars[i]]])) {
rslt_custom <- append(rslt_custom, c("", tmp))
} else{
stop("In rslt_custom stimmen die Laenge derRueckgabe nicht!")
}
}
else{
if (X$measure[i] != "factor") {
rslt_custom <- rbind(rslt_custom, tmp)
}
else if (X$measure[i] == "factor" & nrow(tmp) == 1) {
rslt_custom <- rbind(rslt_custom, tmp)
rslt_custom <- rbind(rslt_custom,
matrix(
"",
ncol = ncol(rslt_custom),
nrow = nlevels(X$data[[X$measure.vars[i]]])
))
}
else if (X$measure[i] == "factor" &
nrow(tmp) == nlevels(X$data[[X$measure.vars[i]]])) {
rslt_custom <- rbind(rslt_custom,
matrix("",
ncol = ncol(rslt_custom),
nrow = 1))
rslt_custom <- rbind(rslt_custom, tmp)
} else{
stop("In rslt_custom stimmen die Laenge derRueckgabe nicht!")
}
}
}
if (is.vector(rslt_custom)) {
if (include.nr)
rslt_custom <- append(rslt_custom, "", after = 0)
rslt_all$custom <- rslt_custom
}
else {
# is.matrix
if (include.nr)
rslt_custom <- rbind(rep("", ncol(rslt_custom)), rslt_custom)
rslt_all <- cbind(rslt_all, rslt_custom)
}
}
if (is.character(include.test)) {
include.test <- gsub("[^[:alpha:]]", "", tolower(include.test))
which_test <-
match.arg(include.test,
c(contest, cattest, notest, ordtest, disttest, cortest))
X$measure.test <- rep(which_test, length(X$measure.test))
if (which_test %in% disttest) {
include.test <- FALSE
include.normality.tests <- TRUE
} else{
include.test <- TRUE
}
}
if (include.test) {
rslt_test <- NULL
for (i in seq_len(n)) {
temp <- NULL
fm_chi <-
formula(paste("~", X$measure.vars[i], "+", X$group.vars[1]))
fm_aov <-
formula(paste(X$measure.vars[i], "~", X$group.vars[1]))
if (X$measure.test[i] == "notest") {
rslt_test <- append(rslt_test, "")
}
else if (X$measure.test[i] == "contest") {
if (X$measure.class[i] == "factor") {
temp <- X$data[[X$measure.vars[i]]]
X$data[[X$measure.vars[i]]] <-
as.numeric(X$data[[X$measure.vars[i]]])
}
rslt_test <-
append(rslt_test, conTest(fm_aov, X$data))
}
else if (X$measure.test[i] == "cattest") {
rslt_test <- append(rslt_test, catTest(fm_chi, X$data))
}
else if (X$measure.test[i] %in% contest) {
if (X$measure.class[i] == "factor") {
temp <- X$data[[X$measure.vars[i]]]
X$data[[X$measure.vars[i]]] <-
as.numeric(X$data[[X$measure.vars[i]]])
}
rslt_test <-
append(rslt_test, conTest(fm_aov, X$data, X$measure.test[i]))
}
else if (X$measure.test[i] %in% cattest) {
rslt_test <-
append(rslt_test, catTest(fm_chi, X$data, X$measure.test[i]))
}
if (!is.null(temp))
X$data[[X$measure.vars[i]]] <- temp
if (X$measure[i] == "factor")
rslt_test <-
append(rslt_test, rep("", nlevels(X$data[[X$measure.vars[i]]])))
}
if(include.nr) rslt_test <- append(rslt_test, "", after = 0)
note <- paste(unique(names(rslt_test)[nzchar(names(rslt_test))]), collapse = ", ")
rslt_all$statistics <- rslt_test
}
if (include.normality.tests) {
rslt_disttest <- NULL
for (i in seq_len(n)) {
if (X$measure[i] %in% c("numeric", "mean", "median")) {
ix <- na.omit(as.numeric(X$data[[X$measure.vars[i]]]))
if (X$measure.test[i] == "kstest")
r <- APA(stats::ks.test(ix, "pnorm", mean(ix), sd(ix)))
else
r <- APA(stats::shapiro.test(ix))
} else if (X$measure[i] == "factor")
r <- rep("", nlevels(X$data[[X$measure.vars[i]]]))
else
r <- ""
rslt_disttest <- append(rslt_disttest, r)
}
if (include.nr)
rslt_disttest <- append(rslt_disttest, "", after = 0)
note<- X$measure.test[1]
rslt_all$normality.tests <- rslt_disttest
}
if (!is.null(include.value)) {
rslt_custom <- NULL
if (is.vector(include.value)) {
cat("\n in vector")
for (i in seq_len(n)) {
# include.value[i] kann ein vector der laenge 1 oder eine matrix sein
if (X$measure[i] != "factor") {
rslt_custom <- append(rslt_custom, include.value[i])
}
else if (X$measure[i] == "factor" &
length(include.value[i]) == 1) {
rslt_custom <- append(rslt_custom, include.value[i])
rslt_custom <-
append(rslt_custom, rep("", nlevels(X$data[[X$measure.vars[i]]])))
} else if (X$measure[i] == "factor" &
length(include.value[i]) == nlevels(X$data[[X$measure.vars[i]]])) {
rslt_custom <- append(rslt_custom, c("", include.value[i]))
} else{
stop("In rslt_custom stimmen die Laenge derRueckgabe nicht!")
}
}
}
else{
cat("\n in matrix")
for (i in seq_len(n)) {
cat("\n i = ", i, "\n")
print(X$measure[i])
print( include.value[i,] )
if (X$measure[i] != "factor") {
cat( " kein Factor ")
rslt_custom <- rbind(rslt_custom, include.value[i,])
}
else if (X$measure[i] == "factor" & nrow(include.value[i,]) == 1) {
cat( " Factor und nrow = 1 " )
rslt_custom <- rbind(rslt_custom, include.value[i,])
print(rslt_custom)
rslt_custom <- rbind(rslt_custom,
matrix(
"",
ncol = ncol(rslt_custom),
nrow = nlevels(X$data[[X$measure.vars[i]]]),
dimnames = list(NULL,
colnames(( include.value ))))
)
}
else if (X$measure[i] == "factor" &
nrow(include.value[i,]) == nlevels(X$data[[X$measure.vars[i]]])) {
cat( " Factor und irgendwas " )
rslt_custom <- rbind(rslt_custom,
matrix("",
ncol = ncol(rslt_custom),
nrow = 1,
dimnames = list(NULL,
colnames(( include.value ))))
)
rslt_custom <- rbind(rslt_custom, include.value[i,])
} else{
stop("In rslt_custom stimmen die Laenge derRueckgabe nicht!")
}
}
}
if (is.vector(rslt_custom)) {
if (include.nr)
rslt_custom <- append(rslt_custom, "", after = 0)
rslt_all$value <- rslt_custom
}
else {
# is.matrix
if (include.nr)
rslt_custom <- rbind(rep("", ncol(rslt_custom)), rslt_custom)
rslt_all <- cbind(rslt_all, rslt_custom)
}
}
rslt_all[[1]] <- paste(rslt_all[[1]], rslt_all[[2]])
# cat("\n vore prepare \n")
# print(rslt_all)
prepare_output(rslt_all[-2], caption = caption, note=note, N=X$N)
}
#' @param include.n,include.mean,include.median,include.sd,include.range Masszahlen
#' @param include.shapiro,include.ks Normalverteilung Tests
#' @param include.skew,include.kurtosi Eigenschaften
#'
#' @rdname Tbll_desc
#' @export
#' @examples
#'
#' df <- data.frame(
#' month = rep(1:3, 2),
#' student = factor(rep(c("Amy", "Bob"), each = 3)),
#' A = c(9, 7, 6, 8, 6, 9),
#' B = c(6, 7, 8, 5, 6, 7)
#' )
#'
#' Tbll_desc_item( ~ A + B + student, df)
#'
#'
Tbll_desc_item <- function(...,
caption = "",
# include.label = TRUE,
include.n = TRUE,
# include.missing = TRUE,
include.mean = TRUE,
include.median = FALSE,
include.sd = TRUE,
include.range = TRUE,
include.shapiro = TRUE,
include.ks = FALSE,
include.skew = TRUE,
include.kurtosi = include.skew,
# na.omit = FALSE,
digits = 2) {
note = ""
X <- stp25formula::prepare_data2(...)
# n_col <- length(X$measure.vars)
n_row <- length(X$data)
X$data[X$measure.vars] <- dapply2(X$data[X$measure.vars])
result <- Summarise(
X$formula,
X$data,
fun = function(x) {
x <- na.omit(as.numeric(x))
rslt <- c()
if (include.n)
rslt <-
append(rslt,
c(n = stp25rndr::Format2(length(x), 0)), 0)
if (include.mean)
rslt <-
append(rslt,
c(M = stp25rndr::Format2(mean(x), digits)))
if (include.sd)
rslt <-
append(rslt,
c(SD = stp25rndr::Format2(sd(x), digits)))
if (include.median)
rslt <-
append(rslt,
c(Median = stp25rndr::Format2(median(x), digits)))
if (include.range)
rslt <-
append(rslt,
c(Range = paste0(
"[", paste(stp25rndr::Format2(range(x), digits), collapse = ", "), "]"
)))
if (include.skew | include.kurtosi)
rslt <-
append(rslt,
c(
Skew = stp25rndr::Format2(psych::skew(x), 2),
Kurtosi = stp25rndr::Format2(stp25rndr::Format2(psych::kurtosi(x), 2))
))
if (include.ks)
rslt <-
append(rslt, c(KS.Test = APA(
stats::ks.test(x, "pnorm", mean(x), sd(x))
)))
if (include.shapiro)
rslt <-
append(rslt, c(Shapiro.Test = APA(stats::shapiro.test(x))))
rslt
}
)
result[[1]] <- as.character(result[[1]])
is_transformt <- X$measure.vars[which(X$measure.class != "numeric")]
if (length(is_transformt) > 0) {
note <-
paste("Transformed to numeric:",
paste(is_transformt, collapse = ", "))
}
prepare_output(result,
caption = caption,
note = note,
N = n_row)
}
#' @rdname Tbll_desc
#' @export
Tbll_desc_multi <- function(...,
by = NULL,
digits = 0,
include.order = TRUE) {
rslt <- Tbll_desc(
...,
by = by,
include.multiresponse = TRUE,
digits = digits
)
if (include.order) {
rslt_order <- Summarise(
...,
fun = function(x) {
x <- na.omit(x)
if (is.logical(x))
mean(x)
else if (is.numeric(x))
mean(x == 1)
else
mean(x == levels(x)[1])
}
)
rslt <- rslt[order( rslt_order$value, decreasing = TRUE),]
}
rslt
}
#' @noRd
#'
#' @description Kopie von interaction
#' die Labels werden anderst sortiert.
#'
#' i lauft in umgekehrter richtung und past ist auch umgedreht ansonsten identich mit interaction
#'
#' @param ... the factors for
#' @param sep string to construct the new level labels by joining the constituent ones.
#'
#' @examples
#'
#' interaction2(
#' gl(2, 8, labels = c("Z", "X")),
#' gl(2, 8, labels = c( "A","B")),
#' gl(2, 8, labels = c( "a","b"))
#' )
#'
interaction2 <-
function (...,
sep = "_") {
args <- list(...)
narg <- length(args)
if (narg < 1L)
stop("No factors specified")
if (narg == 1L && is.list(args[[1L]])) {
args <- args[[1L]]
narg <- length(args)
}
# orginal for (i in narg:1L)
for (i in 1L:narg) {
# cat("\n", i, narg, "\n")
f <- as.factor(args[[i]])[, drop = FALSE]
l <- levels(f)
if1 <- as.integer(f) - 1L
# Orginal if (i == narg) {
if (i == 1) {
ans <- if1
lvs <- l
}
else {
ans <- ans * length(l) + if1
lvs <- paste(rep(lvs, each = length(l)),
rep(l, length(lvs)),
sep = sep)
#orginal paste(rep(l, each = ll), rep(lvs, length(l))
if (anyDuplicated(lvs)) {
ulvs <- unique(lvs)
while ((i <- anyDuplicated(flv <- match(lvs, ulvs)))) {
lvs <- lvs[-i]
ans[ans + 1L == i] <- match(flv[i], flv[1:(i - 1)]) - 1L
ans[ans + 1L > i] <- ans[ans + 1L > i] - 1L
}
lvs <- ulvs
}
}
}
structure(as.integer(ans + 1L),
levels = lvs,
class = "factor")
}
#' @param include.mean mean + sd
#' @param include.stars,include.p P-Wert
#' @param cor_diagonale_up diagonale
#' @param type c("pearson", "spearman"
#'
#' @rdname Tbll_desc
#' @export
#' @examples
#'
#' #' require(stpvers)
#' n <- 2 * 20
#' e <- rnorm(n)
#' dat <- stp25aggregate::Label(
#' data.frame(
#' a = rnorm(n) + e / 2,
#' b = rnorm(n) + e,
#' c = rnorm(n),
#' d = rnorm(n) + e * 10,
#' g = gl(2, 20, labels = c("Control", "Treat"))
#' ),
#' a = "Alpha",
#' b = "Beta",
#' c = "Gamma"
#' )
#'
#'
#' Tbll_corr( ~ a + b + c, dat)
#' Tbll_corr(a ~ c, dat)
#' Tbll_corr(a + b + c ~ d, dat)
#' Tbll_corr(a + b + c ~ d, dat, groups = ~ g)
#'
#'
Tbll_corr <-
function(...,
caption="",
include.label=TRUE,
include.mean = FALSE,
include.n = TRUE,
include.stars = TRUE,
include.p = FALSE,
cor_diagonale_up = TRUE,
type = c("pearson", "spearman")) {
Hmisc_rcorr(
...,
cor_diagonale_up = cor_diagonale_up,
include.stars = include.stars,
include.p = include.p,
include.mean = include.mean,
include.n = include.n,
type = type,
caption = caption,
note = ""
)
}
#' @rdname Tbll_desc
#' @export
#'
#' @examples
#'
#'
#' data(infert, package = "datasets")
#' infert$case <- factor(infert$case , 1:0, c("case", "control"))
#'
#' infert$spontaneous <- factor(infert$spontaneous)
#' infert$induced2 <- factor(infert$induced == 0)
#'
#' Tbll_xtabs( ~ case, infert)
#' Tbll_xtabs( ~ induced2 + case, infert)
#' Tbll_xtabs( ~ induced + case, infert)
#' Tbll_xtabs( ~ induced + education, infert)
#'
#'
#' Tbll_xtabs( ~ induced + education + case,
#' infert,
#' margin = "case",
#' # add.margins = c("education", "induced"),
#' include.count = FALSE)
#'
#' Tbll_xtabs(
#' ~ induced + education + case,
#' infert,
#' margin = "case",
#' add.margins = c("case"),
#' include.count = FALSE
#' )
#'
#'
#'
Tbll_xtabs <- function(...,
caption="",
include.label=TRUE,
include.count = TRUE,
include.percent = TRUE,
include.total = FALSE,
include.prop.chisq = FALSE,
include.chisq = FALSE,
include.fisher = FALSE,
include.test = any(c(include.fisher,
include.chisq,
include.prop.chisq)),
include.correlation = FALSE,
include.diagnostic = FALSE,
margin = NULL,
add.margins = NA) {
rslt <- APA_Xtabs(
...,
caption=caption,
label=include.label,
include.percent = include.percent,
include.count = include.count,
include.total = include.total,
margin = margin,
add.margins = add.margins,
include.prop.chisq = include.prop.chisq,
include.chisq = include.chisq,
include.fisher = include.fisher,
include.test = include.test,
include.correlation = include.correlation,
include.diagnostic = include.diagnostic,
output = FALSE
)
rslt
}
#' Leerer Data.Frame
#'
#' @noRd
.emty_tbll <- function() {
data.frame(
lev = "",
n = "",
m = "",
stringsAsFactors = FALSE
)
}
#' Die Berechnung
#'
#' @noRd
.calc_desc_mean <- function(x,
digits,
measure,
row_name,
sep = paste(stp25rndr::symbol_nbsp(), stp25rndr::symbol_nbsp()),
exclude = NA,
max_factor_length = 35,
...) {
x <- na.omit(x)
n <- length(x)
rslt <- NULL
res <- switch(
measure,
numeric = Mean2default(x, digits, n),
integer = Mean2default(x, digits, n),
factor = Prozent2default(x, digits, n, exclude, max_factor_length),
logical = Prozent2default(x, digits, n, exclude, max_factor_length),
mean = Mean2default(x, digits, n),
median = Median2default(x, digits, n),
multi = Multi2default(x, digits, n),
header = .emty_tbll(),
.emty_tbll()
)
if (measure == "factor") {
x0 <- data.frame(
Item = row_name,
lev = "",
n = res$n[1] ,
m = "",
stringsAsFactors = FALSE
)
res$n <- ""
x1 <- cbind(Item = sep, res)
rslt <- rbind(x0, x1)
} else
rslt <-
cbind(Item = c(row_name, rep("", nrow(res) - 1)), res)
rslt
}
#' liste als DF
#'
#' @noRd
list_rbind <- function(l)
as.data.frame(do.call(rbind, (l)))
#' effect_size
#'
#' Cohen's d d=(x1-x2)/s psych::cohen.d
#' Hedges' g g= (x1-x2)/s1s2 ( pooled standard deviation)
#' g enspricht x<-scale(x) (mean(x1) - mean(x2))
#'
#' Generalized Log Odds Ratios for Frequency Tables vcd::oddsratio
#'
#' @param x vector
#' @param by factor
#' @param measure intern c("mean", "median", "numeric", "factor", "logical")
#' @param measure.test, test intern c("cattest", "contest", "notest", "ttest", ...)
#'
#' @examples
#'
#' effect_size(c(2, 3, 4, 2, 3, 4, 3, 6,
#' 7, 6, 8, 9, 4, 5, 6, 7) ,
#' gl(2, 8, labels = c("Control", "Treat")))
#' x<- c(2, 3, 4, 2, 3, 4, 3, 6,7, 6, 8, 9, 4, 5, 6, 7)
#' y<- factor(c(2, 2, 2, 2, 1, 1, 1, 1, 2, 2, 2, 2, 1, 2, 1, 2))
#' z<- gl(2, 8, labels = c("Control", "Treat"))
#' rbind(
#' effect_size(x, z),
#' effect_size(y, z)
#' )
#'
effect_size <- function(x,
by,
measure,
measure.test,
# test =
# if (measure.test == "contest")
# coin::wilcox_test
# else
# coin::chisq_test)
...) {
dat <- na.omit(data.frame(x = x, by = by))
n <- nrow(dat)
es <- rslt <- ""
if (n > 10) {
if (measure.test == "contest") {
es <- try(psych::cohen.d(as.numeric(dat$x), dat$by), silent = TRUE)
if (is.character(es)) {
es <- " error "
}
else{
es <- stp25rndr::Format2(es$cohen.d)
es <- paste0(es[2], " [", es[1], ", ", es[3], "] ES")
}
}
else if (measure.test == "cattest") {
# Generalized Log Odds Ratios for Frequency Tables
if (measure == "factor" & nlevels(dat$x) != 2) {
es <- "n.a."
}
else{
es <- try(vcd::oddsratio(table(dat$x, dat$by), log = FALSE),
silent = TRUE)
if (is.character(es)) {
es <- " error "
}
else{
if (coef(es) < 0.01)
es <- "n.a."
else if (coef(es) > 100)
es <- "n.a."
else{
es <- stp25rndr::rndr_ods(c(coef(es) , confint(es)))
es <- paste0(es[1], " [", es[2], ", ", es[3], "] OR")
}
}
}
}
# rslt <-
# stp25stat::APA(do.call(test, list(x ~ by, dat)))
}
# cbind('Odds Ratio/Effect Size' = es,
# 'sig. Test' = rslt)
cbind('SDM/OR [95% CI]' = es)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.