R/deparse_formula.R

In tablespan: Create Satisficing 'Excel', 'HTML', 'LaTeX', and 'RTF' Tables using a Simple Formula

#' deparse_formula
#'
#' Translates an R formula into nested lists for both the left and the right
#' hand side to create table rows and banners. Importantly, this function
#' can only parse a specific subset of formulas that allows for the following
#' grammar:
#'
#' 1) Braces group columns
#' 2) Equal signs assign the left hand side as name for multiple columns
#' 3) plus signs combine columns
#'
#' @param formula an R formula following the pattern above
#' @returns nested lists for the left hand side and right hand side of the formula
#' @noRd
#' @examples
#' library(tablespan)
#' deparsed <- tablespan:::deparse_formula(formula =
#'  (`Row Name` = `Row 1` + `Row 2`) ~ `Column 1` + (`Column Banner` = `Column 2` + `Column 3`))
#' str(deparsed)
deparse_formula <- function(formula) {
  if (formula[[2]] == "1") {
    lhs <- NULL
  } else {
    lhs <- deparse_formula_partial(formula_partial = formula[[2]])
  }

  if (formula[[3]] == "1") {
    stop("Missing right hand side of formula.")
  } else {
    rhs <- deparse_formula_partial(formula_partial = formula[[3]])
  }

  return(list(lhs = lhs, rhs = rhs))
}

#' deparse_formula_partial
#'
#' Translates the left of right hand side of an R formula into a nested list. Importantly, this function
#' can only parse a specific subset of formulas that allows for the following
#' grammar:
#'
#' 1) Braces group columns
#' 2) Equal signs assign the left hand side as name for multiple columns
#' 3) plus signs combine columns
#'
#' @param formula_partial the left or right hand side of an R formula following the pattern above
#' @param deparsed this function is a recursive function and makes use of the deparsed list.
#' Don't change this manually.
#' @returns a nested list with formula elements
#' @importFrom methods is
#' @noRd
#' @examples
#' library(tablespan)
#' formula <- (`Row Name` = `Row 1` + `Row 2`) ~
#'   `Column 1` + (`Column Banner` = `Column 2` + `Column 3`)
#'
#' deparsed <- tablespan:::deparse_formula_partial(formula_partial = formula[[2]])
#' str(deparsed)
deparse_formula_partial <- function(
  formula_partial,
  deparsed = list(name = "_BASE_LEVEL_", entries = list())
) {
  # There are three types of symbols on the right hand side:
  # 1) Braces group columns
  # 2) Equal signs assign the left hand side as name for multiple columns
  # 3) plus signs combine columns
  # We want to translate the above in a list. For example, we want
  # (a = b1 + b2)
  # to become
  # list(a = c("b1", "b2"))

  if (length(formula_partial) == 1) {
    deparsed$entries <- c(
      deparsed$entries,
      list(list(
        name = as.character(formula_partial),
        item_name = as.character(formula_partial),
        entries = NULL
      ))
    )
    return(deparsed)
  }

  if ((formula_partial[[1]] == ":")) {
    if (
      (length(formula_partial[[2]]) == 1) & (length(formula_partial[[3]]) == 1)
    ) {
      deparsed$entries <- c(
        deparsed$entries,
        list(list(
          name = as.character(formula_partial[[2]]),
          item_name = as.character(formula_partial[[3]]),
          entries = NULL
        ))
      )
      return(deparsed)
    } else {
      stop(paste0(
        "Renaming with ",
        as.character(formula_partial),
        " is not allowed. Both sides of the colon must be single names (e.g., a:b)."
      ))
    }
  }

  if (formula_partial[[1]] == "+") {
    deparsed <- deparse_formula_partial(formula_partial[[2]], deparsed)
    deparsed <- deparse_formula_partial(formula_partial[[3]], deparsed)
    return(deparsed)
  } else if (formula_partial[[1]] == "=") {
    # The left hand side is the name of the split, the right hand side
    # specifies the elements
    deparsed$name <- as.character(formula_partial[[2]])
    deparsed <- deparse_formula_partial(formula_partial[[3]], deparsed)
    return(deparsed)
  } else if (formula_partial[[1]] == "(") {
    # Check if there is a name for the current spanner
    try_name <- try(formula_partial[[2]][[1]] != "=", silent = TRUE)
    if (is(try_name, "try-error") | try_name) {
      stop("The following spanner has no label: ", formula_partial, ".")
    }
    # In case of a brace, we have to go one step deeper
    deparsed$entries <- c(
      deparsed$entries,
      list(deparse_formula_partial(
        formula_partial[[2]],
        list(name = NULL, entries = list())
      ))
    )
    return(deparsed)
  } else {
    stop(paste0(
      "Unknown symbol detected: ",
      paste0(as.character(formula_partial), collapse = "")
    ))
  }
}


#' get_variables
#'
#' Extracts the variable names from a deparsed formula (see ?tablespan:::deparse_formula).
#'
#' @param deparsed_formula result from tablespan:::deparse_formula
#' @returns a list with the names of the variables that build the rows and columns
#' @noRd
#' @examples
#' library(tablespan)
#' deparsed <- tablespan:::deparse_formula(formula =
#'  (`Row Name` = `Row 1` + `Row 2`) ~ `Column 1` + (`Column Banner` = `Column 2` + `Column 3`))
#' str(deparsed)
#' tablespan:::get_variables(deparsed)
get_variables <- function(deparsed_formula) {
  if (is.null(deparsed_formula$lhs)) {
    # no row variable
    row_variables <- NULL
  } else {
    row_variables <- get_variables_from_list(
      deparsed_formula_element = deparsed_formula$lhs
    )
  }

  col_variables <- get_variables_from_list(
    deparsed_formula_element = deparsed_formula$rhs
  )

  return(
    list(row_variables = row_variables, col_variables = col_variables)
  )
}

#' get_variables_from_list
#'
#' Extracts the variable names from the left or right hand side of a
#' deparsed formula (see ?tablespan:::deparse_formula).
#'
#' @param deparsed_formula_element left or right hand side of the result from
#' tablespan:::deparse_formula
#' @param variables the function is recursive and fills the variable vector
#' @returns a vector with the names of the variables
#' @noRd
#' @examples
#' library(tablespan)
#' deparsed <- tablespan:::deparse_formula(formula =
#'  (`Row Name` = `Row 1` + `Row 2`) ~ `Column 1` + (`Column Banner` = `Column 2` + `Column 3`))
#' str(deparsed)
#' tablespan:::get_variables_from_list(deparsed$lhs)
get_variables_from_list <- function(deparsed_formula_element, variables = c()) {
  if (is.null(deparsed_formula_element$entries)) {
    variables <- c(variables, deparsed_formula_element$item_name)
    return(variables)
  } else {
    for (entry in deparsed_formula_element$entries) {
      variables <- get_variables_from_list(entry, variables)
    }
    return(variables)
  }
}