R/deprecated.R

In MaximeWack/desctable: Produce Descriptive and Comparative Tables Easily

#' @importFrom pander pander
pander::pander

#' Generate a statistics table
#'
#' Generate a statistics table with the chosen statistical functions, and tests if given a \code{"grouped"} dataframe.
#'
#' @section Labels:
#' labels is an option named character vector used to make the table prettier.
#'
#' If given, the variable names for which there is a label will be replaced by their corresponding label.
#'
#' Not all variables need to have a label, and labels for non-existing variables are ignored.
#'
#' labels must be given in the form c(unquoted_variable_name = "label")
#'
#' @section Stats:
#' The stats can be a function which takes a dataframe and returns a list of statistical functions to use.
#'
#' stats can also be a named list of statistical functions, or purrr::map like formulas.
#'
#' The names will be used as column names in the resulting table. If an element of the list is a function, it will be used as-is for the stats.
#'
#' @section Tests:
#' The tests can be a function which takes a variable and a grouping variable, and returns an appropriate statistical test to use in that case.
#'
#' tests can also be a named list of statistical test functions, associating the name of a variable in the data and a test to use specifically for that variable.
#'
#' That test name must be expressed as a single-term formula (e.g. \code{~t.test}), or a purrr::map like formula
#' (e.g. \code{~t.test(., var.equal = T)}). You don't have to specify tests for all the variables: a default test for
#' all other variables can be defined with the name \code{.default}, and an automatic test can be defined with the name \code{.auto}.
#'
#' If data is a grouped dataframe (using \code{group_by}), subtables are created and statistic tests are performed over each sub-group.
#'
#' @section Output:
#' The output is a desctable object, which is a list of named dataframes that can be further manipulated. Methods for printing, using in \pkg{pander} and \pkg{DT} are present. Printing reduces the object to a dataframe.
#'
#' @param data The dataframe to analyze
#' @param stats A list of named statistics to apply to each element of the dataframe, or a function returning a list of named statistics
#' @param tests A list of statistical tests to use when calling desctable with a grouped_df
#' @param labels A named character vector of labels to use instead of variable names
#' @return A desctable object, which prints to a table of statistics for all variables
#' @seealso \code{\link{stats_auto}}
#' @seealso \code{\link{tests_auto}}
#' @seealso \code{\link{print.desctable}}
#' @seealso \code{\link{pander.desctable}}
#' @seealso \code{\link{datatable.desctable}}
#' @export
#' @keywords deprecated
#' @examples
#' iris %>%
#'   desctable()
#'
#' # Does the same as stats_auto here
#' iris %>%
#'   desctable(stats = list("N"      = length,
#'                          "Mean"   = ~ if (is.normal(.)) mean(.),
#'                          "sd"     = ~ if (is.normal(.)) sd(.),
#'                          "Med"    = stats::median,
#'                          "IQR"    = ~ if(!is.factor(.)) IQR(.)))
#'
#' # With labels
#' mtcars %>% desctable(labels = c(hp  = "Horse Power",
#'                                 cyl = "Cylinders",
#'                                 mpg = "Miles per gallon"))
#'
#' # With grouping on a factor
#' iris %>%
#'   group_by(Species) %>%
#'   desctable(stats = stats_default)
#'
#' # With nested grouping, on arbitrary variables
#' mtcars %>%
#'   group_by(vs, cyl) %>%
#'   desctable()
#'
#' # With grouping on a condition, and choice of tests
#' iris %>%
#'   group_by(Petal.Length > 5) %>%
#'   desctable(tests = list(.auto = tests_auto, Species = ~chisq.test))
desctable <- function(data, stats, tests, labels) {
  warning("desctable is deprecated and will be removed in 1.0.0.

Please use the `desc_*` family of functions (`desc_table`, `desc_tests`, `desc_output`)")
  UseMethod("desctable", data)
}


#' @rdname desctable
#' @export
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)) %>%
  set_desctable_class()
}


#' @rdname desctable
#' @export
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)

  # 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()
}


#' Create the subtables names
#'
#' Create the subtables names, as
#' factor: level (n=sub-group length)
#'
#' @param grp Grouping factor
#' @param df Dataframe containing the grouping factor
#' @return A character vector with the names for the subtables
#' @keywords deprecated internal
subNames <- function(grp, df) {
  paste0(as.character(grp),
         ": ",
         eval(grp, df) %>% factor() %>% levels(),
         " (n=",
         summary(eval(grp, df) %>% factor() %>% stats::na.omit(), maxsum = Inf),
         ")")
}


#' Create a subtable in a grouped desctable
#'
#' @param df Dataframe to use
#' @param stats Stats list/function to use
#' @param tests Tests list/function to use
#' @param grps List of symbols for grouping factors
#' @return A nested list of statTables and testColumns
#' @keywords deprecated internal
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[!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
    pvalues <- testColumn(df, tests, grps[[1]])

    c(stats, tests = list(pvalues))
  } else {
    group <- eval(grps[[1]], df)

    # Go through the next grouping levels and build the subtables
    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))
  }
}


#' Print method for desctable
#'
#' @param x A desctable
#' @param ... Additional print parameters
#' @return A flat dataframe
#' @export
#' @keywords deprecated
print.desctable <- function(x, ...) {
  print(as.data.frame(x))
}


#' As.data.frame method for desctable
#'
#' @param x A desctable
#' @param ... Additional as.data.frame parameters
#' @return A flat dataframe
#' @export
#' @keywords deprecated
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, ...) %>%
    stats::setNames(header)
}


#' Pander method for desctable
#'
#' Pander method to output a desctable
#'
#' Uses \code{pandoc.table}, with some default parameters (\code{digits = 2}, \code{justify = "left"}, \code{missing = ""}, \code{keep.line.breaks = T}, \code{split.tables = Inf}, and \code{emphasize.rownames = F}), that you can override if needed.
#'
#' @param x A desctable
#' @inheritParams pander::pandoc.table
#' @seealso \code{\link{pandoc.table}}
#' @export
#' @keywords deprecated
pander.desctable <- function(x = NULL,
                             digits = 2,
                             justify = "left",
                             missing = "",
                             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
  x$Variables$Variables <- gsub("\\*\\*(.*?)\\*\\*: \\*(.*?)\\*", "&nbsp;&nbsp;&nbsp;&nbsp;\\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) %>%
    stats::setNames(header) %>%
    pander::pandoc.table(justify = justify,
                         digits = digits,
                         missing = missing,
                         keep.line.breaks = keep.line.breaks,
                         split.tables = split.tables,
                         emphasize.rownames = emphasize.rownames,
                         ...)
}


#' Create an HTML table widget using the DataTables library
#'
#' This function creates an HTML widget to display rectangular data (a matrix or data frame) using the JavaScript library DataTables, with a method for \code{desctable} objects.
#'
#' @note
#' You are recommended to escape the table content for security reasons (e.g. XSS attacks) when using this function in Shiny or any other dynamic web applications.
#' @references
#' See \url{https://rstudio.github.io/DT/} for the full documentation.
#' @examples
#' library(DT)
#'
#' # see the package vignette for examples and the link to website
#' vignette('DT', package = 'DT')
#'
#' # some boring edge cases for testing purposes
#' m = matrix(nrow = 0, ncol = 5, dimnames = list(NULL, letters[1:5]))
#' datatable(m)  # zero rows
#' datatable(as.data.frame(m))
#'
#' m = matrix(1, dimnames = list(NULL, 'a'))
#' datatable(m)  # one row and one column
#' datatable(as.data.frame(m))
#'
#' m = data.frame(a = 1, b = 2, c = 3)
#' datatable(m)
#' datatable(as.matrix(m))
#'
#' # dates
#' datatable(data.frame(
#'   date = seq(as.Date("2015-01-01"), by = "day", length.out = 5), x = 1:5
#' ))
#' datatable(data.frame(x = Sys.Date()))
#' datatable(data.frame(x = Sys.time()))
#'
#' ###
#' @inheritParams DT::datatable
#' @export
#' @keywords deprecated
datatable <- function(data, ...) {
  UseMethod("datatable", data)
}


#' @rdname datatable
#' @export
datatable.default <- function(data,
                              options = list(),
                              class = "display",
                              callback = DT::JS("return table;"),
                              caption = NULL,
                              filter = c("none", "bottom", "top"),
                              escape = TRUE,
                              style = "default",
                              width = NULL,
                              height = NULL,
                              elementId = NULL,
                              fillContainer = getOption("DT.fillContainer", NULL),
                              autoHideNavigation = getOption("DT.autoHideNavigation", NULL),
                              selection = c("multiple", "single", "none"),
                              extensions = list(),
                              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, ...)
}


#' @rdname datatable
#' @inheritParams base::prettyNum
#' @export
datatable.desctable <- function(data,
                                options = list(paging = F,
                                               info = F,
                                               search = list(),
                                               dom = "Brtip",
                                               fixedColumns = T,
                                               fixedHeader = T,
                                               buttons = c("copy", "excel")),
                                class = "display",
                                callback = DT::JS("return table;"),
                                caption = NULL,
                                filter = c("none", "bottom", "top"),
                                escape = FALSE,
                                style = "default",
                                width = NULL,
                                height = NULL,
                                elementId = NULL,
                                fillContainer = getOption("DT.fillContainer", NULL),
                                autoHideNavigation = getOption("DT.autoHideNavigation", NULL),
                                selection = c("multiple", "single", "none"),
                                extensions = c("FixedHeader", "FixedColumns", "Buttons"),
                                plugins = NULL,
                                rownames = F,
                                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)

  # 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 %>%
      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,
                  options = options,
                  extensions = extensions,
                  escape = escape,
                  class = class,
                  callback = callback,
                  caption = caption,
                  filter = filter,
                  style = style,
                  width = width,
                  height = height,
                  elementId = elementId,
                  fillContainer = fillContainer,
                  autoHideNavigation = autoHideNavigation,
                  selection = selection,
                  plugins = plugins,
                  rownames = rownames, ...)
}

#' Set the "desctable" class to the passed object
#'
#' @param x Object to set the "desctable" class to
#' @return The object with the class "desctable"
#' @keywords deprecated internal
set_desctable_class <- function(x) {
  class(x) <- "desctable"

  x
}


#' Parse a formula
#'
#' Parse a formula defining the conditions to pick a stat/test
#'
#' Parse a formula defining the conditions to pick a stat/test
#' and return the function to use.
#' The formula is to be given in the form of
#' conditional ~ T | F
#' and conditions can be nested such as
#' conditional1 ~ (conditional2 ~ T | F) | F
#' The FALSE option can be omitted, and the TRUE can be replaced with NA
#'
#' @param x The variable to test it on
#' @param f A formula to parse
#' @return A function to use as a stat/test
#' @keywords deprecated internal
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)) ",
               "{",
               parse_f(x[[3]]),
               "}")
      } else if (as.character(x[[1]]) == "|") {
        paste0(parse_f(x[[2]]),
               "} else ",
               "{",
               parse_f(x[[3]]))
      } else if (as.character(x[[1]]) == "(") {
        parse_f(x[[2]])
      }
    }
  }

  eval(parse(text = parse_f(f)))
}


#' Build the header for pander
#'
#' @param head A headerList object
#' @return A names vector
#' @keywords deprecated internal
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/>")
  }
}


#' Build the header for datatable
#'
#' @param head A headerList object
#' @return An htmltools$tags object containing the header
#' @keywords deprecated internal
head_datatable <- function(head) {
  TRs <- list()

  while (is.list(head[[1]])) {
    TR <- mapply(function(x, y) htmltools::tags$th(x, colspan = y), names(head), lapply(head, attr, "colspan"), SIMPLIFY = F)

    TRs <- c(TRs, list(TR))
    head <- purrr::flatten(head)
  }

  c(TRs, list(mapply(function(x, y) htmltools::tags$th(x, colspan = y), names(head), head, SIMPLIFY = F)))
}


#' Build the header for dataframe
#'
#' @param head A headerList object
#' @return A names vector
#' @keywords deprecated internal
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 = " / ")
  }
}


#' Build header
#'
#' Take a desctable object and create a suitable header for the mentionned output.
#' Output can be one of "pander", "datatable", or "dataframe".
#'
#' @param desctable A desctable object
#' @param output An output format for the header
#' @return A header object in the output format
#' @keywords deprecated internal
header <- function(desctable, output = c("pander", "datatable", "dataframe")) {
  desctable[-1] %>%
    flatten_desctable() %>%
    data.frame(check.names = F) %>%
    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 {
    head <- headerList(desctable)

    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") {
      c("\u00A0", head_dataframe(head) %>% paste(nm, sep = " / "))
    }
  }
}


#' build a header list object
#'
#' @param desctable a desctable
#' @return a nested list of headers with colspans
#' @keywords deprecated internal
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
  }
}


#' Flatten a desctable to a dataframe recursively
#'
#' @param desctable A desctable object
#' @return A flat dataframe
#' @keywords deprecated internal
flatten_desctable <- function(desctable) {
  if (is.data.frame(desctable)) desctable
  else {
    desctable %>%
      lapply(flatten_desctable) %>%
      Reduce(f = cbind)
  }
}

#' Define a list of default statistics
#'
#' @param data A dataframe
#' @return A list of statistical functions
#' @export
#' @keywords deprecated
stats_default <- function(data) {
  list("N" = length,
       "%" = percent,
       "Mean" = ~if (is.normal(.)) mean(.),
       "sd" = ~if (is.normal(.)) sd(.),
       "Med" = stats::median,
       "IQR" = ~if (!is.factor(.)) IQR(.))
}


#' @rdname stats_default
#' @export
stats_normal <- function(data) {
  list("N" = length,
       "%" = percent,
       "Mean" = mean,
       "sd" = stats::sd)
}


#' @rdname stats_default
#' @export
stats_nonnormal <- function(data) {
  list("N" = length,
       "%" = percent,
       "Median" = stats::median,
       "IQR" = ~if (!is.factor(.)) IQR(.))
}