Browse Source

Merge branch 'dev'

tags/0.1.8
Maxime Wack 4 years ago
parent
commit
cd1af67483
8 changed files with 355 additions and 357 deletions
  1. +2
    -2
      DESCRIPTION
  2. +6
    -0
      NEWS
  3. +86
    -84
      R/build.R
  4. +34
    -47
      R/convenience_functions.R
  5. +28
    -21
      R/output.R
  6. +51
    -72
      R/stats.R
  7. +39
    -40
      R/tests.R
  8. +109
    -91
      R/utils.R

+ 2
- 2
DESCRIPTION View File

@@ -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

+ 6
- 0
NEWS View File

@@ -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


+ 86
- 84
R/build.R View File

@@ -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))


+ 34
- 47
R/convenience_functions.R View File

@@ -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)
}

+ 28
- 21
R/output.R View File

@@ -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("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "&nbsp;&nbsp;&nbsp;&nbsp;\\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("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "&nbsp;&nbsp;&nbsp;&nbsp;\\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,


+ 51
- 72
R/stats.R View File

@@ -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)
}

+ 39
- 40
R/tests.R View File

@@ -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
}
}
}

+ 109
- 91
R/utils.R View File

@@ -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)
}
}

Loading…
Cancel
Save