Form

form.R

# Sketch for a form() function to be inserted in the future form.io R package
# Copyright (c) 2019, Philippe Grosjean (phgrosjean@sciviews.org)
# 
# TODO:
# - Use something else than caption (may be comment?) for the default legend of
#   the tables
# - ...

#' Form tabular and textual output of various R objects using markdown
#'
#' @param x An R object
#' @param ... Further aerguments (depends on the class of `x`)
#' @param data A data frame or tibble to be used to extract lables and/units
#' @param options Pander options (see`panderOptions()`)
#' @param table_split Number of characters to accept for the widrth of the table
#' before splitting it (`pander()` functions)
#' @param table_row_align How to align table row names (`"left"` by default)
#' @param signif_stars For `anova` objects, do we write significance stars?
#' @param lang The language to use for the output. By default, it is the
#' `data.io_lang` options (same one as for the `data.io` package)
#'
#' @description Use rich-text formatting (R markdown) to output the content of
#' \R objects by using `kable()` or `pander()` functions. Output should be
#' readable at the R console, inside inline eleme nts in an R Notebook and in
#' both HTML and LaTeX kintted documents. Moreover, they are translatable in
#' different languages `lang =` argument, and labels and/or units for variables
#' can also be used in place of the name of these variables.
#' 
#' @return A character string with the formatted results
#' @author Philippe Grosjean (phgrosjean@sciviews.org)
#' @export
#' @seealso [knitr::kable()], [pander::pander()]
#' @keywords utilities
#' @concept rich-formatted outputs
#'
#' @examples
#' SciViews::R
#' options(data.io_lang = "FR")
#' trees <- read("trees", package = "datasets")
#' lm_1 <- lm(data = trees, volume ~ .)
#' form(trees)
#' form(head(trees), data = trees) # Try without data =
#' form(anova(lm_1), data = trees)
form <- function(x, ...)
  UseMethod("form")

#' @export
#' @rdname form
form.default <- function(x, caption = attr(x, "caption"), ..., data = NULL,
options = list(digits = 2, missing = "", table.style = "rmarkdown"),
table_split = 120L, table_row_align = "left",
lang = getOption("data.io_lang", "en")) {
  # Get pander options
  p_old_opts <- p_opts <- pander::panderOptions()
  
  # Change pander options according to lang
  lang <- tolower(lang)
  # Currently only use "en" or "us" (no changes), or "fr"
  p_new_opts <- switch(lang,
    en    = list(),
    en_us = list(),
    fr    = list(decimal.mark = ",", formula.caption.prefix = "Formule : ",
      date = "%d/%m/%Y %H:%M:%S", #table.caption.prefix = "Tableau : ",
      table.continues = "Le tableau continue ci-dessous",
      table.continues.affix = "(continue ci-dessous)", p.copula = " et "),
    list())
  # Replace new language options into p_opts
  p_opts[names(p_new_opts)] <- p_new_opts
  # Replace custom options into p_opts
  p_opts[names(options)] <- options
  # Use as default pander options for now
  options(pander = p_opts)
  # Change length for table split and row names alignment
  pander::panderOptions("table.split.table", table_split)
  pander::panderOptions("table.alignment.rownames", table_row_align)
  # Restore previous pander options on exit
  on.exit(options(pander = p_old_opts))
  
  # If we knit a document, or execute the code outside of an R Notebook chunk
  if (isTRUE(getOption("knitr.in.progress")) ||
    !getOption("rstudio.notebook.executing", FALSE)) {
    # Use default pander() function
    pander::pander(x, caption = caption, ...)
  } else {# In an R Notebook, use special code to produce a knit_asis object
    knitr::asis_output(pander::pander_return(x, caption = caption, ...))
  }
}
#print.form <- function(x, ...) {
#  cat("print\n")
#}

#knit_print.form <- function(x, ...) {
#  cat("knit_print\n")
#}

rephrase <- function(x, data = NULL, ...,
lang = getOption("data.io_lang", "en"))
  UseMethod("rephrase")

# The default method just returns the object unmodified
rephrase.default <- function(x, data = NULL, ...,
lang = getOption("data.io_lang", "en"))
  x

rephrase.anova <- function(x, data = NULL, ...,
lang = getOption("data.io_lang", "en")) {
  # Minimal check of the object
  if (!is.list(x) || length(x) != 5) {
    warning("Strange 'anova' object (not a list of 5 items)")
    return(x)
  }
  
  # Get translated stuff
  tr <- switch(tolower(lang),
    fr = list(header =
      c("DDL", "Somme carrés", "Carrés moyens", "Stat. _F_", "Valeur _p_"),
      residuals = "Résidus", response = "Réponse :",
      caption = "Tableau d'analyse de la variance\n"),
    en_us = ,
    en_uk = ,
    en = ,
    list(header =
      c("DF", "Sum Squares", "Mean Squares", "_F_ Stat.", "_p_-value"),
      residuals = "Residuals", response = "Response:",
      caption = "Analysis of Variance Table\n")
  )
  
  # Replace column headers
  names(x) <- tr$header

  # Replace Residuals in row.names (last item)
  rn <- rownames(x)
  names(rn) <- rn
  rn[length(rn)] <- tr$residuals
  # If data is provided, try to replace variables by their labels
  labels <- data.io::label(data)
  labels[labels == ""] <- NA
  labels_rn <- na.omit(labels[rn])
  nlabels_rn <- names(labels_rn)
  rn[nlabels_rn] <- labels[nlabels_rn]
  rownames(x) <- as.character(rn)
  
  # Possibly replace heading
  head <- attr(x, "heading")
  if (!is.null(head)) {
    response_var <- strsplit(head[2], ": ", fixed = TRUE)[[1]][2]
    response_label <- labels[response_var]
    if (!is.na(response_label) && !is.null(response_label))
      response_var <- response_label
    attr(x, "heading") <-
      c(tr$caption, paste(tr$response, response_var))
  }
  x
}

#' @export
#' @rdname form
form.anova <- function(x, caption = attr(x, "caption"), data = NULL,
signif_stars = TRUE, ..., lang = getOption("data.io_lang", "en")) {
  x <- rephrase(x, data = data, lang = lang)
  res <- form.default(x, caption = caption, data = data,
    add.significance.stars = signif_stars, ..., lang = lang)
  
  # Replace Signif. codes:
  # TODO: how to do that? When pander() is called, I cannot change its output!
  res
}

# Also works on data.tables, because they also are data.frames
rephrase.data.frame <- function(x, data = NULL, labels = TRUE, units = TRUE,
..., lang = getOption("data.io_lang", "en")) {
  # Replace column headers by labels if data is provided,
  # otherwise use labels from x if present
  if (!isTRUE(labels)) return(x)
  
  if (isTRUE(units)) {
    if (!is.null(data)) {
      labels <- sapply(data, data.io::label, units = TRUE)
    } else {
      labels <- sapply(x, data.io::label, units = TRUE)
    }
    # Replace two spaces before units with a single one
    labels <- sub("  \\[", " [", labels)
    # Replace ^x by ^x and _x by ~x~ for uppercase or lowercase numbers
    labels <- gsub("\\^([0-9])", "^\\1^", labels)
    labels <- gsub("_([0-9])", "~\\1~", labels)
  } else {# No units
    if (!is.null(data)) {
      labels <- data.io::label(data)
    } else {
      labels <- data.io::label(x)
    }
  }
  labels[labels == ""] <- NA
  x_names <- names(x)
  names(x_names) <- x_names
  labels_rn <- na.omit(labels[x_names])
  nlabels_rn <- names(labels_rn)
  x_names[nlabels_rn] <- labels[nlabels_rn]
  names(x) <- as.character(x_names)
  x
}

form.data.frame <- function(x, caption = attr(x, "caption"), data = NULL,
labels = TRUE, units = TRUE, ..., lang = getOption("data.io_lang", "en")) {
  x <- rephrase(x, data = data, labels = labels, units = units, lang = lang)
  lang <- tolower(lang)
  form.default(x, caption = caption, data = data, ..., lang = lang)
}

To use it:

SciViews::R
options(data.io_lang = "FR")
source("https://go.sciviews.org/form")

# Test
trees <- read("trees", package = "datasets")
lm_1 <- lm(data = trees, volume ~ .)
form(trees)
form(head(trees), data = trees) # Try without data =
form(anova(lm_1), data = trees)

Do you have an idea, why the labels do not print with lang = EN or en

SciViews::R
options(data.io_lang = "EN")
source("https://go.sciviews.org/form")

# Test
trees <- read("trees", package = "datasets")
form(trees)
form(head(trees), data = trees) 

Yes: because it is not programmed yet!

... But see the repository https://github.com/SciViews/form.io

New version that works with 'fr', 'en', en_us' & 'en_uk' (don't forget to eliminate the form.io.R file from the /R subdirectory on your local repo to get latest version, then run all chunks into https://github.com/SciViews/form.io to test it.