From 8d3e6682e55065f105d20c3762e9da0a85239a1d Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 22 Jul 2019 16:02:11 +0200 Subject: [PATCH 01/15] First version of export function to gt --- R/output.R | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/R/output.R b/R/output.R index 3ca86c9..0edfa99 100644 --- a/R/output.R +++ b/R/output.R @@ -195,3 +195,32 @@ datatable.desctable <- function(data, plugins = plugins, rownames = rownames, ...) } + +# TODO: recopier la doc de gt +gt <- function(data, ...) +{ + UseMethod("gt", data) +} + +#' @rdname gt +#' @export +gt.default <- gt::gt + +#' @rdname gt +#' @export +gt.desctable <- function(data, + rowname_col = "rowname", + groupname_col = "groupname", + rownames_to_stub = FALSE, + id = random_id(), + stub_group.sep = getOption("gt.stub_group.sep", " - ")) +{ + data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "    \\2", data$Variables$Variables) + + # header <- data %>% header("datatable") + + data %>% + flatten_desctable %>% + gt %>% + fmt_markdown("Variables") +} From af7f87fcc9339ef644bb0fa6e0ef683d3eeeb601 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 16:09:53 +0200 Subject: [PATCH 02/15] Use less dplyr verbs (select -> [], bind_cols -> Reduce(cbind)) --- R/build.R | 13 ++++++------- R/utils.R | 4 +++- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/R/build.R b/R/build.R index 24a0ddc..03ccccd 100644 --- a/R/build.R +++ b/R/build.R @@ -212,8 +212,7 @@ 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)) { @@ -239,7 +238,7 @@ testColumn <- function(df, tests, grp) df %>% purrr::map2(ftests, testify, group) %>% - dplyr::bind_rows() + Reduce(f = cbind) } @@ -258,8 +257,8 @@ subTable <- function(df, stats, tests, grps) group <- eval(grps[[1]], df) %>% factor() # Create the subtable stats - df %>% - dplyr::select(-!!(grps[[1]])) %>% + df_without_group <- df[!names(df) %in% as.character(grps[[1]])] + df_without_group %>% by(group, statTable, stats) %>% # Name the subtables with info about group and group size stats::setNames(subNames(grps[[1]], df)) -> stats @@ -274,8 +273,8 @@ subTable <- function(df, stats, tests, grps) group <- eval(grps[[1]], df) # Go through the next grouping levels and build the subtables - df %>% - dplyr::select(-!!(grps[[1]])) %>% + df_without_group <- df[!names(df) %in% as.character(grps[[1]])] + df_without_group %>% by(group, subTable, stats, tests, grps[-1]) %>% # Name the subtables with info about group and group size stats::setNames(subNames(grps[[1]], df)) diff --git a/R/utils.R b/R/utils.R index ac954c6..62d58cd 100644 --- a/R/utils.R +++ b/R/utils.R @@ -199,5 +199,7 @@ flatten_desctable <- function(desctable) if (desctable %>% is.data.frame()) desctable else - desctable %>% lapply(flatten_desctable) %>% dplyr::bind_cols() + desctable %>% + lapply(flatten_desctable) %>% + Reduce(f = cbind) } From 24d5821c33a05f09341a33909264b3c8495122c4 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 16:15:25 +0200 Subject: [PATCH 03/15] Revert "First version of export function to gt" This reverts commit 8d3e6682e55065f105d20c3762e9da0a85239a1d. --- R/output.R | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/R/output.R b/R/output.R index ce5b05c..00eddbd 100644 --- a/R/output.R +++ b/R/output.R @@ -195,32 +195,3 @@ datatable.desctable <- function(data, plugins = plugins, rownames = rownames, ...) } - -# TODO: recopier la doc de gt -gt <- function(data, ...) -{ - UseMethod("gt", data) -} - -#' @rdname gt -#' @export -gt.default <- gt::gt - -#' @rdname gt -#' @export -gt.desctable <- function(data, - rowname_col = "rowname", - groupname_col = "groupname", - rownames_to_stub = FALSE, - id = random_id(), - stub_group.sep = getOption("gt.stub_group.sep", " - ")) -{ - data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "    \\2", data$Variables$Variables) - - # header <- data %>% header("datatable") - - data %>% - flatten_desctable %>% - gt %>% - fmt_markdown("Variables") -} From 2439268c4a144715027a951a855cad949a05f565 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 17:32:41 +0200 Subject: [PATCH 04/15] Function to set desctable class --- R/build.R | 6 +++--- R/utils.R | 12 ++++++++++++ 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/R/build.R b/R/build.R index 03ccccd..5da87f3 100644 --- a/R/build.R +++ b/R/build.R @@ -163,8 +163,8 @@ desctable.default <- function(data, stats = stats_auto, tests, labels = NULL) { # Build the complete table list(Variables = varColumn(data, labels), - stats = statTable(data, stats)) %>% - `class<-`("desctable") + stats = statTable(data, stats)) %>% + set_desctable_class() } @@ -179,7 +179,7 @@ desctable.grouped_df <- function(data, stats = stats_auto, tests = tests_auto, l # Build the complete table recursively, assign "desctable" class c(Variables = list(varColumn(data[!names(data) %in% (grps %>% lapply(as.character) %>% unlist())], labels)), subTable(data, stats, tests, grps)) %>% - `class<-`("desctable") + set_desctable_class() } diff --git a/R/utils.R b/R/utils.R index 62d58cd..baa7427 100644 --- a/R/utils.R +++ b/R/utils.R @@ -20,6 +20,18 @@ insert <- function(x, y, position) } +#' 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 From 28d7546554bc90aa83a0585c3efecd115c3191f2 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 17:49:56 +0200 Subject: [PATCH 05/15] Simple assignments use <- --- R/build.R | 37 +++++++++++++++---------------------- R/output.R | 3 +-- R/stats.R | 4 ++-- R/tests.R | 3 ++- R/utils.R | 2 +- 5 files changed, 21 insertions(+), 28 deletions(-) diff --git a/R/build.R b/R/build.R index 5da87f3..895d28b 100644 --- a/R/build.R +++ b/R/build.R @@ -42,33 +42,26 @@ statTable <- function(data, stats) #' @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 + # Replace variable names by their labels, if they exist + base_names <- names(data) base_names[base_names %in% names(labels)] <- labels[base_names[base_names %in% names(labels)]] # Insert levels for factors after the variable name - if (any(data %>% lapply(is.factor) %>% unlist())) + data %>% + lapply(is.factor) %>% + unlist() -> factors + + if (any(factors)) { - data %>% - lapply(is.factor) %>% - unlist() %>% - which() -> factors_idx + factors_idx <- which(factors) 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 <- lapply(factors_idx, function(x) paste0(base_names[x], ": ", "*", levels(data[[x]]), "*")) + + 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) @@ -264,7 +257,7 @@ subTable <- function(df, stats, tests, grps) 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)) } diff --git a/R/output.R b/R/output.R index 00eddbd..4c42b61 100644 --- a/R/output.R +++ b/R/output.R @@ -169,8 +169,7 @@ datatable.desctable <- function(data, header <- data %>% header("datatable") - data %>% - flatten_desctable() -> flat + flat <- flatten_desctable(data) if (!is.null(digits)) flat <- flat %>% lapply(prettyNum, digits = digits) %>% lapply(gsub, pattern = "^NA$", replacement = "") diff --git a/R/stats.R b/R/stats.R index 9ec6383..68006d8 100644 --- a/R/stats.R +++ b/R/stats.R @@ -137,8 +137,8 @@ stats_auto <- function(data) } else { - any(shapiro) -> normal - any(!shapiro) -> nonnormal + normal <- any(shapiro) + nonnormal <- any(!shapiro) } any(data %>% lapply(is.factor) %>% unlist()) -> fact diff --git a/R/tests.R b/R/tests.R index dc3533a..03fcd92 100644 --- a/R/tests.R +++ b/R/tests.R @@ -36,7 +36,8 @@ testify <- function(x, f, group) #' @export tests_auto <- function(var, grp) { - grp <- grp %>% factor() + grp <- factor(grp) + if (nlevels(grp) < 2) ~no.test else if (var %>% is.factor()) diff --git a/R/utils.R b/R/utils.R index baa7427..4db7287 100644 --- a/R/utils.R +++ b/R/utils.R @@ -165,7 +165,7 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) c("\u00A0", head_pander(head) %>% paste(nm, sep = "
")) } else if (output == "datatable") { - c(head_datatable(head), list(nm %>% lapply(htmltools::tags$th))) -> head + 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) %>% From 04a2d56d09ef7d173499b2fd32bfb0d6644b2e60 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 17:51:04 +0200 Subject: [PATCH 06/15] Useless use of temp variable --- R/build.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/build.R b/R/build.R index 895d28b..d646dd2 100644 --- a/R/build.R +++ b/R/build.R @@ -250,8 +250,7 @@ subTable <- function(df, stats, tests, grps) group <- eval(grps[[1]], df) %>% factor() # Create the subtable stats - df_without_group <- df[!names(df) %in% as.character(grps[[1]])] - df_without_group %>% + 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 @@ -266,8 +265,7 @@ subTable <- function(df, stats, tests, grps) group <- eval(grps[[1]], df) # Go through the next grouping levels and build the subtables - df_without_group <- df[!names(df) %in% as.character(grps[[1]])] - df_without_group %>% + 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)) From c289fb5037903c35a310521434a61930e8e71b6c Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 17:56:17 +0200 Subject: [PATCH 07/15] Don't use trivial pipes --- R/build.R | 23 ++++++-------------- R/convenience_functions.R | 10 +++------ R/output.R | 8 +++---- R/stats.R | 19 ++++++++--------- R/tests.R | 40 +++++++++++++++++------------------ R/utils.R | 44 ++++++++++++++++++--------------------- 6 files changed, 62 insertions(+), 82 deletions(-) diff --git a/R/build.R b/R/build.R index d646dd2..c516cac 100644 --- a/R/build.R +++ b/R/build.R @@ -166,7 +166,7 @@ desctable.default <- function(data, stats = stats_auto, tests, 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 @@ -209,22 +209,11 @@ testColumn <- function(df, tests, grp) if (is.function(tests)) { - ftests <- df %>% - lapply(tests, group %>% factor()) + 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 ftests[names(ftests) %in% forced_tests][forced_tests] <- tests[forced_tests] @@ -247,7 +236,7 @@ subTable <- function(df, stats, tests, grps) # Final group, make tests if (length(grps) == 1) { - group <- eval(grps[[1]], df) %>% factor() + group <- factor(eval(grps[[1]], df)) # Create the subtable stats df[!names(df) %in% as.character(grps[[1]])] %>% diff --git a/R/convenience_functions.R b/R/convenience_functions.R index e11887c..bf1f728 100644 --- a/R/convenience_functions.R +++ b/R/convenience_functions.R @@ -36,13 +36,9 @@ IQR <- function(x) #' @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 + 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 } diff --git a/R/output.R b/R/output.R index 4c42b61..a2e10ce 100644 --- a/R/output.R +++ b/R/output.R @@ -6,7 +6,7 @@ #' @export print.desctable <- function(x, ...) { - print(x %>% as.data.frame()) + print(as.data.frame(x)) } @@ -21,7 +21,7 @@ as.data.frame.desctable <- function(x, ...) x$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*", "\\1", x$Variables$Variables) x$Variables$Variables <- gsub("\\*(.*?)\\*", "\\1", x$Variables$Variables) - header <- x %>% header("dataframe") + header <- header(x, "dataframe") x %>% flatten_desctable() %>% @@ -54,7 +54,7 @@ pander.desctable <- function(x = NULL, x$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "    \\2", x$Variables$Variables) - header <- x %>% header("pander") + header <- header(x, "pander") x %>% flatten_desctable %>% @@ -167,7 +167,7 @@ datatable.desctable <- function(data, data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "    \\2", data$Variables$Variables) data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*", "\\1", data$Variables$Variables) - header <- data %>% header("datatable") + header <- header(data, "datatable") flat <- flatten_desctable(data) diff --git a/R/stats.R b/R/stats.R index 68006d8..5ecd914 100644 --- a/R/stats.R +++ b/R/stats.R @@ -23,16 +23,16 @@ statify <- function(x, f) #' @export statify.default <- function(x, f) { - x <- x %>% stats::na.omit() + 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 (is.factor(x)) { if (length(res) == nlevels(x) + 1) res @@ -48,12 +48,11 @@ statify.default <- function(x, f) } else { if (length(res) == 1) - if (res %>% is.numeric | res %>% is.na) - res - else - res %>% as.character - else - NA + { + if (is.numeric(res) | is.na(res)) res + else as.character(res) + } + else NA } } diff --git a/R/tests.R b/R/tests.R index 03fcd92..a7890d1 100644 --- a/R/tests.R +++ b/R/tests.R @@ -38,31 +38,31 @@ tests_auto <- function(var, grp) { grp <- factor(grp) - 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 + if (nlevels(grp) < 2) ~no.test + else if (is.factor(var)) + { + 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)) + 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 + { + 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 + { + 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 + } } } diff --git a/R/utils.R b/R/utils.R index 4db7287..8b548d3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -6,8 +6,7 @@ #' @return The combined vector insert <- function(x, y, position) { - if (! y %>% is.list()) - y <- list(y) + if (!is.list(y)) y <- list(y) stopifnot(length(y) == length(position)) @@ -51,29 +50,28 @@ parse_formula <- function(x, f) { parse_f <- function(x) { - if (length(x) == 1) - x %>% as.character() + if (length(x) == 1) as.character(x) else { - if (x[[1]] %>% as.character() == "~") + if (as.character(x[[1]]) == "~") { - paste0("if (", x[[2]] %>% parse_f(), "(x)) ", + paste0("if (", parse_f(x[[2]]), "(x)) ", "{", - x[[3]] %>% parse_f(), + parse_f(x[[3]]), "}") - } else if (x[[1]] %>% as.character() == "|") + } else if (as.character(x[[1]]) == "|") { - paste0(x[[2]] %>% parse_f(), + paste0(parse_f(x[[2]]), "} else ", "{", - x[[3]] %>% parse_f()) - } else if (x[[1]] %>% as.character() == "(") + parse_f(x[[3]])) + } else if (as.character(x[[1]]) == "(") { - x[[2]] %>% parse_f() + parse_f(x[[2]]) } } } - parse(text = parse_f(f)) %>% eval() + eval(parse(text = parse_f(f))) } @@ -83,7 +81,7 @@ parse_formula <- function(x, f) #' @return A names vector head_pander <- function(head) { - if (head[[1]] %>% is.integer()) + if (is.integer(head[[1]])) { head %>% names %>% lapply(function(x){c(x, rep("", head[[x]] - 1))}) %>% unlist } else @@ -102,14 +100,16 @@ head_pander <- function(head) head_datatable <- function(head) { TRs <- list() - while (head[[1]] %>% is.list()) + + while (is.list(head[[1]])) { - TR <- purrr::map2(head %>% names(), head %>% lapply(attr, "colspan"), ~htmltools::tags$th(.x, colspan = .y)) + 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)))) } @@ -119,7 +119,7 @@ head_datatable <- function(head) #' @return A names vector head_dataframe <- function(head) { - if (head[[1]] %>% is.integer()) + if (is.integer(head[[1]])) { head %>% names() %>% lapply(function(x){rep(x, head[[x]])}) %>% unlist() } else @@ -185,10 +185,7 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) #' @return A nested list of headers with colspans headerList <- function(desctable) { - if (desctable %>% is.data.frame()) - { - length(desctable) - } + if (is.data.frame(desctable)) length(desctable) else { lapply(desctable, headerList) -> rec @@ -208,8 +205,7 @@ headerList <- function(desctable) #' @return A flat dataframe flatten_desctable <- function(desctable) { - if (desctable %>% is.data.frame()) - desctable + if (is.data.frame(desctable)) desctable else desctable %>% lapply(flatten_desctable) %>% From d53f7d0f86c58c1408f20c67206c8214e2c5fc2d Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 17:58:11 +0200 Subject: [PATCH 08/15] Multiline pipelines, with assignment using -> --- R/build.R | 6 +++++- R/output.R | 6 +++++- R/stats.R | 5 ++++- R/tests.R | 6 +++++- R/utils.R | 47 ++++++++++++++++++++++++++++++++++------------- 5 files changed, 53 insertions(+), 17 deletions(-) diff --git a/R/build.R b/R/build.R index c516cac..5f17c30 100644 --- a/R/build.R +++ b/R/build.R @@ -215,7 +215,11 @@ testColumn <- function(df, tests, grp) 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 + tests %>% + names() %>% + setdiff(".auto") %>% + intersect(names(df)) -> forced_tests + ftests[names(ftests) %in% forced_tests][forced_tests] <- tests[forced_tests] df %>% diff --git a/R/output.R b/R/output.R index a2e10ce..6a5f950 100644 --- a/R/output.R +++ b/R/output.R @@ -172,7 +172,11 @@ datatable.desctable <- function(data, flat <- flatten_desctable(data) 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 + } flat %>% data.frame(check.names = F, stringsAsFactors = F) %>% diff --git a/R/stats.R b/R/stats.R index 5ecd914..e78aff5 100644 --- a/R/stats.R +++ b/R/stats.R @@ -140,7 +140,10 @@ stats_auto <- function(data) nonnormal <- any(!shapiro) } - any(data %>% lapply(is.factor) %>% unlist()) -> fact + data %>% + lapply(is.factor) %>% + unlist() %>% + any() -> fact if (fact & normal & !nonnormal) stats_normal(data) diff --git a/R/tests.R b/R/tests.R index a7890d1..00ee178 100644 --- a/R/tests.R +++ b/R/tests.R @@ -9,7 +9,11 @@ #' @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) + f %>% + deparse() %>% + Reduce(f = paste0) %>% + substring(2) -> fun + f <- eval(f[[2]]) p <- tryCatch(f(x ~ group)$p.value[1], error = function(e) {message(e);NaN}) diff --git a/R/utils.R b/R/utils.R index 8b548d3..370d676 100644 --- a/R/utils.R +++ b/R/utils.R @@ -83,11 +83,19 @@ head_pander <- function(head) { if (is.integer(head[[1]])) { - head %>% names %>% lapply(function(x){c(x, rep("", head[[x]] - 1))}) %>% unlist + 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(), + paste(head %>% + names() %>% + lapply(function(x){c(x, rep("", attr(head[[x]], "colspan") - 1))}) %>% + unlist(), + head %>% + lapply(head_pander) %>% + unlist(), sep = "
") } } @@ -121,11 +129,19 @@ head_dataframe <- function(head) { if (is.integer(head[[1]])) { - head %>% names() %>% lapply(function(x){rep(x, head[[x]])}) %>% unlist() + 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(), + paste(head %>% + names() %>% + lapply(function(x){rep(x, attr(head[[x]], "colspan"))}) %>% + unlist(), + head %>% + lapply(head_pander) %>% + unlist(), sep = " / ") } } @@ -141,20 +157,24 @@ head_dataframe <- function(head) #' @return A header object in the output format header <- function(desctable, output = c("pander", "datatable", "dataframe")) { - nm <- desctable %>% - `[`(-1) %>% + 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) + { + c("\u00A0", nm) %>% + lapply(htmltools::tags$th) %>% + htmltools::tags$tr() %>% + htmltools::tags$thead() %>% + htmltools::tags$table(class = "display") + } + else c("\u00A0", nm) } else { @@ -162,7 +182,8 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) if (output == "pander") { - c("\u00A0", head_pander(head) %>% paste(nm, sep = "
")) + c("\u00A0", head_pander(head) %>% + paste(nm, sep = "
")) } else if (output == "datatable") { head <- c(head_datatable(head), list(nm %>% lapply(htmltools::tags$th))) From bfa62fe07718ffee3456ee4354924f11dfa60ac2 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 18:00:11 +0200 Subject: [PATCH 09/15] Styling (added empty lines, multi-line statements, simple ifs on a single line, complex ifs with {} --- R/build.R | 12 ++++++++---- R/convenience_functions.R | 12 ++++++------ R/output.R | 3 +-- R/stats.R | 31 +++++++++++++++++-------------- R/tests.R | 11 +++++++++-- R/utils.R | 12 +++++++----- 6 files changed, 48 insertions(+), 33 deletions(-) diff --git a/R/build.R b/R/build.R index 5f17c30..44a0923 100644 --- a/R/build.R +++ b/R/build.R @@ -19,12 +19,13 @@ statColumn <- function(stat, data) statTable <- function(data, stats) { # Call the stats arg_function passed, or use the provided list as-is - if (is.function(stats)) - stats = stats(data) + if (is.function(stats)) stats = stats(data) stats %>% lapply(statColumn, data) %>% - data.frame(check.names = F, row.names = NULL, stringsAsFactors = F) + data.frame(check.names = F, + row.names = NULL, + stringsAsFactors = F) } @@ -64,7 +65,10 @@ varColumn <- function(data, labels = NULL) 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) } diff --git a/R/convenience_functions.R b/R/convenience_functions.R index bf1f728..baabb91 100644 --- a/R/convenience_functions.R +++ b/R/convenience_functions.R @@ -7,10 +7,8 @@ #' @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 + if (is.factor(x)) c(NA, summary(x, maxsum = Inf) / length(x)) * 100 + else NA } @@ -194,8 +192,10 @@ fisher.test <- function(x, y, workspace, hybrid, control, or, alternative, conf. #' @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, diff --git a/R/output.R b/R/output.R index 6a5f950..a5f96dc 100644 --- a/R/output.R +++ b/R/output.R @@ -49,8 +49,7 @@ pander.desctable <- function(x = NULL, emphasize.rownames = F, ...) { - if (is.null(digits)) - digits <- pander::panderOptions("digits") + if (is.null(digits)) digits <- pander::panderOptions("digits") x$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "    \\2", x$Variables$Variables) diff --git a/R/stats.R b/R/stats.R index e78aff5..3b1ce25 100644 --- a/R/stats.R +++ b/R/stats.R @@ -34,17 +34,17 @@ statify.default <- function(x, f) # If it is a numeric, return f(x) if it behaves as expected (ONE value), or fail with NA if (is.factor(x)) { - if (length(res) == nlevels(x) + 1) - res + 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 rep(NA, nlevels(x) + 1) } else { if (length(res) == 1) @@ -62,11 +62,9 @@ statify.default <- 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)) } @@ -145,27 +143,32 @@ stats_auto <- function(data) unlist() %>% any() -> fact - if (fact & normal & !nonnormal) - stats_normal(data) - else if (fact & !normal & nonnormal) - stats_nonnormal(data) + 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) + } + else stats_default(data) } diff --git a/R/tests.R b/R/tests.R index 00ee178..0d9fac9 100644 --- a/R/tests.R +++ b/R/tests.R @@ -17,14 +17,19 @@ testify <- function(x, f, group) 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))), + { + 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) + } } @@ -53,6 +58,7 @@ tests_auto <- function(var, grp) 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) @@ -61,6 +67,7 @@ tests_auto <- function(var, grp) 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) diff --git a/R/utils.R b/R/utils.R index 370d676..71061a8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -188,6 +188,7 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) { 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() %>% @@ -209,11 +210,10 @@ headerList <- function(desctable) if (is.data.frame(desctable)) 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 + 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 } @@ -228,7 +228,9 @@ flatten_desctable <- function(desctable) { if (is.data.frame(desctable)) desctable else + { desctable %>% lapply(flatten_desctable) %>% Reduce(f = cbind) + } } From a1c3e35906997a1f59315621a48052034321b8ea Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 18:52:38 +0200 Subject: [PATCH 10/15] Add comments and doc --- R/build.R | 41 +++++++++++++++++++++++++++++----- R/convenience_functions.R | 1 + R/output.R | 11 +++++++++ R/stats.R | 47 +++++++++++++++------------------------ R/tests.R | 3 +++ R/utils.R | 17 ++++++++++++-- 6 files changed, 83 insertions(+), 37 deletions(-) diff --git a/R/build.R b/R/build.R index 44a0923..3b624c4 100644 --- a/R/build.R +++ b/R/build.R @@ -1,10 +1,19 @@ #' 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) { + # 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,14 +22,21 @@ 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 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, @@ -43,23 +59,29 @@ statTable <- function(data, stats) #' @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 + # 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)]] - # Insert levels for factors after the variable name + # Check if there are factors data %>% lapply(is.factor) %>% unlist() -> factors + # Insert levels for factors after the variable name if (any(factors)) { factors_idx <- which(factors) + # Factor names in **bold** base_names[factors_idx] <- paste0("**", base_names[factors_idx], "**") + # 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) @@ -158,7 +180,7 @@ desctable <- function(data, stats, tests, labels) #' @export desctable.default <- function(data, stats = stats_auto, tests, labels = NULL) { - # Build the complete table + # Assemble the Variables and the statTable in a single desctable object list(Variables = varColumn(data, labels), stats = statTable(data, stats)) %>% set_desctable_class() @@ -173,7 +195,7 @@ desctable.grouped_df <- function(data, stats = stats_auto, tests = tests_auto, l 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)) %>% set_desctable_class() @@ -211,6 +233,10 @@ testColumn <- function(df, tests, grp) df <- df[!names(df) %in% as.character(grp)] + # 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)) @@ -219,13 +245,16 @@ testColumn <- function(df, tests, grp) else if (!is.null(tests$.default)) ftests <- lapply(df, function(x){tests$.default}) else ftests <- lapply(df, function(x){stats::kruskal.test}) + # 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) %>% Reduce(f = cbind) @@ -241,7 +270,7 @@ testColumn <- function(df, tests, grp) #' @return A nested list of statTables and testColumns subTable <- function(df, stats, tests, grps) { - # Final group, make tests + # Final group, compute tests if (length(grps) == 1) { group <- factor(eval(grps[[1]], df)) diff --git a/R/convenience_functions.R b/R/convenience_functions.R index baabb91..79d85a0 100644 --- a/R/convenience_functions.R +++ b/R/convenience_functions.R @@ -2,6 +2,7 @@ #' #' 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 diff --git a/R/output.R b/R/output.R index a5f96dc..61e60a2 100644 --- a/R/output.R +++ b/R/output.R @@ -18,11 +18,14 @@ print.desctable <- function(x, ...) #' @export 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) + # Create a dataframe header header <- header(x, "dataframe") + # Make a standard dataframe x %>% flatten_desctable() %>% data.frame(check.names = F, ...) %>% @@ -51,10 +54,13 @@ pander.desctable <- function(x = NULL, { 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) + # 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) %>% @@ -163,13 +169,17 @@ datatable.desctable <- function(data, rownames = F, digits = 2, ...) { + # Discard "markdown" and insert 4 NbSp before factor levels data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "    \\2", data$Variables$Variables) data$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*", "\\1", data$Variables$Variables) + # Create a datatable header header <- header(data, "datatable") + # Flatten desctable flat <- flatten_desctable(data) + # Replace NAs and apply digits arg if (!is.null(digits)) { flat %>% @@ -177,6 +187,7 @@ datatable.desctable <- function(data, 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, diff --git a/R/stats.R b/R/stats.R index 3b1ce25..c0a5cc4 100644 --- a/R/stats.R +++ b/R/stats.R @@ -23,6 +23,7 @@ statify <- function(x, f) #' @export statify.default <- function(x, f) { + # Discard NA values x <- stats::na.omit(x) # Try f(x), silent warnings and fail with NA @@ -31,7 +32,6 @@ statify.default <- function(x, f) 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 (is.factor(x)) { if (length(res) == nlevels(x) + 1) res @@ -45,6 +45,7 @@ statify.default <- function(x, f) }) %>% unlist) } 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) @@ -143,32 +144,20 @@ stats_auto <- function(data) 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) + 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) } diff --git a/R/tests.R b/R/tests.R index 0d9fac9..e242da4 100644 --- a/R/tests.R +++ b/R/tests.R @@ -9,15 +9,18 @@ #' @return The results for the function applied on the vector, compatible with the format of the result table 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}) + # Return the correct number of rows depending on the variable type if (is.factor(x)) { data.frame(p = c(p, rep(NA, nlevels(x))), diff --git a/R/utils.R b/R/utils.R index 71061a8..a88949c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,20 +1,33 @@ #' 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) { + # 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) } From f5925a92fcb2446008ad1e4b707a30aef1af07e0 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 19:07:03 +0200 Subject: [PATCH 11/15] Conform to tidyverse style convention for opening { --- R/build.R | 44 +++++++------------- R/convenience_functions.R | 64 ++++++++++++---------------- R/output.R | 18 +++----- R/stats.R | 43 +++++++------------ R/tests.R | 60 ++++++++++---------------- R/utils.R | 88 +++++++++++++-------------------------- 6 files changed, 114 insertions(+), 203 deletions(-) diff --git a/R/build.R b/R/build.R index 3b624c4..65469d3 100644 --- a/R/build.R +++ b/R/build.R @@ -9,8 +9,7 @@ #' @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. @@ -29,8 +28,7 @@ statColumn <- function(stat, data) #' @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) -{ +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) @@ -57,8 +55,7 @@ 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) -{ +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 @@ -71,8 +68,7 @@ varColumn <- function(data, labels = NULL) unlist() -> factors # Insert levels for factors after the variable name - if (any(factors)) - { + if (any(factors)) { factors_idx <- which(factors) # Factor names in **bold** @@ -170,16 +166,14 @@ 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) -{ +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)) %>% @@ -189,8 +183,7 @@ desctable.default <- function(data, stats = stats_auto, tests, labels = NULL) #' @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 <- dplyr::groups(data) data <- dplyr::ungroup(data) @@ -210,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(), @@ -227,8 +219,7 @@ 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[!names(df) %in% as.character(grp)] @@ -237,13 +228,12 @@ testColumn <- function(df, tests, grp) # 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)) - { + if (is.function(tests)) { ftests <- lapply(df, tests, factor(group)) tests <- ftests - } else if (!is.null(tests$.auto)) ftests <- lapply(df, tests$.auto, factor(group)) + } 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}) + else ftests <- lapply(df, function(x){stats::kruskal.test}) # Select the forced (named) tests tests %>% @@ -268,11 +258,9 @@ 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) -{ +subTable <- function(df, stats, tests, grps) { # Final group, compute tests - if (length(grps) == 1) - { + if (length(grps) == 1) { group <- factor(eval(grps[[1]], df)) # Create the subtable stats @@ -285,9 +273,7 @@ subTable <- function(df, stats, tests, grps) 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 diff --git a/R/convenience_functions.R b/R/convenience_functions.R index 79d85a0..ee950c1 100644 --- a/R/convenience_functions.R +++ b/R/convenience_functions.R @@ -6,10 +6,9 @@ #' @param x A factor #' @export #' @return A nlevels(x) + 1 length vector of percentages -percent <- function(x) -{ +percent <- function(x) { if (is.factor(x)) c(NA, summary(x, maxsum = Inf) / length(x)) * 100 - else NA + else NA } @@ -19,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)) } @@ -33,8 +31,7 @@ IQR <- function(x) #' @param x A numerical vector #' @export #' @return A boolean -is.normal <- function(x) -{ +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 @@ -186,15 +183,13 @@ 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, ...) -{ +fisher.test.default <- function(x, ...) { stats::fisher.test(x, ...) } @@ -209,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) } @@ -349,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") } @@ -366,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) } @@ -383,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) } @@ -393,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) } diff --git a/R/output.R b/R/output.R index 61e60a2..3ab5992 100644 --- a/R/output.R +++ b/R/output.R @@ -4,8 +4,7 @@ #' @param ... Additional print parameters #' @return A flat dataframe #' @export -print.desctable <- function(x, ...) -{ +print.desctable <- function(x, ...) { print(as.data.frame(x)) } @@ -16,8 +15,7 @@ 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) @@ -50,8 +48,7 @@ pander.desctable <- function(x = NULL, keep.line.breaks = T, split.tables = Inf, emphasize.rownames = F, - ...) -{ + ...) { if (is.null(digits)) digits <- pander::panderOptions("digits") # Discard "markdown" and insert 4 NbSp before factor levels @@ -112,8 +109,7 @@ pander.desctable <- function(x = NULL, #' ### #' @inheritParams DT::datatable #' @export -datatable <- function(data, ...) -{ +datatable <- function(data, ...) { UseMethod("datatable", data) } @@ -135,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, ...) } @@ -167,8 +162,7 @@ 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("\\*\\*(.*?)\\*\\*", "\\1", data$Variables$Variables) diff --git a/R/stats.R b/R/stats.R index c0a5cc4..3cace49 100644 --- a/R/stats.R +++ b/R/stats.R @@ -13,16 +13,14 @@ #' @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) -{ +statify.default <- function(x, f) { # Discard NA values x <- stats::na.omit(x) @@ -32,13 +30,10 @@ statify.default <- function(x, f) 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 (is.factor(x)) - { + if (is.factor(x)) { if (length(res) == nlevels(x) + 1) res - else if (length(res) == 1) - { - c(res, lapply(levels(x), function(lvl) - { + 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) @@ -46,10 +41,8 @@ statify.default <- function(x, f) } 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) - { + } else { + if (length(res) == 1) { if (is.numeric(res) | is.na(res)) res else as.character(res) } @@ -60,8 +53,7 @@ statify.default <- function(x, f) #' @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]]) # else parse the formula (cond ~ T | F) @@ -86,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, @@ -99,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, @@ -110,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, @@ -121,20 +110,16 @@ 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 - { + } else { normal <- any(shapiro) nonnormal <- any(!shapiro) } diff --git a/R/tests.R b/R/tests.R index e242da4..ef9871a 100644 --- a/R/tests.R +++ b/R/tests.R @@ -7,8 +7,7 @@ #' @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) -{ +testify <- function(x, f, group) { # Extract the name of the function f %>% deparse() %>% @@ -21,18 +20,12 @@ testify <- function(x, f, group) error = function(e) {message(e);NaN}) # 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) - } + 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) } @@ -46,37 +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) -{ +tests_auto <- function(var, grp) { grp <- factor(grp) - if (nlevels(grp) < 2) ~no.test - else if (is.factor(var)) - { - if (tryCatch(fisher.test(var ~ grp)$p.value %>% is.numeric(), error = function(e) F)) ~fisher.test - else ~chisq.test - } - else - { + 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) + 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) - { + 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 ~oneway.test(., var.equal = F) } - else ~kruskal.test + else ~kruskal.test } } } diff --git a/R/utils.R b/R/utils.R index a88949c..d15360f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -7,8 +7,7 @@ #' @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) -{ +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) @@ -36,8 +35,7 @@ insert <- function(x, y, position) #' #' @param x Object to set the "desctable" class to #' @return The object with the class "desctable" -set_desctable_class <- function(x) -{ +set_desctable_class <- function(x) { class(x) <- "desctable" x @@ -59,31 +57,26 @@ set_desctable_class <- function(x) #' @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) - { +parse_formula <- function(x, f) { + parse_f <- function(x) { if (length(x) == 1) as.character(x) - else - { - if (as.character(x[[1]]) == "~") - { + else { + if (as.character(x[[1]]) == "~") { paste0("if (", parse_f(x[[2]]), "(x)) ", "{", parse_f(x[[3]]), "}") - } else if (as.character(x[[1]]) == "|") - { + } else if (as.character(x[[1]]) == "|") { paste0(parse_f(x[[2]]), "} else ", "{", parse_f(x[[3]])) - } else if (as.character(x[[1]]) == "(") - { + } else if (as.character(x[[1]]) == "(") { parse_f(x[[2]]) } } } + eval(parse(text = parse_f(f))) } @@ -92,16 +85,13 @@ parse_formula <- function(x, f) #' #' @param head A headerList object #' @return A names vector -head_pander <- function(head) -{ - if (is.integer(head[[1]])) - { +head_pander <- function(head) { + if (is.integer(head[[1]])) { head %>% names %>% lapply(function(x){c(x, rep("", head[[x]] - 1))}) %>% unlist() - } else - { + } else { paste(head %>% names() %>% lapply(function(x){c(x, rep("", attr(head[[x]], "colspan") - 1))}) %>% @@ -118,12 +108,10 @@ 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 (is.list(head[[1]])) - { + 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)) @@ -138,16 +126,13 @@ head_datatable <- function(head) #' #' @param head A headerList object #' @return A names vector -head_dataframe <- function(head) -{ - if (is.integer(head[[1]])) - { +head_dataframe <- function(head) { + if (is.integer(head[[1]])) { head %>% names() %>% lapply(function(x){rep(x, head[[x]])}) %>% unlist() - } else - { + } else { paste(head %>% names() %>% lapply(function(x){rep(x, attr(head[[x]], "colspan"))}) %>% @@ -168,8 +153,7 @@ 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")) -{ +header <- function(desctable, output = c("pander", "datatable", "dataframe")) { desctable[-1] %>% flatten_desctable() %>% data.frame(check.names = F) %>% @@ -177,28 +161,21 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) desctable <- desctable[-1] - if (length(desctable) == 1) - { - if (output == "datatable") - { + 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 - { + } else c("\u00A0", nm) + } else { head <- headerList(desctable) - if (output == "pander") - { + if (output == "pander") { c("\u00A0", head_pander(head) %>% paste(nm, sep = "
")) - } else if (output == "datatable") - { + } 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]]) @@ -206,8 +183,7 @@ header <- function(desctable, output = c("pander", "datatable", "dataframe")) 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 = " / ")) } } @@ -218,15 +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) -{ +headerList <- function(desctable) { if (is.data.frame(desctable)) length(desctable) - else - { + 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() + else attr(rec, "colspan") <- rec %>% lapply(attr, "colspan") %>% unlist() %>% sum() rec } @@ -237,11 +211,9 @@ headerList <- function(desctable) #' #' @param desctable A desctable object #' @return A flat dataframe -flatten_desctable <- function(desctable) -{ +flatten_desctable <- function(desctable) { if (is.data.frame(desctable)) desctable - else - { + else { desctable %>% lapply(flatten_desctable) %>% Reduce(f = cbind) From fd151e11314c0c817ddc247edd3adcc2a4d301bb Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 19:24:11 +0200 Subject: [PATCH 12/15] Fix wrong cbind instead of rbind for results of tests --- R/build.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/build.R b/R/build.R index 65469d3..004b4c9 100644 --- a/R/build.R +++ b/R/build.R @@ -5,7 +5,7 @@ #' #' 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 @@ -247,7 +247,7 @@ testColumn <- function(df, tests, grp) { # Compute the tests (made safe with testify) on the variable, using the grouping variable df %>% purrr::map2(ftests, testify, group) %>% - Reduce(f = cbind) + Reduce(f = rbind) } From 756c032f4b141966e430b0292746b71827f18b1b Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 29 Jul 2019 19:24:38 +0200 Subject: [PATCH 13/15] Fix wrong correction of functional pipelines into applications --- R/tests.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/tests.R b/R/tests.R index ef9871a..76857f0 100644 --- a/R/tests.R +++ b/R/tests.R @@ -51,14 +51,14 @@ tests_auto <- function(var, grp) { 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) + 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) + 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 } From 9090b5928e5652c22f450ee684947d7874feeca7 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Tue, 30 Jul 2019 13:55:59 +0200 Subject: [PATCH 14/15] Remove purrr import --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0be2184..ccdf794 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -15,13 +15,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: 6.1.1 VignetteBuilder: knitr From 0dfc511cd0906bbaeb158595b2fedd32005f4660 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Mon, 3 Feb 2020 16:52:41 +0100 Subject: [PATCH 15/15] Bump version and news --- DESCRIPTION | 2 +- NEWS | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 0f8e211..475358d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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. diff --git a/NEWS b/NEWS index 74b6ee2..78426f7 100644 --- a/NEWS +++ b/NEWS @@ -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