@@ -1,6 +1,6 @@ | |||||
Package: desctable | Package: desctable | ||||
Title: Produce Descriptive and Comparative Tables Easily | 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")), | 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"))) | person("Adrien", "Boukobza", email = "hadrien_b@hotmail.fr", role = c("aut"))) | ||||
Description: Easily create descriptive and comparative tables. | Description: Easily create descriptive and comparative tables. | ||||
@@ -16,13 +16,13 @@ URL: https://github.com/maximewack/desctable | |||||
BugReports: https://github.com/maximewack/desctable/issues | BugReports: https://github.com/maximewack/desctable/issues | ||||
Imports: | Imports: | ||||
dplyr, | dplyr, | ||||
purrr, | |||||
DT, | DT, | ||||
htmltools, | htmltools, | ||||
pander | pander | ||||
Suggests: | Suggests: | ||||
knitr, | knitr, | ||||
rmarkdown, | rmarkdown, | ||||
purrr, | |||||
survival | survival | ||||
RoxygenNote: 7.0.2 | RoxygenNote: 7.0.2 | ||||
VignetteBuilder: knitr | 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 | Version 0.1.7 | ||||
- Vignette and README with RStudio style guidelines | - Vignette and README with RStudio style guidelines | ||||
@@ -1,10 +1,18 @@ | |||||
#' Generate one statistic for all variables | #' 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 stat The statistic to use | ||||
#' @param data The dataframe to apply the statistic to | #' @param data The dataframe to apply the statistic to | ||||
#' @return A vector for one statistic column | #' @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 %>% | data %>% | ||||
lapply(statify, stat) %>% | lapply(statify, stat) %>% | ||||
unlist() | unlist() | ||||
@@ -13,18 +21,25 @@ statColumn <- function(stat, data) | |||||
#' Generate the table of all statistics for all variables | #' 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 data The dataframe to apply the statistic to | ||||
#' @param stats A list of named statistics to use | #' @param stats A list of named statistics to use | ||||
#' @return A dataframe of all statistics for all variables | #' @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 %>% | stats %>% | ||||
lapply(statColumn, data) %>% | 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 data The dataframe to get the names from | ||||
#' @param labels The optional named character vector containing the keypairs var = "Label" | #' @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 | #' @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)]] | 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 | # 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], "**") | 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 %>% | #' iris %>% | ||||
#' group_by(Petal.Length > 5) %>% | #' group_by(Petal.Length > 5) %>% | ||||
#' desctable(tests = list(.auto = tests_auto, Species = ~chisq.test)) | #' desctable(tests = list(.auto = tests_auto, Species = ~chisq.test)) | ||||
desctable <- function(data, stats, tests, labels) | |||||
{ | |||||
desctable <- function(data, stats, tests, labels) { | |||||
UseMethod("desctable", data) | UseMethod("desctable", data) | ||||
} | } | ||||
#' @rdname desctable | #' @rdname desctable | ||||
#' @export | #' @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), | list(Variables = varColumn(data, labels), | ||||
stats = statTable(data, stats)) %>% | |||||
`class<-`("desctable") | |||||
stats = statTable(data, stats)) %>% | |||||
set_desctable_class() | |||||
} | } | ||||
#' @rdname desctable | #' @rdname desctable | ||||
#' @export | #' @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 | # Get groups then ungroup dataframe | ||||
grps <- data %>% dplyr::groups() | |||||
grps <- dplyr::groups(data) | |||||
data <- dplyr::ungroup(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)), | c(Variables = list(varColumn(data[!names(data) %in% (grps %>% lapply(as.character) %>% unlist())], labels)), | ||||
subTable(data, stats, tests, grps)) %>% | 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 grp Grouping factor | ||||
#' @param df Dataframe containing the grouping factor | #' @param df Dataframe containing the grouping factor | ||||
#' @return A character vector with the names for the subtables | #' @return A character vector with the names for the subtables | ||||
subNames <- function(grp, df) | |||||
{ | |||||
subNames <- function(grp, df) { | |||||
paste0(as.character(grp), | paste0(as.character(grp), | ||||
": ", | ": ", | ||||
eval(grp, df) %>% factor() %>% levels(), | eval(grp, df) %>% factor() %>% levels(), | ||||
@@ -208,38 +219,35 @@ subNames <- function(grp, df) | |||||
#' @param tests Test function or list of functions | #' @param tests Test function or list of functions | ||||
#' @param grp Grouping factor | #' @param grp Grouping factor | ||||
#' @return A numeric vector of pvalues | #' @return A numeric vector of pvalues | ||||
testColumn <- function(df, tests, grp) | |||||
{ | |||||
testColumn <- function(df, tests, grp) { | |||||
group <- eval(grp, df) | 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 | 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] | 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 %>% | df %>% | ||||
purrr::map2(ftests, testify, group) %>% | 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 tests Tests list/function to use | ||||
#' @param grps List of symbols for grouping factors | #' @param grps List of symbols for grouping factors | ||||
#' @return A nested list of statTables and testColumns | #' @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 | # Create the subtable stats | ||||
df %>% | |||||
dplyr::select(-!!(grps[[1]])) %>% | |||||
df[!names(df) %in% as.character(grps[[1]])] %>% | |||||
by(group, statTable, stats) %>% | by(group, statTable, stats) %>% | ||||
# Name the subtables with info about group and group size | # Name the subtables with info about group and group size | ||||
stats::setNames(subNames(grps[[1]], df)) -> stats | stats::setNames(subNames(grps[[1]], df)) -> stats | ||||
# Create the subtable tests | # Create the subtable tests | ||||
testColumn(df, tests, grps[[1]]) -> pvalues | |||||
pvalues <- testColumn(df, tests, grps[[1]]) | |||||
c(stats, tests = list(pvalues)) | c(stats, tests = list(pvalues)) | ||||
} | |||||
else | |||||
{ | |||||
} else { | |||||
group <- eval(grps[[1]], df) | group <- eval(grps[[1]], df) | ||||
# Go through the next grouping levels and build the subtables | # 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]) %>% | by(group, subTable, stats, tests, grps[-1]) %>% | ||||
# Name the subtables with info about group and group size | # Name the subtables with info about group and group size | ||||
stats::setNames(subNames(grps[[1]], df)) | stats::setNames(subNames(grps[[1]], df)) | ||||
@@ -2,15 +2,13 @@ | |||||
#' | #' | ||||
#' Return a compatible vector of length nlevels(x) + 1 | #' Return a compatible vector of length nlevels(x) + 1 | ||||
#' to print the percentages of each level of a factor | #' to print the percentages of each level of a factor | ||||
#' | |||||
#' @param x A factor | #' @param x A factor | ||||
#' @export | #' @export | ||||
#' @return A nlevels(x) + 1 length vector of percentages | #' @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 | #' @param x A vector | ||||
#' @return The IQR | #' @return The IQR | ||||
#' @export | #' @export | ||||
IQR <- function(x) | |||||
{ | |||||
IQR <- function(x) { | |||||
base::diff(stats::quantile(x, c(0.25, 0.75), na.rm = T)) | 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 | #' @param x A numerical vector | ||||
#' @export | #' @export | ||||
#' @return A boolean | #' @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 | #' @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") | UseMethod("fisher.test") | ||||
} | } | ||||
#' @rdname 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 | #' @rdname fisher.test | ||||
fisher.test.formula <- function(x, | fisher.test.formula <- function(x, | ||||
@@ -212,19 +204,18 @@ fisher.test.formula <- function(x, | |||||
conf.int = T, | conf.int = T, | ||||
conf.level = .95, | conf.level = .95, | ||||
simulate.p.value = F, | simulate.p.value = F, | ||||
B = 2000) | |||||
{ | |||||
B = 2000) { | |||||
stats::fisher.test(x = eval(x[[2]], envir = parent.frame()), | 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 | #' @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") | UseMethod("chisq.test") | ||||
} | } | ||||
@@ -369,15 +359,14 @@ chisq.test.formula <- function(x, | |||||
p = rep(1/length(x), length(x)), | p = rep(1/length(x), length(x)), | ||||
rescale.p = F, | rescale.p = F, | ||||
simulate.p.value = F, | simulate.p.value = F, | ||||
B = 2000) | |||||
{ | |||||
B = 2000) { | |||||
stats::chisq.test(x = eval(x[[2]], envir = parent.frame()), | 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}) | #' @param formula An anova formula (\code{variable ~ grouping variable}) | ||||
#' @seealso \code{\link{oneway.test}} | #' @seealso \code{\link{oneway.test}} | ||||
#' @export | #' @export | ||||
ANOVA <- function(formula) | |||||
{ | |||||
ANOVA <- function(formula) { | |||||
stats::oneway.test(formula, var.equal = T) | stats::oneway.test(formula, var.equal = T) | ||||
} | } | ||||
@@ -396,7 +384,6 @@ ANOVA <- function(formula) | |||||
#' | #' | ||||
#' An empty test | #' An empty test | ||||
#' @param formula A formula | #' @param formula A formula | ||||
no.test <- function(formula) | |||||
{ | |||||
no.test <- function(formula) { | |||||
data.frame(p.value = NA) | data.frame(p.value = NA) | ||||
} | } |
@@ -4,9 +4,8 @@ | |||||
#' @param ... Additional print parameters | #' @param ... Additional print parameters | ||||
#' @return A flat dataframe | #' @return A flat dataframe | ||||
#' @export | #' @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 | #' @param ... Additional as.data.frame parameters | ||||
#' @return A flat dataframe | #' @return A flat dataframe | ||||
#' @export | #' @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) | ||||
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 %>% | x %>% | ||||
flatten_desctable() %>% | flatten_desctable() %>% | ||||
data.frame(check.names = F, ...) %>% | data.frame(check.names = F, ...) %>% | ||||
@@ -47,15 +48,16 @@ pander.desctable <- function(x = NULL, | |||||
keep.line.breaks = T, | keep.line.breaks = T, | ||||
split.tables = Inf, | split.tables = Inf, | ||||
emphasize.rownames = F, | 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) | 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 %>% | x %>% | ||||
flatten_desctable %>% | flatten_desctable %>% | ||||
data.frame(check.names = F, stringsAsFactors = F) %>% | data.frame(check.names = F, stringsAsFactors = F) %>% | ||||
@@ -107,8 +109,7 @@ pander.desctable <- function(x = NULL, | |||||
#' ### | #' ### | ||||
#' @inheritParams DT::datatable | #' @inheritParams DT::datatable | ||||
#' @export | #' @export | ||||
datatable <- function(data, ...) | |||||
{ | |||||
datatable <- function(data, ...) { | |||||
UseMethod("datatable", data) | UseMethod("datatable", data) | ||||
} | } | ||||
@@ -130,8 +131,7 @@ datatable.default <- function(data, | |||||
autoHideNavigation = getOption("DT.autoHideNavigation", NULL), | autoHideNavigation = getOption("DT.autoHideNavigation", NULL), | ||||
selection = c("multiple", "single", "none"), | selection = c("multiple", "single", "none"), | ||||
extensions = list(), | 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, ...) | 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"), | extensions = c("FixedHeader", "FixedColumns", "Buttons"), | ||||
plugins = NULL, | plugins = NULL, | ||||
rownames = F, | 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("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", " \\2", data$Variables$Variables) | ||||
data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*", "<b>\\1</b>", 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)) | 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 %>% | flat %>% | ||||
data.frame(check.names = F, stringsAsFactors = F) %>% | data.frame(check.names = F, stringsAsFactors = F) %>% | ||||
DT::datatable(container = header, | DT::datatable(container = header, | ||||
@@ -13,61 +13,51 @@ | |||||
#' @param x A vector | #' @param x A vector | ||||
#' @export | #' @export | ||||
#' @return The results for the function applied on the vector, compatible with the format of the result table | #' @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) | UseMethod("statify", f) | ||||
} | } | ||||
#' @rdname statify | #' @rdname statify | ||||
#' @export | #' @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 | # 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) | 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 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]), | tryCatch(f(x[x == lvl]), | ||||
warning = function(e) suppressWarnings(f(x[x == lvl])), | warning = function(e) suppressWarnings(f(x[x == lvl])), | ||||
error = function(e) NA) | error = function(e) NA) | ||||
}) %>% unlist) | }) %>% 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 | #' @rdname statify | ||||
#' @export | #' @export | ||||
statify.formula <- function(x, f) | |||||
{ | |||||
statify.formula <- function(x, f) { | |||||
# if expression quoted with ~, evaluate the expression | # 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 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 | #' @param data The dataframe to apply the statistic to | ||||
#' @return A list of statistics to use, potentially assessed from the dataframe | #' @return A list of statistics to use, potentially assessed from the dataframe | ||||
#' @export | #' @export | ||||
stats_default <- function(data) | |||||
{ | |||||
stats_default <- function(data) { | |||||
list("N" = length, | list("N" = length, | ||||
"%" = percent, | "%" = percent, | ||||
"Mean" = is.normal ~ mean, | "Mean" = is.normal ~ mean, | ||||
@@ -101,8 +90,7 @@ stats_default <- function(data) | |||||
#' @rdname stats_default | #' @rdname stats_default | ||||
#' @export | #' @export | ||||
stats_normal <- function(data) | |||||
{ | |||||
stats_normal <- function(data) { | |||||
list("N" = length, | list("N" = length, | ||||
"%" = percent, | "%" = percent, | ||||
"Mean" = mean, | "Mean" = mean, | ||||
@@ -112,8 +100,7 @@ stats_normal <- function(data) | |||||
#' @rdname stats_default | #' @rdname stats_default | ||||
#' @export | #' @export | ||||
stats_nonnormal <- function(data) | |||||
{ | |||||
stats_nonnormal <- function(data) { | |||||
list("N" = length, | list("N" = length, | ||||
"%" = percent, | "%" = percent, | ||||
"Median" = stats::median, | "Median" = stats::median, | ||||
@@ -123,47 +110,39 @@ stats_nonnormal <- function(data) | |||||
#' @rdname stats_default | #' @rdname stats_default | ||||
#' @export | #' @export | ||||
stats_auto <- function(data) | |||||
{ | |||||
stats_auto <- function(data) { | |||||
data %>% | data %>% | ||||
Filter(f = is.numeric) %>% | Filter(f = is.numeric) %>% | ||||
lapply(is.normal) %>% | lapply(is.normal) %>% | ||||
unlist() -> shapiro | unlist() -> shapiro | ||||
if (length(shapiro) == 0) | |||||
{ | |||||
if (length(shapiro) == 0) { | |||||
normal <- F | normal <- F | ||||
nonnormal <- 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 f The function to try to apply, or a formula combining two functions | ||||
#' @param group Grouping factor | #' @param group Grouping factor | ||||
#' @return The results for the function applied on the vector, compatible with the format of the result table | #' @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]]) | f <- eval(f[[2]]) | ||||
p <- tryCatch(f(x ~ group)$p.value[1], | p <- tryCatch(f(x ~ group)$p.value[1], | ||||
error = function(e) {message(e);NaN}) | 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 | #' @param grp The variable for the groups | ||||
#' @return A statistical test function | #' @return A statistical test function | ||||
#' @export | #' @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 | #' 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 | #' @param position The position / vector of positions to insert vector(s) y in vector x | ||||
#' @return The combined vector | #' @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)) | 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) | 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))) | 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 | 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 | result[c(F, T)] <- y | ||||
# Return a simple vector | |||||
unlist(result) | 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 | ||||
#' | #' | ||||
#' Parse a formula defining the conditions to pick a stat/test | #' 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 x The variable to test it on | ||||
#' @param f A formula to parse | #' @param f A formula to parse | ||||
#' @return A function to use as a stat/test | #' @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 ", | "} 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 | #' @param head A headerList object | ||||
#' @return A names vector | #' @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/>") | sep = "<br/>") | ||||
} | } | ||||
} | } | ||||
@@ -87,17 +108,17 @@ head_pander <- function(head) | |||||
#' | #' | ||||
#' @param head A headerList object | #' @param head A headerList object | ||||
#' @return An htmltools$tags object containing the header | #' @return An htmltools$tags object containing the header | ||||
head_datatable <- function(head) | |||||
{ | |||||
head_datatable <- function(head) { | |||||
TRs <- list() | 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)) | TRs <- c(TRs, list(TR)) | ||||
head <- purrr::flatten(head) | 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 | #' @param head A headerList object | ||||
#' @return A names vector | #' @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 = " / ") | sep = " / ") | ||||
} | } | ||||
} | } | ||||
@@ -127,40 +153,37 @@ head_dataframe <- function(head) | |||||
#' @param desctable A desctable object | #' @param desctable A desctable object | ||||
#' @param output An output format for the header | #' @param output An output format for the header | ||||
#' @return A header object in the output format | #' @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() %>% | flatten_desctable() %>% | ||||
data.frame(check.names = F) %>% | data.frame(check.names = F) %>% | ||||
names | |||||
names() -> nm | |||||
desctable <- desctable[-1] | 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) | 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[[1]] <- c(list(htmltools::tags$th(rowspan = length(head))), head[[1]]) | ||||
head %>% | head %>% | ||||
lapply(htmltools::tags$tr) %>% | lapply(htmltools::tags$tr) %>% | ||||
htmltools::tags$thead() %>% | htmltools::tags$thead() %>% | ||||
htmltools::tags$table(class = "display") | htmltools::tags$table(class = "display") | ||||
} else if (output == "dataframe") | |||||
{ | |||||
} else if (output == "dataframe") { | |||||
c("\u00A0", head_dataframe(head) %>% paste(nm, sep = " / ")) | c("\u00A0", head_dataframe(head) %>% paste(nm, sep = " / ")) | ||||
} | } | ||||
} | } | ||||
@@ -171,19 +194,13 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) | |||||
#' | #' | ||||
#' @param desctable A desctable | #' @param desctable A desctable | ||||
#' @return A nested list of headers with colspans | #' @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 | rec | ||||
} | } | ||||
@@ -194,10 +211,11 @@ headerList <- function(desctable) | |||||
#' | #' | ||||
#' @param desctable A desctable object | #' @param desctable A desctable object | ||||
#' @return A flat dataframe | #' @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) | |||||
} | |||||
} | } |