@@ -1,6 +1,6 @@ | |||
Package: desctable | |||
Title: Produce Descriptive and Comparative Tables Easily | |||
Version: 0.1.7 | |||
Version: 0.1.8 | |||
Authors@R: c(person("Maxime", "Wack", email = "maximewack@free.fr", role = c("aut", "cre")), | |||
person("Adrien", "Boukobza", email = "hadrien_b@hotmail.fr", role = c("aut"))) | |||
Description: Easily create descriptive and comparative tables. | |||
@@ -16,13 +16,13 @@ URL: https://github.com/maximewack/desctable | |||
BugReports: https://github.com/maximewack/desctable/issues | |||
Imports: | |||
dplyr, | |||
purrr, | |||
DT, | |||
htmltools, | |||
pander | |||
Suggests: | |||
knitr, | |||
rmarkdown, | |||
purrr, | |||
survival | |||
RoxygenNote: 7.0.2 | |||
VignetteBuilder: knitr |
@@ -1,3 +1,9 @@ | |||
Version 0.1.8 | |||
- Code cleanup: | |||
- use RStudio style guidelines for all code and docs | |||
- use fewer tidyverse functions internally, drop `purrr` dependancy | |||
Version 0.1.7 | |||
- Vignette and README with RStudio style guidelines | |||
@@ -1,10 +1,18 @@ | |||
#' Generate one statistic for all variables | |||
#' | |||
#' Use one stat function (made safe using statify) on all the data | |||
#' to produce a single statistics column. | |||
#' | |||
#' The result is either a numeric vector, or a character vector if | |||
#' the content of the column is not made entirely of numbers. | |||
#' | |||
#' @param stat The statistic to use | |||
#' @param data The dataframe to apply the statistic to | |||
#' @return A vector for one statistic column | |||
statColumn <- function(stat, data) | |||
{ | |||
statColumn <- function(stat, data) { | |||
# Apply one statified stat function to every variable in the data | |||
# Return a simple vector for the column | |||
# Statify checks types and output for the stat function. Returns a numeric vector or a character vector if needed. | |||
data %>% | |||
lapply(statify, stat) %>% | |||
unlist() | |||
@@ -13,18 +21,25 @@ statColumn <- function(stat, data) | |||
#' Generate the table of all statistics for all variables | |||
#' | |||
#' If stats is a list of functions, use them. | |||
#' If it is a single function, use it with the entire data as | |||
#' its argument to produce a list of statistical functions to use. | |||
#' | |||
#' @param data The dataframe to apply the statistic to | |||
#' @param stats A list of named statistics to use | |||
#' @return A dataframe of all statistics for all variables | |||
statTable <- function(data, stats) | |||
{ | |||
# Call the stats arg_function passed, or use the provided list as-is | |||
if (is.function(stats)) | |||
stats = stats(data) | |||
statTable <- function(data, stats) { | |||
# If stats is a function, apply it to the data to obtain a list of stat functions | |||
# Else use the function list as-is | |||
if (is.function(stats)) stats = stats(data) | |||
# Compute a statColumn for every stat function in stats | |||
# Assemble the result in a dataframe | |||
stats %>% | |||
lapply(statColumn, data) %>% | |||
data.frame(check.names = F, row.names = NULL, stringsAsFactors = F) | |||
data.frame(check.names = F, | |||
row.names = NULL, | |||
stringsAsFactors = F) | |||
} | |||
@@ -40,38 +55,38 @@ statTable <- function(data, stats) | |||
#' @param data The dataframe to get the names from | |||
#' @param labels The optional named character vector containing the keypairs var = "Label" | |||
#' @return A dataframe with one variable named "Variables", a character vector of variable names/labels and levels | |||
varColumn <- function(data, labels = NULL) | |||
{ | |||
# Replace variable names by their labels, if they exist | |||
names(data) -> base_names | |||
varColumn <- function(data, labels = NULL) { | |||
# Every variable name that exists in the labels is to be replaced with its corresponding label | |||
# Labels for non-existing variables are ignored | |||
# Variables with no label are not replaced and used as-is | |||
base_names <- names(data) | |||
base_names[base_names %in% names(labels)] <- labels[base_names[base_names %in% names(labels)]] | |||
# Check if there are factors | |||
data %>% | |||
lapply(is.factor) %>% | |||
unlist() -> factors | |||
# Insert levels for factors after the variable name | |||
if (any(data %>% lapply(is.factor) %>% unlist())) | |||
{ | |||
data %>% | |||
lapply(is.factor) %>% | |||
unlist() %>% | |||
which() -> factors_idx | |||
if (any(factors)) { | |||
factors_idx <- which(factors) | |||
# Factor names in **bold** | |||
base_names[factors_idx] <- paste0("**", base_names[factors_idx], "**") | |||
factor_levels <- | |||
factors_idx %>% | |||
lapply(function(x) | |||
{ | |||
paste0(base_names[x], | |||
": ", | |||
"*", | |||
levels(data[[x]]), | |||
"*") | |||
}) | |||
insert(x = base_names, | |||
y = factor_levels, | |||
position = factors_idx) -> base_names | |||
# Factor levels in *italic* | |||
factor_levels <- lapply(factors_idx, function(x) paste0(base_names[x], ": ", "*", levels(data[[x]]), "*")) | |||
# Insert the factor levels after each factor name | |||
base_names <- insert(x = base_names, | |||
y = factor_levels, | |||
position = factors_idx) | |||
} | |||
data.frame(Variables = base_names, check.names = F, row.names = NULL, stringsAsFactors = F) | |||
data.frame(Variables = base_names, | |||
check.names = F, | |||
row.names = NULL, | |||
stringsAsFactors = F) | |||
} | |||
@@ -151,35 +166,32 @@ varColumn <- function(data, labels = NULL) | |||
#' iris %>% | |||
#' group_by(Petal.Length > 5) %>% | |||
#' desctable(tests = list(.auto = tests_auto, Species = ~chisq.test)) | |||
desctable <- function(data, stats, tests, labels) | |||
{ | |||
desctable <- function(data, stats, tests, labels) { | |||
UseMethod("desctable", data) | |||
} | |||
#' @rdname desctable | |||
#' @export | |||
desctable.default <- function(data, stats = stats_auto, tests, labels = NULL) | |||
{ | |||
# Build the complete table | |||
desctable.default <- function(data, stats = stats_auto, tests, labels = NULL) { | |||
# Assemble the Variables and the statTable in a single desctable object | |||
list(Variables = varColumn(data, labels), | |||
stats = statTable(data, stats)) %>% | |||
`class<-`("desctable") | |||
stats = statTable(data, stats)) %>% | |||
set_desctable_class() | |||
} | |||
#' @rdname desctable | |||
#' @export | |||
desctable.grouped_df <- function(data, stats = stats_auto, tests = tests_auto, labels = NULL) | |||
{ | |||
desctable.grouped_df <- function(data, stats = stats_auto, tests = tests_auto, labels = NULL) { | |||
# Get groups then ungroup dataframe | |||
grps <- data %>% dplyr::groups() | |||
grps <- dplyr::groups(data) | |||
data <- dplyr::ungroup(data) | |||
# Build the complete table recursively, assign "desctable" class | |||
# Assemble the Variables (excluding the grouping ones) and the subTables recursively in a single desctable object | |||
c(Variables = list(varColumn(data[!names(data) %in% (grps %>% lapply(as.character) %>% unlist())], labels)), | |||
subTable(data, stats, tests, grps)) %>% | |||
`class<-`("desctable") | |||
set_desctable_class() | |||
} | |||
@@ -191,8 +203,7 @@ desctable.grouped_df <- function(data, stats = stats_auto, tests = tests_auto, l | |||
#' @param grp Grouping factor | |||
#' @param df Dataframe containing the grouping factor | |||
#' @return A character vector with the names for the subtables | |||
subNames <- function(grp, df) | |||
{ | |||
subNames <- function(grp, df) { | |||
paste0(as.character(grp), | |||
": ", | |||
eval(grp, df) %>% factor() %>% levels(), | |||
@@ -208,38 +219,35 @@ subNames <- function(grp, df) | |||
#' @param tests Test function or list of functions | |||
#' @param grp Grouping factor | |||
#' @return A numeric vector of pvalues | |||
testColumn <- function(df, tests, grp) | |||
{ | |||
testColumn <- function(df, tests, grp) { | |||
group <- eval(grp, df) | |||
df <- df %>% | |||
dplyr::select(-!!(grp)) | |||
df <- df[!names(df) %in% as.character(grp)] | |||
if (is.function(tests)) | |||
{ | |||
ftests <- df %>% | |||
lapply(tests, group %>% factor()) | |||
# If tests is a function, apply it to the data and the grouping factor to produce a list of tests | |||
# If there is an .auto element in the list of tests, apply the function as previously to select the relevant test | |||
# If there is a .default element, use it as tests | |||
# Else fall back on kruskal.test | |||
if (is.function(tests)) { | |||
ftests <- lapply(df, tests, factor(group)) | |||
tests <- ftests | |||
} else if (!is.null(tests$.auto)) | |||
{ | |||
ftests <- df %>% | |||
lapply(tests$.auto, group %>% factor) | |||
} else if (!is.null(tests$.default)) | |||
{ | |||
ftests <- df %>% | |||
lapply(function(x){tests$.default}) | |||
} else | |||
{ | |||
ftests <- df %>% | |||
lapply(function(x){stats::kruskal.test}) | |||
} | |||
} else if (!is.null(tests$.auto)) ftests <- lapply(df, tests$.auto, factor(group)) | |||
else if (!is.null(tests$.default)) ftests <- lapply(df, function(x){tests$.default}) | |||
else ftests <- lapply(df, function(x){stats::kruskal.test}) | |||
names(tests) %>% setdiff(".auto") %>% intersect(names(df)) -> forced_tests | |||
# Select the forced (named) tests | |||
tests %>% | |||
names() %>% | |||
setdiff(".auto") %>% | |||
intersect(names(df)) -> forced_tests | |||
# Assemble the complete list of tests to compute | |||
ftests[names(ftests) %in% forced_tests][forced_tests] <- tests[forced_tests] | |||
# Compute the tests (made safe with testify) on the variable, using the grouping variable | |||
df %>% | |||
purrr::map2(ftests, testify, group) %>% | |||
dplyr::bind_rows() | |||
Reduce(f = rbind) | |||
} | |||
@@ -250,32 +258,26 @@ testColumn <- function(df, tests, grp) | |||
#' @param tests Tests list/function to use | |||
#' @param grps List of symbols for grouping factors | |||
#' @return A nested list of statTables and testColumns | |||
subTable <- function(df, stats, tests, grps) | |||
{ | |||
# Final group, make tests | |||
if (length(grps) == 1) | |||
{ | |||
group <- eval(grps[[1]], df) %>% factor() | |||
subTable <- function(df, stats, tests, grps) { | |||
# Final group, compute tests | |||
if (length(grps) == 1) { | |||
group <- factor(eval(grps[[1]], df)) | |||
# Create the subtable stats | |||
df %>% | |||
dplyr::select(-!!(grps[[1]])) %>% | |||
df[!names(df) %in% as.character(grps[[1]])] %>% | |||
by(group, statTable, stats) %>% | |||
# Name the subtables with info about group and group size | |||
stats::setNames(subNames(grps[[1]], df)) -> stats | |||
# Create the subtable tests | |||
testColumn(df, tests, grps[[1]]) -> pvalues | |||
pvalues <- testColumn(df, tests, grps[[1]]) | |||
c(stats, tests = list(pvalues)) | |||
} | |||
else | |||
{ | |||
} else { | |||
group <- eval(grps[[1]], df) | |||
# Go through the next grouping levels and build the subtables | |||
df %>% | |||
dplyr::select(-!!(grps[[1]])) %>% | |||
df[!names(df) %in% as.character(grps[[1]])] %>% | |||
by(group, subTable, stats, tests, grps[-1]) %>% | |||
# Name the subtables with info about group and group size | |||
stats::setNames(subNames(grps[[1]], df)) | |||
@@ -2,15 +2,13 @@ | |||
#' | |||
#' Return a compatible vector of length nlevels(x) + 1 | |||
#' to print the percentages of each level of a factor | |||
#' | |||
#' @param x A factor | |||
#' @export | |||
#' @return A nlevels(x) + 1 length vector of percentages | |||
percent <- function(x) | |||
{ | |||
if (x %>% is.factor()) | |||
c(NA, summary(x, maxsum = Inf) / length(x)) * 100 | |||
else | |||
NA | |||
percent <- function(x) { | |||
if (is.factor(x)) c(NA, summary(x, maxsum = Inf) / length(x)) * 100 | |||
else NA | |||
} | |||
@@ -20,8 +18,7 @@ percent <- function(x) | |||
#' @param x A vector | |||
#' @return The IQR | |||
#' @export | |||
IQR <- function(x) | |||
{ | |||
IQR <- function(x) { | |||
base::diff(stats::quantile(x, c(0.25, 0.75), na.rm = T)) | |||
} | |||
@@ -34,15 +31,10 @@ IQR <- function(x) | |||
#' @param x A numerical vector | |||
#' @export | |||
#' @return A boolean | |||
is.normal <- function(x) | |||
{ | |||
if (! x %>% is.numeric()) | |||
F | |||
else if (length(x %>% stats::na.omit()) >= 30) | |||
tryCatch(stats::shapiro.test(x)$p.value > .1, | |||
error = function(e) F) | |||
else | |||
F | |||
is.normal <- function(x) { | |||
if (!is.numeric(x)) F | |||
else if (length(stats::na.omit(x)) >= 30) tryCatch(stats::shapiro.test(x)$p.value > .1, error = function(e) F) | |||
else F | |||
} | |||
@@ -191,15 +183,15 @@ is.normal <- function(x) | |||
#' ### | |||
#' } | |||
#' @export | |||
fisher.test <- function(x, y, workspace, hybrid, control, or, alternative, conf.int, conf.level, simulate.p.value, B) | |||
{ | |||
fisher.test <- function(x, y, workspace, hybrid, control, or, alternative, conf.int, conf.level, simulate.p.value, B) { | |||
UseMethod("fisher.test") | |||
} | |||
#' @rdname fisher.test | |||
fisher.test.default <- function(x, ...) stats::fisher.test(x, ...) | |||
fisher.test.default <- function(x, ...) { | |||
stats::fisher.test(x, ...) | |||
} | |||
#' @rdname fisher.test | |||
fisher.test.formula <- function(x, | |||
@@ -212,19 +204,18 @@ fisher.test.formula <- function(x, | |||
conf.int = T, | |||
conf.level = .95, | |||
simulate.p.value = F, | |||
B = 2000) | |||
{ | |||
B = 2000) { | |||
stats::fisher.test(x = eval(x[[2]], envir = parent.frame()), | |||
y = eval(x[[3]], envir = parent.frame()), | |||
workspace = workspace, | |||
hybrid = hybrid, | |||
control = control, | |||
or = or, | |||
alternative = alternative, | |||
conf.int = conf.int, | |||
conf.level = conf.level, | |||
simulate.p.value = simulate.p.value, | |||
B = B) | |||
y = eval(x[[3]], envir = parent.frame()), | |||
workspace = workspace, | |||
hybrid = hybrid, | |||
control = control, | |||
or = or, | |||
alternative = alternative, | |||
conf.int = conf.int, | |||
conf.level = conf.level, | |||
simulate.p.value = simulate.p.value, | |||
B = B) | |||
} | |||
@@ -352,8 +343,7 @@ fisher.test.formula <- function(x, | |||
#' ### | |||
#' } | |||
#' @export | |||
chisq.test <- function(x, y, correct, p, rescale.p, simulate.p.value, B) | |||
{ | |||
chisq.test <- function(x, y, correct, p, rescale.p, simulate.p.value, B) { | |||
UseMethod("chisq.test") | |||
} | |||
@@ -369,15 +359,14 @@ chisq.test.formula <- function(x, | |||
p = rep(1/length(x), length(x)), | |||
rescale.p = F, | |||
simulate.p.value = F, | |||
B = 2000) | |||
{ | |||
B = 2000) { | |||
stats::chisq.test(x = eval(x[[2]], envir = parent.frame()), | |||
y = eval(x[[3]], envir = parent.frame()), | |||
correct = correct, | |||
p = p, | |||
rescale.p = rescale.p, | |||
simulate.p.value = simulate.p.value, | |||
B = B) | |||
y = eval(x[[3]], envir = parent.frame()), | |||
correct = correct, | |||
p = p, | |||
rescale.p = rescale.p, | |||
simulate.p.value = simulate.p.value, | |||
B = B) | |||
} | |||
@@ -386,8 +375,7 @@ chisq.test.formula <- function(x, | |||
#' @param formula An anova formula (\code{variable ~ grouping variable}) | |||
#' @seealso \code{\link{oneway.test}} | |||
#' @export | |||
ANOVA <- function(formula) | |||
{ | |||
ANOVA <- function(formula) { | |||
stats::oneway.test(formula, var.equal = T) | |||
} | |||
@@ -396,7 +384,6 @@ ANOVA <- function(formula) | |||
#' | |||
#' An empty test | |||
#' @param formula A formula | |||
no.test <- function(formula) | |||
{ | |||
no.test <- function(formula) { | |||
data.frame(p.value = NA) | |||
} |
@@ -4,9 +4,8 @@ | |||
#' @param ... Additional print parameters | |||
#' @return A flat dataframe | |||
#' @export | |||
print.desctable <- function(x, ...) | |||
{ | |||
print(x %>% as.data.frame()) | |||
print.desctable <- function(x, ...) { | |||
print(as.data.frame(x)) | |||
} | |||
@@ -16,13 +15,15 @@ print.desctable <- function(x, ...) | |||
#' @param ... Additional as.data.frame parameters | |||
#' @return A flat dataframe | |||
#' @export | |||
as.data.frame.desctable <- function(x, ...) | |||
{ | |||
as.data.frame.desctable <- function(x, ...) { | |||
# Discard "markdown" formatting of variable names | |||
x$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*", "\\1", x$Variables$Variables) | |||
x$Variables$Variables <- gsub("\\*(.*?)\\*", "\\1", x$Variables$Variables) | |||
header <- x %>% header("dataframe") | |||
# Create a dataframe header | |||
header <- header(x, "dataframe") | |||
# Make a standard dataframe | |||
x %>% | |||
flatten_desctable() %>% | |||
data.frame(check.names = F, ...) %>% | |||
@@ -47,15 +48,16 @@ pander.desctable <- function(x = NULL, | |||
keep.line.breaks = T, | |||
split.tables = Inf, | |||
emphasize.rownames = F, | |||
...) | |||
{ | |||
if (is.null(digits)) | |||
digits <- pander::panderOptions("digits") | |||
...) { | |||
if (is.null(digits)) digits <- pander::panderOptions("digits") | |||
# Discard "markdown" and insert 4 NbSp before factor levels | |||
x$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", " \\2", x$Variables$Variables) | |||
header <- x %>% header("pander") | |||
# Create a pander header | |||
header <- header(x, "pander") | |||
# Make a dataframe and push it to pandoc | |||
x %>% | |||
flatten_desctable %>% | |||
data.frame(check.names = F, stringsAsFactors = F) %>% | |||
@@ -107,8 +109,7 @@ pander.desctable <- function(x = NULL, | |||
#' ### | |||
#' @inheritParams DT::datatable | |||
#' @export | |||
datatable <- function(data, ...) | |||
{ | |||
datatable <- function(data, ...) { | |||
UseMethod("datatable", data) | |||
} | |||
@@ -130,8 +131,7 @@ datatable.default <- function(data, | |||
autoHideNavigation = getOption("DT.autoHideNavigation", NULL), | |||
selection = c("multiple", "single", "none"), | |||
extensions = list(), | |||
plugins = NULL, ...) | |||
{ | |||
plugins = NULL, ...) { | |||
DT::datatable(data, options = options, class = class, callback = callback, caption = caption, filter = filter, escape = escape, style = style, width = width, height = height, elementId = elementId, fillContainer = fillContainer, autoHideNavigation = autoHideNavigation, selection = selection, extensions = extensions, plugins = plugins, ...) | |||
} | |||
@@ -162,19 +162,26 @@ datatable.desctable <- function(data, | |||
extensions = c("FixedHeader", "FixedColumns", "Buttons"), | |||
plugins = NULL, | |||
rownames = F, | |||
digits = 2, ...) | |||
{ | |||
digits = 2, ...) { | |||
# Discard "markdown" and insert 4 NbSp before factor levels | |||
data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", " \\2", data$Variables$Variables) | |||
data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*", "<b>\\1</b>", data$Variables$Variables) | |||
header <- data %>% header("datatable") | |||
# Create a datatable header | |||
header <- header(data, "datatable") | |||
data %>% | |||
flatten_desctable() -> flat | |||
# Flatten desctable | |||
flat <- flatten_desctable(data) | |||
# Replace NAs and apply digits arg | |||
if (!is.null(digits)) | |||
flat <- flat %>% lapply(prettyNum, digits = digits) %>% lapply(gsub, pattern = "^NA$", replacement = "") | |||
{ | |||
flat %>% | |||
lapply(prettyNum, digits = digits) %>% | |||
lapply(gsub, pattern = "^NA$", replacement = "") -> flat | |||
} | |||
# Make a dataframe and push it to datatable, with its custom header | |||
flat %>% | |||
data.frame(check.names = F, stringsAsFactors = F) %>% | |||
DT::datatable(container = header, | |||
@@ -13,61 +13,51 @@ | |||
#' @param x A vector | |||
#' @export | |||
#' @return The results for the function applied on the vector, compatible with the format of the result table | |||
statify <- function(x, f) | |||
{ | |||
statify <- function(x, f) { | |||
UseMethod("statify", f) | |||
} | |||
#' @rdname statify | |||
#' @export | |||
statify.default <- function(x, f) | |||
{ | |||
x <- x %>% stats::na.omit() | |||
statify.default <- function(x, f) { | |||
# Discard NA values | |||
x <- stats::na.omit(x) | |||
# Try f(x), silent warnings and fail with NA | |||
res <- tryCatch(x %>% f, | |||
warning = function(e) suppressWarnings(x %>% f), | |||
res <- tryCatch(f(x), | |||
warning = function(e) suppressWarnings(f(x)), | |||
error = function(e) NA) | |||
# If x is a factor and f(x) behaves as expected (nlevel + total value), return f(x), or apply f(x) on each level, or fail with n+1 NA | |||
# If it is a numeric, return f(x) if it behaves as expected (ONE value), or fail with NA | |||
if (x %>% is.factor) | |||
{ | |||
if (length(res) == nlevels(x) + 1) | |||
res | |||
else if (length(res) == 1) | |||
c(res, lapply(levels(x), function(lvl) | |||
{ | |||
if (is.factor(x)) { | |||
if (length(res) == nlevels(x) + 1) res | |||
else if (length(res) == 1) { | |||
c(res, lapply(levels(x), function(lvl) { | |||
tryCatch(f(x[x == lvl]), | |||
warning = function(e) suppressWarnings(f(x[x == lvl])), | |||
error = function(e) NA) | |||
}) %>% unlist) | |||
else | |||
rep(NA, nlevels(x) + 1) | |||
} else | |||
{ | |||
if (length(res) == 1) | |||
if (res %>% is.numeric | res %>% is.na) | |||
res | |||
else | |||
res %>% as.character | |||
else | |||
NA | |||
} | |||
else rep(NA, nlevels(x) + 1) | |||
# If it is a numeric, return f(x) if it behaves as expected (ONE value), or fail with NA | |||
} else { | |||
if (length(res) == 1) { | |||
if (is.numeric(res) | is.na(res)) res | |||
else as.character(res) | |||
} | |||
else NA | |||
} | |||
} | |||
#' @rdname statify | |||
#' @export | |||
statify.formula <- function(x, f) | |||
{ | |||
statify.formula <- function(x, f) { | |||
# if expression quoted with ~, evaluate the expression | |||
if (length(f) == 2) | |||
eval(f[[2]]) | |||
if (length(f) == 2) eval(f[[2]]) | |||
# else parse the formula (cond ~ T | F) | |||
else | |||
statify.default(x, parse_formula(x, f)) | |||
else statify.default(x, parse_formula(x, f)) | |||
} | |||
@@ -88,8 +78,7 @@ statify.formula <- function(x, f) | |||
#' @param data The dataframe to apply the statistic to | |||
#' @return A list of statistics to use, potentially assessed from the dataframe | |||
#' @export | |||
stats_default <- function(data) | |||
{ | |||
stats_default <- function(data) { | |||
list("N" = length, | |||
"%" = percent, | |||
"Mean" = is.normal ~ mean, | |||
@@ -101,8 +90,7 @@ stats_default <- function(data) | |||
#' @rdname stats_default | |||
#' @export | |||
stats_normal <- function(data) | |||
{ | |||
stats_normal <- function(data) { | |||
list("N" = length, | |||
"%" = percent, | |||
"Mean" = mean, | |||
@@ -112,8 +100,7 @@ stats_normal <- function(data) | |||
#' @rdname stats_default | |||
#' @export | |||
stats_nonnormal <- function(data) | |||
{ | |||
stats_nonnormal <- function(data) { | |||
list("N" = length, | |||
"%" = percent, | |||
"Median" = stats::median, | |||
@@ -123,47 +110,39 @@ stats_nonnormal <- function(data) | |||
#' @rdname stats_default | |||
#' @export | |||
stats_auto <- function(data) | |||
{ | |||
stats_auto <- function(data) { | |||
data %>% | |||
Filter(f = is.numeric) %>% | |||
lapply(is.normal) %>% | |||
unlist() -> shapiro | |||
if (length(shapiro) == 0) | |||
{ | |||
if (length(shapiro) == 0) { | |||
normal <- F | |||
nonnormal <- F | |||
} | |||
else | |||
{ | |||
any(shapiro) -> normal | |||
any(!shapiro) -> nonnormal | |||
} else { | |||
normal <- any(shapiro) | |||
nonnormal <- any(!shapiro) | |||
} | |||
any(data %>% lapply(is.factor) %>% unlist()) -> fact | |||
if (fact & normal & !nonnormal) | |||
stats_normal(data) | |||
else if (fact & !normal & nonnormal) | |||
stats_nonnormal(data) | |||
else if (fact & !normal & !nonnormal) | |||
list("N" = length, | |||
"%" = percent) | |||
else if (!fact & normal & nonnormal) | |||
list("N" = length, | |||
"Mean" = is.normal ~ mean, | |||
"sd" = is.normal ~ sd, | |||
"Med" = stats::median, | |||
"IQR" = is.factor ~ NA | IQR) | |||
else if (!fact & normal & !nonnormal) | |||
list("N" = length, | |||
"Mean" = mean, | |||
"sd" = stats::sd) | |||
else if (!fact & !normal & nonnormal) | |||
list("N" = length, | |||
"Med" = stats::median, | |||
"IQR" = IQR) | |||
else | |||
stats_default(data) | |||
data %>% | |||
lapply(is.factor) %>% | |||
unlist() %>% | |||
any() -> fact | |||
if (fact & normal & !nonnormal) stats_normal(data) | |||
else if (fact & !normal & nonnormal) stats_nonnormal(data) | |||
else if (fact & !normal & !nonnormal) list("N" = length, | |||
"%" = percent) | |||
else if (!fact & normal & nonnormal) list("N" = length, | |||
"Mean" = is.normal ~ mean, | |||
"sd" = is.normal ~ sd, | |||
"Med" = stats::median, | |||
"IQR" = is.factor ~ NA | IQR) | |||
else if (!fact & normal & !nonnormal) list("N" = length, | |||
"Mean" = mean, | |||
"sd" = stats::sd) | |||
else if (!fact & !normal & nonnormal) list("N" = length, | |||
"Med" = stats::median, | |||
"IQR" = IQR) | |||
else stats_default(data) | |||
} |
@@ -7,20 +7,25 @@ | |||
#' @param f The function to try to apply, or a formula combining two functions | |||
#' @param group Grouping factor | |||
#' @return The results for the function applied on the vector, compatible with the format of the result table | |||
testify <- function(x, f, group) | |||
{ | |||
fun <- f %>% deparse() %>% Reduce(f = paste0) %>% substring(2) | |||
testify <- function(x, f, group) { | |||
# Extract the name of the function | |||
f %>% | |||
deparse() %>% | |||
Reduce(f = paste0) %>% | |||
substring(2) -> fun | |||
# Try the function | |||
f <- eval(f[[2]]) | |||
p <- tryCatch(f(x ~ group)$p.value[1], | |||
error = function(e) {message(e);NaN}) | |||
if (is.factor(x)) | |||
data.frame(p = c(p, NA %>% rep(nlevels(x))), | |||
test = c(fun, NA %>% rep(nlevels(x))), | |||
row.names = NULL, check.names = F, stringsAsFactors = F) | |||
else | |||
data.frame(p = p, | |||
test = fun, | |||
row.names = NULL, check.names = F, stringsAsFactors = F) | |||
# Return the correct number of rows depending on the variable type | |||
if (is.factor(x)) data.frame(p = c(p, rep(NA, nlevels(x))), | |||
test = c(fun, rep(NA, nlevels(x))), | |||
row.names = NULL, check.names = F, stringsAsFactors = F) | |||
else data.frame(p = p, | |||
test = fun, | |||
row.names = NULL, check.names = F, stringsAsFactors = F) | |||
} | |||
@@ -34,34 +39,28 @@ testify <- function(x, f, group) | |||
#' @param grp The variable for the groups | |||
#' @return A statistical test function | |||
#' @export | |||
tests_auto <- function(var, grp) | |||
{ | |||
grp <- grp %>% factor() | |||
if (nlevels(grp) < 2) | |||
~no.test | |||
else if (var %>% is.factor()) | |||
if (tryCatch(fisher.test(var ~ grp)$p.value %>% is.numeric(), error = function(e) F)) | |||
~fisher.test | |||
else | |||
~chisq.test | |||
else | |||
{ | |||
all_normal <- all(var %>% tapply(grp, is.normal)) | |||
if (nlevels(grp) == 2) | |||
if (all_normal) | |||
if (tryCatch(stats::var.test(var ~ grp)$p.value > .1, warning = function(e) F, error = function(e) F)) | |||
~. %>% t.test(var.equal = T) | |||
else | |||
~. %>% t.test(var.equal = F) | |||
else | |||
~wilcox.test | |||
else | |||
if (all_normal) | |||
if (tryCatch(stats::bartlett.test(var ~ grp)$p.value > .1, warning = function(e) F, error = function(e) F)) | |||
~. %>% oneway.test(var.equal = T) | |||
else | |||
~. %>% oneway.test(var.equal = F) | |||
else | |||
~kruskal.test | |||
tests_auto <- function(var, grp) { | |||
grp <- factor(grp) | |||
if (nlevels(grp) < 2) ~no.test | |||
else if (is.factor(var)) { | |||
if (tryCatch(is.numeric(fisher.test(var ~ grp)$p.value), error = function(e) F)) ~fisher.test | |||
else ~chisq.test | |||
} else { | |||
all_normal <- all(tapply(var, grp, is.normal)) | |||
if (nlevels(grp) == 2) { | |||
if (all_normal) { | |||
if (tryCatch(stats::var.test(var ~ grp)$p.value > .1, warning = function(e) F, error = function(e) F)) ~. %>% t.test(var.equal = T) | |||
else ~. %>% t.test(var.equal = F) | |||
} | |||
else ~wilcox.test | |||
} else { | |||
if (all_normal) { | |||
if (tryCatch(stats::bartlett.test(var ~ grp)$p.value > .1, warning = function(e) F, error = function(e) F)) ~. %>% oneway.test(var.equal = T) | |||
else ~. %>% oneway.test(var.equal = F) | |||
} | |||
else ~kruskal.test | |||
} | |||
} | |||
} |
@@ -1,25 +1,47 @@ | |||
#' Insert a vector y inside another vector x at position | |||
#' | |||
#' @param x A vector | |||
#' @param y A vector or list of vectors | |||
#' The vectors in the y list will be inserted | |||
#' at positions respectively *after* the x[position] element of x | |||
#' | |||
#' @param x A vector to be inserted into | |||
#' @param y A vector or list of vectors to insert into x | |||
#' @param position The position / vector of positions to insert vector(s) y in vector x | |||
#' @return The combined vector | |||
insert <- function(x, y, position) | |||
{ | |||
if (! y %>% is.list()) | |||
y <- list(y) | |||
insert <- function(x, y, position) { | |||
# y is supposed to be a list of vectors. If it is a single vector, make it a simple list containing that vector | |||
if (!is.list(y)) y <- list(y) | |||
# Stop if there is not as many positions as vectors to insert | |||
stopifnot(length(y) == length(position)) | |||
# Create an empty return vector that will contain the partition of x and the inserts | |||
result <- vector("list", 2 * length(position) + 1) | |||
# Split x in groups between the insert positions | |||
old <- split(x, cumsum(seq_along(x) %in% (position + 1))) | |||
# Insert the x splits at odd positions in result | |||
result[seq(from = 1, by = 2, length.out = length(old))] <- old | |||
# Insert the y inserts at even positions in results | |||
result[c(F, T)] <- y | |||
# Return a simple vector | |||
unlist(result) | |||
} | |||
#' Set the "desctable" class to the passed object | |||
#' | |||
#' @param x Object to set the "desctable" class to | |||
#' @return The object with the class "desctable" | |||
set_desctable_class <- function(x) { | |||
class(x) <- "desctable" | |||
x | |||
} | |||
#' Parse a formula | |||
#' | |||
#' Parse a formula defining the conditions to pick a stat/test | |||
@@ -35,33 +57,27 @@ insert <- function(x, y, position) | |||
#' @param x The variable to test it on | |||
#' @param f A formula to parse | |||
#' @return A function to use as a stat/test | |||
parse_formula <- function(x, f) | |||
{ | |||
parse_f <- function(x) | |||
{ | |||
if (length(x) == 1) | |||
x %>% as.character() | |||
else | |||
{ | |||
if (x[[1]] %>% as.character() == "~") | |||
{ | |||
paste0("if (", x[[2]] %>% parse_f(), "(x)) ", | |||
parse_formula <- function(x, f) { | |||
parse_f <- function(x) { | |||
if (length(x) == 1) as.character(x) | |||
else { | |||
if (as.character(x[[1]]) == "~") { | |||
paste0("if (", parse_f(x[[2]]), "(x)) ", | |||
"{", | |||
x[[3]] %>% parse_f(), | |||
parse_f(x[[3]]), | |||
"}") | |||
} else if (x[[1]] %>% as.character() == "|") | |||
{ | |||
paste0(x[[2]] %>% parse_f(), | |||
} else if (as.character(x[[1]]) == "|") { | |||
paste0(parse_f(x[[2]]), | |||
"} else ", | |||
"{", | |||
x[[3]] %>% parse_f()) | |||
} else if (x[[1]] %>% as.character() == "(") | |||
{ | |||
x[[2]] %>% parse_f() | |||
parse_f(x[[3]])) | |||
} else if (as.character(x[[1]]) == "(") { | |||
parse_f(x[[2]]) | |||
} | |||
} | |||
} | |||
parse(text = parse_f(f)) %>% eval() | |||
eval(parse(text = parse_f(f))) | |||
} | |||
@@ -69,15 +85,20 @@ parse_formula <- function(x, f) | |||
#' | |||
#' @param head A headerList object | |||
#' @return A names vector | |||
head_pander <- function(head) | |||
{ | |||
if (head[[1]] %>% is.integer()) | |||
{ | |||
head %>% names %>% lapply(function(x){c(x, rep("", head[[x]] - 1))}) %>% unlist | |||
} else | |||
{ | |||
paste(head %>% names() %>% lapply(function(x){c(x, rep("", attr(head[[x]], "colspan") - 1))}) %>% unlist(), | |||
head %>% lapply(head_pander) %>% unlist(), | |||
head_pander <- function(head) { | |||
if (is.integer(head[[1]])) { | |||
head %>% | |||
names %>% | |||
lapply(function(x){c(x, rep("", head[[x]] - 1))}) %>% | |||
unlist() | |||
} else { | |||
paste(head %>% | |||
names() %>% | |||
lapply(function(x){c(x, rep("", attr(head[[x]], "colspan") - 1))}) %>% | |||
unlist(), | |||
head %>% | |||
lapply(head_pander) %>% | |||
unlist(), | |||
sep = "<br/>") | |||
} | |||
} | |||
@@ -87,17 +108,17 @@ head_pander <- function(head) | |||
#' | |||
#' @param head A headerList object | |||
#' @return An htmltools$tags object containing the header | |||
head_datatable <- function(head) | |||
{ | |||
head_datatable <- function(head) { | |||
TRs <- list() | |||
while (head[[1]] %>% is.list()) | |||
{ | |||
TR <- purrr::map2(head %>% names(), head %>% lapply(attr, "colspan"), ~htmltools::tags$th(.x, colspan = .y)) | |||
while (is.list(head[[1]])) { | |||
TR <- purrr::map2(names(head), lapply(head, attr, "colspan"), ~htmltools::tags$th(.x, colspan = .y)) | |||
TRs <- c(TRs, list(TR)) | |||
head <- purrr::flatten(head) | |||
} | |||
c(TRs, list(purrr::map2(head %>% names, head, ~htmltools::tags$th(.x, colspan = .y)))) | |||
c(TRs, list(purrr::map2(names(head), head, ~htmltools::tags$th(.x, colspan = .y)))) | |||
} | |||
@@ -105,15 +126,20 @@ head_datatable <- function(head) | |||
#' | |||
#' @param head A headerList object | |||
#' @return A names vector | |||
head_dataframe <- function(head) | |||
{ | |||
if (head[[1]] %>% is.integer()) | |||
{ | |||
head %>% names() %>% lapply(function(x){rep(x, head[[x]])}) %>% unlist() | |||
} else | |||
{ | |||
paste(head %>% names() %>% lapply(function(x){rep(x, attr(head[[x]], "colspan"))}) %>% unlist(), | |||
head %>% lapply(head_pander) %>% unlist(), | |||
head_dataframe <- function(head) { | |||
if (is.integer(head[[1]])) { | |||
head %>% | |||
names() %>% | |||
lapply(function(x){rep(x, head[[x]])}) %>% | |||
unlist() | |||
} else { | |||
paste(head %>% | |||
names() %>% | |||
lapply(function(x){rep(x, attr(head[[x]], "colspan"))}) %>% | |||
unlist(), | |||
head %>% | |||
lapply(head_pander) %>% | |||
unlist(), | |||
sep = " / ") | |||
} | |||
} | |||
@@ -127,40 +153,37 @@ head_dataframe <- function(head) | |||
#' @param desctable A desctable object | |||
#' @param output An output format for the header | |||
#' @return A header object in the output format | |||
header <- function(desctable, output = c("pander", "datatable", "dataframe")) | |||
{ | |||
nm <- desctable %>% | |||
`[`(-1) %>% | |||
header <- function(desctable, output = c("pander", "datatable", "dataframe")) { | |||
desctable[-1] %>% | |||
flatten_desctable() %>% | |||
data.frame(check.names = F) %>% | |||
names | |||
names() -> nm | |||
desctable <- desctable[-1] | |||
if (length(desctable) == 1) | |||
{ | |||
if (output == "datatable") | |||
c("\u00A0", nm) %>% lapply(htmltools::tags$th) %>% htmltools::tags$tr() %>% htmltools::tags$thead() %>% htmltools::tags$table(class = "display") | |||
else | |||
c("\u00A0", nm) | |||
} | |||
else | |||
{ | |||
if (length(desctable) == 1) { | |||
if (output == "datatable") { | |||
c("\u00A0", nm) %>% | |||
lapply(htmltools::tags$th) %>% | |||
htmltools::tags$tr() %>% | |||
htmltools::tags$thead() %>% | |||
htmltools::tags$table(class = "display") | |||
} else c("\u00A0", nm) | |||
} else { | |||
head <- headerList(desctable) | |||
if (output == "pander") | |||
{ | |||
c("\u00A0", head_pander(head) %>% paste(nm, sep = "<br/>")) | |||
} else if (output == "datatable") | |||
{ | |||
c(head_datatable(head), list(nm %>% lapply(htmltools::tags$th))) -> head | |||
if (output == "pander") { | |||
c("\u00A0", head_pander(head) %>% | |||
paste(nm, sep = "<br/>")) | |||
} else if (output == "datatable") { | |||
head <- c(head_datatable(head), list(nm %>% lapply(htmltools::tags$th))) | |||
head[[1]] <- c(list(htmltools::tags$th(rowspan = length(head))), head[[1]]) | |||
head %>% | |||
lapply(htmltools::tags$tr) %>% | |||
htmltools::tags$thead() %>% | |||
htmltools::tags$table(class = "display") | |||
} else if (output == "dataframe") | |||
{ | |||
} else if (output == "dataframe") { | |||
c("\u00A0", head_dataframe(head) %>% paste(nm, sep = " / ")) | |||
} | |||
} | |||
@@ -171,19 +194,13 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) | |||
#' | |||
#' @param desctable A desctable | |||
#' @return A nested list of headers with colspans | |||
headerList <- function(desctable) | |||
{ | |||
if (desctable %>% is.data.frame()) | |||
{ | |||
length(desctable) | |||
} | |||
else | |||
{ | |||
lapply(desctable, headerList) -> rec | |||
if (is.integer(rec[[1]])) | |||
attr(rec, "colspan") <- rec %>% unlist() %>% sum() | |||
else | |||
attr(rec, "colspan") <- rec %>% lapply(attr, "colspan") %>% unlist %>% sum | |||
headerList <- function(desctable) { | |||
if (is.data.frame(desctable)) length(desctable) | |||
else { | |||
rec <- lapply(desctable, headerList) | |||
if (is.integer(rec[[1]])) attr(rec, "colspan") <- rec %>% unlist() %>% sum() | |||
else attr(rec, "colspan") <- rec %>% lapply(attr, "colspan") %>% unlist() %>% sum() | |||
rec | |||
} | |||
@@ -194,10 +211,11 @@ headerList <- function(desctable) | |||
#' | |||
#' @param desctable A desctable object | |||
#' @return A flat dataframe | |||
flatten_desctable <- function(desctable) | |||
{ | |||
if (desctable %>% is.data.frame()) | |||
desctable | |||
else | |||
desctable %>% lapply(flatten_desctable) %>% dplyr::bind_cols() | |||
flatten_desctable <- function(desctable) { | |||
if (is.data.frame(desctable)) desctable | |||
else { | |||
desctable %>% | |||
lapply(flatten_desctable) %>% | |||
Reduce(f = cbind) | |||
} | |||
} |