Nothing
R/create_eq.R
In equatiomatic: Transform Models into 'LaTeX' Equations
Defines functions
fix_coef_signs
anno_greek
add_greek.forecast_ARIMA
add_greek.clm
add_greek.polr
add_greek.default
add_greek
add_coefs.forecast_ARIMA
add_coefs.clm
add_coefs.polr
add_coefs.default
add_coefs
add_hat
add_tex_mult
add_tex_superscripts_v
add_tex_superscripts
add_tex_subscripts_v
add_tex_subscripts
add_tex_ital_v
add_tex_ital
escape_tex
swap_names
create_term.forecast_ARIMA
check_math
add_math
create_term.default
create_term
create_eq.forecast_ARIMA
create_eq.clm
create_eq.polr
create_eq.glm
create_eq.default
create_eq
create_eq <- function(model, lhs, ...) {
UseMethod("create_eq", model)
}
#' Create the full equation
#'
#' @keywords internal
#'
#' @param lhs A character string of the left-hand side variable extracted with
#' \code{extract_lhs}
#' @param rhs A data frame of right-hand side variables extracted with
#' \code{extract_rhs}.
#'
#' @inheritParams extract_eq
#' @noRd
create_eq.default <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors, swap_var_names,
swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars,
swap_var_names, swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors,
raw_tex)
}
# Add error row or not in lm
if (!use_coefs) {
error_row <- rhs[nrow(rhs) + 1, ]
error_row$term <- "error"
error_row$final_terms <- "\\epsilon"
error_row$final_terms <- colorize(
greek_colors[length(greek_colors)],
error_row$final_terms
)
rhs <- rbind(rhs, error_row)
}
list(lhs = list(lhs), rhs = list(rhs$final_terms))
}
#' @noRd
#' @inheritParams extract_eq
create_eq.glm <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors,
swap_var_names, swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors, raw_tex)
}
if (!is.null(model$offset)) {
rhs <- rbind(rhs, c(
rep(NA, (dim(rhs)[2] - 1)),
add_tex_ital(tail(names(attr(model$terms, "dataClasses")), 1), ital_vars)
))
}
list(lhs = list(lhs), rhs = list(rhs$final_terms))
}
#' @noRd
create_eq.polr <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors,
swap_var_names, swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors, raw_tex)
}
splt <- split(rhs, rhs$coef.type)
rhs_final <- lapply(splt$scale$final_terms, function(x) {
c(x, splt$coefficient$final_terms)
})
attributes(lhs) <- NULL
list(lhs = lhs, rhs = rhs_final)
}
#' @noRd
create_eq.clm <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors,
swap_var_names, swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors, raw_tex)
}
splt <- split(rhs, rhs$coef.type)
rhs_final <- lapply(splt$intercept$final_terms, function(x) {
c(x, splt$location$final_terms)
})
attributes(lhs) <- NULL
list(lhs = lhs, rhs = rhs_final)
}
#' Create equations from forecast::Arima object
#'
#' @keywords internal
#'
#' @param lhs A data frame of right-hand side variables extracted with
#' \code{extract_lhs}
#' @param rhs A data frame of right-hand side variables extracted with
#' \code{extract_rhs}.
#' @param yt A data frame of regression variables extracted with
#' \code{helper_arima_extract_lm}.
#'
#' @return A dataframe
#' @noRd
create_eq.forecast_ARIMA <- function(model, lhs, rhs, yt, ital_vars, use_coefs,
coef_digits, raw_tex, swap_var_names,
swap_subscript_names, ...) {
# Determine if we are working on Regression w/ Arima Errors
regression <- helper_arima_is_regression(model)
# Convert sides into LATEX-like terms
lhs$final_terms <- create_term(lhs, ital_vars, swap_var_names,
swap_subscript_names)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names)
# Combine coefs or greek letters with the terms
if (use_coefs) {
lhs$final_terms <- add_coefs(lhs, lhs$final_terms, coef_digits, side_sign = -1)
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits, side_sign = 1)
} else {
lhs$final_terms <- add_greek(lhs, lhs$final_terms, regression, raw_tex, side_sign = -1)
rhs$final_terms <- add_greek(rhs, rhs$final_terms, regression, raw_tex, side_sign = 1)
}
# Convert the final terms into proper Backshift notation for L/RHS
## Setup the parsing functions
parsing_functions <- list(
"ar" = function(x) paste("(1", paste0(x, collapse = " "), ")\\"),
"diffs" = function(x) paste(x, collapse = "\\ "),
"error" = function(x) x
)
parsing_functions["sar"] <- parsing_functions["ar"]
parsing_functions["ma"] <- parsing_functions["ar"]
parsing_functions["sma"] <- parsing_functions["ar"]
## Parse the LHS
lhs_intercept <- lhs$final_terms[lhs$term %in% c("intercept", "drift")]
if (length(lhs_intercept) > 0) {
# An intercept or drift term exists for the ARIMA section.
lhs_intercept <- paste0("(y_{t} ", lhs_intercept, ")")
} else {
lhs_intercept <- "y_{t}"
}
lhs_parse <- list(
"ar" = lhs$final_terms[grepl("^ar", lhs$term)],
"sar" = lhs$final_terms[grepl("^sar", lhs$term)],
"diffs" = lhs$final_terms[lhs$term %in% c("zz_differencing", "zz_seas_Differencing")],
"error" = if (regression) "\\eta_{t}" else lhs_intercept
)
lhs_parse <- lhs_parse[lengths(lhs_parse) > 0L]
lhs_final <- Map(function(x, y) parsing_functions[x][[1]](y), names(lhs_parse), lhs_parse)
## Parse the RHS
rhs_parse <- list(
"ma" = rhs$final_terms[grepl("^ma", rhs$term)],
"sma" = rhs$final_terms[grepl("^sma", rhs$term)],
"diffs" = rhs$final_terms[rhs$term == "zz_seas_Differencing"],
"error" = "\\varepsilon_{t}"
)
rhs_parse <- rhs_parse[lengths(rhs_parse) > 0L]
rhs_final <- Map(function(x, y) parsing_functions[x][[1]](y), names(rhs_parse), rhs_parse)
## Output the ARIMA equation segments.
arima_eq <- list(
lhs = list(unlist(lhs_final)),
rhs = list(unlist(rhs_final))
)
# If this is a linear model, also parse yt
# Note that this is the same set of operations as earlier, but only with yt
if (regression) {
# Convert sides into LATEX-like terms
yt$final_terms <- create_term(yt, ital_vars, swap_var_names,
swap_subscript_names)
# Combine coefs or greek letters with the terms
if (use_coefs) {
yt$final_terms <- add_coefs(yt, yt$final_terms, coef_digits, side_sign = 1)
} else {
yt$final_terms <- add_greek(yt, yt$final_terms, regression, raw_tex, side_sign = 1)
}
# Output the LM equation segments
lm_eq <- list(
lhs = list("y_{t}"),
rhs = list(c(yt$final_terms, "+\\eta_{t}"))
)
# Prep for final output
eq_list <- list(
lm_eq = lm_eq,
arima_eq = arima_eq
)
} else {
# No regression model
# Prep for final output
eq_list <- list(arima_eq = arima_eq)
}
# Explicit return
return(eq_list)
}
create_term <- function(side, ...) {
UseMethod("create_term", side)
}
#' @noRd
create_term.default <- function(side, ital_vars, swap_var_names,
swap_subscript_names, var_colors,
var_subscript_colors, ...) {
check_dots(...)
side$primary <- lapply(side$primary, function(x) {
names(x) <- x
x
})
subscript_nms <- Map(function(.x, .y) {
names(.x) <- .y
.x
},
.x = side$subscripts,
.y = side$primary
)
if (!is.null(swap_var_names)) {
side$primary <- swap_names(swap_var_names, side$primary)
}
if (!is.null(swap_subscript_names)) {
side$subscripts <- swap_names(swap_subscript_names, side$subscripts)
side$subscripts <- Map(function(.x, .y) {
names(.x) <- names(.y)
.x
},
.x = side$subscripts,
.y = subscript_nms
)
}
prim_escaped <- lapply(side$primary, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
prim_escaped <- add_math(prim_escaped, side$subscripts)
prim <- lapply(prim_escaped, add_tex_ital_v, ital_vars)
if (!is.null(var_colors)) {
prim <- colorize_terms(var_colors, side$primary, prim)
}
drop_subscripts <- vapply(side$primary,
function(x) any(grepl("poly|<|>", x)),
FUN.VALUE = logical(1))
subs <- ifelse(drop_subscripts, "", side$subscripts)
subs_escaped <- lapply(subs, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
subs <- lapply(subs_escaped, add_tex_ital_v, ital_vars)
subs <- lapply(subs, add_tex_subscripts_v)
if (!is.null(var_subscript_colors)) {
subs <- Map(function(.x, .y) {
names(.x) <- names(.y)
.x
},
.x = subs,
.y = subscript_nms
)
subs <- colorize_terms(var_subscript_colors, side$primary, subs)
}
final <- Map(paste0, prim, subs)
vapply(final, add_tex_mult, FUN.VALUE = character(1))
}
# swap out log, exp
add_math <- function(primary, subscripts) {
Map(check_math, primary, subscripts)
}
check_math <- function(primary, subscripts) {
checks <- c("log", "exp", "poly\\((.+),.+", "I\\((.+)\\)")
replacements <- c("\\\\log", "\\\\exp", paste0("\\1^", subscripts), "\\1")
for(i in seq_along(checks)) {
primary <- gsub(checks[i], replacements[i], primary)
}
gsub("\\^1$", "", primary)
}
#' Create a full term w/subscripts
#'
#' @keywords internal
#'
#' @param side A data frame of right-hand side variables extracted with
#' \code{extract_rhs} or \code{extract_rhs} or \code{helper_arima_extract_lm}.
#'
#' @inheritParams extract_eq
#' @noRd
create_term.forecast_ARIMA <- function(side, ital_vars, swap_var_names,
swap_subscript_names, ...) {
check_dots(...)
if (!is.null(swap_var_names)) {
side$primary <- swap_names(swap_var_names, side$primary)
}
if (!is.null(swap_subscript_names)) {
side$subscripts <- swap_names(swap_subscript_names, side$subscripts)
}
# Get and format the primaries
# Do not escape seasonal differecing primary
prim_escaped <- lapply(side$primary, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
term_check <- side$term %in% c("zz_differencing", "zz_seas_Differencing")
prim_escaped[term_check] <- side[term_check, "primary"]
prim <- lapply(prim_escaped, add_tex_ital_v, ital_vars)
if (!ital_vars) {
# We don"t want (1-B) inside \\operatorname
prim[term_check] <- gsub("B", "\\\\operatorname{B}", side$primary[term_check])
}
# Get and format the subscripts
subs_escaped <- lapply(side$subscripts, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
subs <- lapply(subs_escaped, add_tex_ital_v, ital_vars)
subs <- lapply(subs, add_tex_subscripts_v)
# Get and format the superscripts
supers_escaped <- lapply(side$superscript, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
supers <- lapply(supers_escaped, add_tex_ital_v, ital_vars)
supers <- lapply(supers, add_tex_superscripts_v)
# Combine operators
final <- Map(paste0, prim, subs, supers)
# Add any multiplication for interaction terms
final <- vapply(final, add_tex_mult, FUN.VALUE = character(1))
# Explicit return
return(final)
}
#' Swap out variable names for more human readable forms
#' @param name_vector A vector of the form c("old_var_name" = "new name"). For
#' example: c("bill_length_mm" = "Bill Length (MM)")
#' @param primary The primary column from \code{rhs}
#' @noRd
swap_names <- function(name_vector, primary) {
missing <- setdiff(unique(unlist(primary)), names(name_vector))
names(missing) <- missing
full_name_vector <- c(name_vector, missing)
lapply(primary, function(x) {
full_name_vector[match(x, names(full_name_vector))]
})
}
#' Escape TeX
#'
#' Escape special TeX characters.
#'
#' Ten characters have special meaning in TeX \code{& \% $ # _ { } ~ ^ \\}.
#' This function either escapes them with \\, or in the case of the last three,
#' replaces them with special TeX macros.
#'
#' @keywords internal
#'
#' @param term A character string to escape
#'
#' @return A character string
#' @noRd
escape_tex <- function(term) {
unescaped <- c(" ", "&", "%", "$", "#", "_", "{", "}", "~", "^", "\\")
hat <- ifelse(is_html_output(), "\\texttt{^}", "\\texttt{\\^{}}")
escaped <- c(
"\\ ", "\\&", "\\%", "\\$", "\\#", "\\_", "\\{", "\\}",
"\\char`\\~", hat, "\\backslash "
)
# Split term into a vector of single characters
characters <- strsplit(term, "")[[1]]
# Go through term and replace all unescaped characters with their escaped versions
replaced <- vapply(characters,
function(x) {
ifelse(x %in% unescaped,
escaped[which(x == unescaped)],
x
)
},
FUN.VALUE = character(1)
)
# Return the reassembled term
paste0(replaced, collapse = "")
}
#' Wrap text in \code{\\operatorname{}}
#'
#' Add tex code to make string not italicized within an equation
#'
#' @keywords internal
#'
#' @param term A character to wrap in \code{\\operatorname{}}
#' @param ital_vars Passed from \code{extract_eq}
#'
#' @return A character string
#' @noRd
add_tex_ital <- function(term, ital_vars) {
if (any(nchar(term) == 0, ital_vars)) {
return(term)
}
paste0("\\operatorname{", term, "}")
}
#' Wrap text in \code{\\operatorname{}} (vectorized)
#'
#' Add tex code to make string not italicized within an equation for a vector
#' of strings
#'
#' @keywords internal
#'
#' @return A vector of characters
#' @noRd
add_tex_ital_v <- function(term_v, ital_vars) {
vapply(term_v, add_tex_ital, ital_vars, FUN.VALUE = character(1))
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a single string
#'
#' @keywords internal
#'
#' @param term A character string to TeXify
#'
#' @return A character string
#' @noRd
add_tex_subscripts <- function(term) {
if (any(nchar(term) == 0)) {
return(term)
}
paste0("_{", term, "}")
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a vector of strings
#'
#' @keywords internal
#'
#' @return A vector of characters
#' @noRd
add_tex_subscripts_v <- function(term_v) {
vapply(term_v, add_tex_subscripts, FUN.VALUE = character(1))
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a single string
#'
#' @keywords internal
#'
#' @param term A character string to TeXify
#'
#' @return A character string
#' @noRd
add_tex_superscripts <- function(term) {
if (any(nchar(term) == 0)) {
return(term)
}
paste0("^{", term, "}")
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a vector of strings
#'
#' @keywords internal
#'
#' @return A vector of characters
#' @noRd
add_tex_superscripts_v <- function(term_v) {
vapply(term_v, add_tex_superscripts, FUN.VALUE = character(1))
}
#' Add multiplication symbol for interaction terms
#'
#' @keywords internal
#' @noRd
add_tex_mult <- function(term) {
paste(term, collapse = " \\times ")
}
#' Add a hat sign to the response variable in lm
#'
#' @keywords internal
#' @noRd
add_hat <- function(term) {
paste0("\\widehat{", term, "}")
}
add_coefs <- function(rhs, ...) {
UseMethod("add_coefs", rhs)
}
#' Add coefficient values to the equation
#'
#' @keywords internal
#' @noRd
add_coefs.default <- function(rhs, term, coef_digits, ...) {
check_dots(...)
ests <- round(rhs$estimate, coef_digits)
ifelse(
rhs$term == "(Intercept)",
paste0(ests, term),
paste0(ests, "(", term, ")")
)
}
#' @keywords internal
#' @noRd
add_coefs.polr <- function(rhs, term, coef_digits, ...) {
check_dots(...)
ests <- round(rhs$estimate, coef_digits)
ifelse(
rhs$coef.type == "scale",
paste0(ests, term),
paste0(ests, "(", term, ")")
)
}
#' @keywords internal
#' @noRd
add_coefs.clm <- function(rhs, term, coef_digits, ...) {
check_dots(...)
ests <- round(rhs$estimate, coef_digits)
ifelse(
rhs$coef.type == "intercept",
paste0(ests, term),
paste0(ests, "(", term, ")")
)
}
#' Add coefficient values for forecast::Arima
#'
#' @keywords internal
#' @noRd
add_coefs.forecast_ARIMA <- function(rhs, term, coef_digits, side_sign = 1, ...) {
check_dots(...)
# Round the estimates and turn to a character vector
ests <- round(rhs$estimate, coef_digits)
# Use signif on anything where the round returns a zero
ests[ests == 0 & !is.na(ests)] <- signif(rhs$estimate[ests == 0 & !is.na(ests)], 1)
# Deal with signs
## Flip sign if needed
ests <- ests * side_sign
## Setup for positive signs. Negative signs come automatically.
signs <- ifelse(ests > 0, "+", "")
# Deal with NAs
signs[is.na(ests)] <- ""
ests[is.na(ests)] <- ""
# Combine final terms and the coeficients
final_terms <- paste0(signs, ests, term)
# Explicit return
return(final_terms)
}
add_greek <- function(rhs, ...) {
UseMethod("add_greek", rhs)
}
#' Adds greek symbols to the equation
#'
#' @keywords internal
#' @noRd
add_greek.default <- function(rhs, terms, greek = "beta", intercept = "alpha",
greek_colors, subscript_colors,
raw_tex = FALSE, ...) {
check_dots(...)
int <- switch(intercept,
"alpha" = "\\alpha",
"beta" = "\\beta_{0}"
)
if (raw_tex & !(intercept %in% c("alpha", "beta"))) {
int <- intercept
}
indices <- if ("(Intercept)" %in% rhs$term) {
seq_len(nrow(rhs)) - 1
} else {
seq_len(nrow(rhs))
}
ifelse(rhs$term == "(Intercept)",
colorize(greek_colors[1], int),
anno_greek(
greek,
indices,
terms,
greek_colors,
subscript_colors,
raw_tex
)
)
}
#' @keywords internal
#' @noRd
add_greek.polr <- function(rhs, terms, greek, intercept, greek_colors,
subscript_colors, raw_tex, ...) {
rhs$idx <- unlist(lapply(split(rhs, rhs$coef.type), function(x) {
seq_along(x$coef.type)
}))
ifelse(
rhs$coef.type == "scale",
anno_greek(
"alpha",
rhs$idx,
greek_colors = greek_colors[1],
subscript_colors = subscript_colors[1]
),
anno_greek(
"beta",
rhs$idx,
terms,
greek_colors = greek_colors[-1],
subscript_colors = subscript_colors[-1]
)
)
}
#' @keywords internal
#' @noRd
add_greek.clm <- function(rhs, terms, greek, intercept, greek_colors,
subscript_colors, raw_tex, ...) {
rhs$idx <- unlist(lapply(split(rhs, rhs$coef.type), function(x) {
seq_along(x$coef.type)
}))
ifelse(
rhs$coef.type == "intercept",
anno_greek(
"alpha",
rhs$idx,
greek_colors = greek_colors[1],
subscript_colors = subscript_colors[1]
),
anno_greek(
"beta",
rhs$idx,
terms,
greek_colors = greek_colors[-1],
subscript_colors = subscript_colors[-1]
)
)
}
#' Add greek placeholders for forecast::Arima
#'
#' @keywords internal
#' @noRd
add_greek.forecast_ARIMA <- function(rhs, terms, regression, raw_tex = FALSE, side_sign = 1, ...) {
# These are the greek letters we need to use in REGEX
# Others will be assigned manually
greek_letters <- c(
"^ar" = "phi",
"^sar" = "Phi",
"^ma" = "theta",
"^sma" = "Theta",
"^intercept$" = "mu",
"^drift$" = "delta"
)
# We are going to use lapply to walk and change things for us.
# Note the <<-. This affects something outside the function.
# This is just a fancy for loop.
greek <- rep("", nrow(rhs))
invisible(
lapply(names(greek_letters), function(x) {
greek[grepl(x, rhs$term)] <<- greek_letters[x]
})
)
# To make life easier, we are including the greek parsing for
# the linear component here too.
if (sum(grepl("^s?ar|^s?ma", rhs$term)) == 0) {
# Then we are dealing with the linear component and not the ARIMA component
# Beta will serve as the main letter for the linear component
# Anything in greek that is blank, wasn"t accounted for with known paramters.
greek[greek == "" & rhs$term != "y0"] <- "beta"
# Generate the subs for the greek letters
## Initialize the vector
subs <- rep("", nrow(rhs))
## Give numbers to non-constants
int_drift_y0 <- !(rhs$term %in% c("intercept", "drift", "y0"))
subs[int_drift_y0] <- as.character(1:sum(int_drift_y0))
} else {
# Deal with ARIMA component
# Format the greek letters to vibe with the final_terms
# This is done, in part, with anno_greek for other functions.
subs <- rep("", nrow(rhs))
subs[grepl("^s?ar|^s?ma", rhs$term)] <- gsub("^s?ar|^s?ma", "", rhs$term[grepl("^s?ar|^s?ma", rhs$term)])
}
# Add subscripts to greek
greek[subs != ""] <- paste0(greek[subs != ""], "_{", subs[subs != ""], "}")
# Finalize greek based on raw_tex
if (!raw_tex) {
greek[greek != ""] <- paste0("\\", greek[greek != ""])
}
# Deal with signs on greek letters
signs <- rep("", length(greek))
signs[!(rhs$term %in% c("zz_differencing", "zz_seas_Differencing"))] <- if (side_sign > 0) "+" else "-"
# Combine the final terms with the greek letters
final_terms <- paste0(signs, greek, terms)
# Explicit return
return(final_terms)
}
#' Intermediary function to wrap text in `\\beta_{}`
#'
#' @keywords internal
#' @noRd
anno_greek <- function(greek, nums, terms = NULL,
greek_colors = NULL, subscript_colors = NULL,
raw_tex = FALSE) {
if (raw_tex) {
out <- paste0(greek, "_{", nums, "}")
} else {
coefs <- colorize(greek_colors, paste0("\\", greek))
subscripts <- colorize(subscript_colors, nums)
out <- paste0(coefs, "_{", subscripts, "}")
}
if (!is.null(terms)) {
out <- paste0(out, "(", terms, ")")
}
out
}
#' Deduplicate operators
#'
#' Convert "+ -" to "-"
#'
#' @keywords internal
#'
#' @param eq String containing a LaTeX equation
#' @noRd
fix_coef_signs <- function(eq) {
# Side-by-side + -
eq_clean <- gsub("\\+ -", "- ", eq)
# + - that spans lines
eq_clean <- gsub(
"\\+ \\\\\\\\\\n&\\\\quad -",
"- \\\\\\\\\n&\\\\quad ",
eq_clean
)
eq_clean
}
Try the equatiomatic package in your browser
Any scripts or data that you put into this service are public.
equatiomatic documentation built on May 29, 2024, 1:19 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions fix_coef_signs anno_greek add_greek.forecast_ARIMA add_greek.clm add_greek.polr add_greek.default add_greek add_coefs.forecast_ARIMA add_coefs.clm add_coefs.polr add_coefs.default add_coefs add_hat add_tex_mult add_tex_superscripts_v add_tex_superscripts add_tex_subscripts_v add_tex_subscripts add_tex_ital_v add_tex_ital escape_tex swap_names create_term.forecast_ARIMA check_math add_math create_term.default create_term create_eq.forecast_ARIMA create_eq.clm create_eq.polr create_eq.glm create_eq.default create_eq
create_eq <- function(model, lhs, ...) {
UseMethod("create_eq", model)
}
#' Create the full equation
#'
#' @keywords internal
#'
#' @param lhs A character string of the left-hand side variable extracted with
#' \code{extract_lhs}
#' @param rhs A data frame of right-hand side variables extracted with
#' \code{extract_rhs}.
#'
#' @inheritParams extract_eq
#' @noRd
create_eq.default <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors, swap_var_names,
swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars,
swap_var_names, swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors,
raw_tex)
}
# Add error row or not in lm
if (!use_coefs) {
error_row <- rhs[nrow(rhs) + 1, ]
error_row$term <- "error"
error_row$final_terms <- "\\epsilon"
error_row$final_terms <- colorize(
greek_colors[length(greek_colors)],
error_row$final_terms
)
rhs <- rbind(rhs, error_row)
}
list(lhs = list(lhs), rhs = list(rhs$final_terms))
}
#' @noRd
#' @inheritParams extract_eq
create_eq.glm <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors,
swap_var_names, swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors, raw_tex)
}
if (!is.null(model$offset)) {
rhs <- rbind(rhs, c(
rep(NA, (dim(rhs)[2] - 1)),
add_tex_ital(tail(names(attr(model$terms, "dataClasses")), 1), ital_vars)
))
}
list(lhs = list(lhs), rhs = list(rhs$final_terms))
}
#' @noRd
create_eq.polr <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors,
swap_var_names, swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors, raw_tex)
}
splt <- split(rhs, rhs$coef.type)
rhs_final <- lapply(splt$scale$final_terms, function(x) {
c(x, splt$coefficient$final_terms)
})
attributes(lhs) <- NULL
list(lhs = lhs, rhs = rhs_final)
}
#' @noRd
create_eq.clm <- function(model, lhs, rhs, ital_vars, use_coefs, coef_digits,
fix_signs, intercept, greek,
greek_colors, subscript_colors,
var_colors, var_subscript_colors,
raw_tex, index_factors,
swap_var_names, swap_subscript_names, ...) {
check_dots(...)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names,
var_colors, var_subscript_colors)
if (use_coefs) {
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits)
} else if (index_factors) {
rhs$final_terms <- ifelse(
grepl("\\\\times", rhs$final_terms),
paste0("\\left(", rhs$final_terms, "\\right)"),
rhs$final_terms
)
rhs$final_terms <- ifelse(
rhs$final_terms == "",
"\\alpha",
rhs$final_terms
)
} else {
rhs$final_terms <- add_greek(rhs, rhs$final_terms, greek, intercept,
greek_colors, subscript_colors, raw_tex)
}
splt <- split(rhs, rhs$coef.type)
rhs_final <- lapply(splt$intercept$final_terms, function(x) {
c(x, splt$location$final_terms)
})
attributes(lhs) <- NULL
list(lhs = lhs, rhs = rhs_final)
}
#' Create equations from forecast::Arima object
#'
#' @keywords internal
#'
#' @param lhs A data frame of right-hand side variables extracted with
#' \code{extract_lhs}
#' @param rhs A data frame of right-hand side variables extracted with
#' \code{extract_rhs}.
#' @param yt A data frame of regression variables extracted with
#' \code{helper_arima_extract_lm}.
#'
#' @return A dataframe
#' @noRd
create_eq.forecast_ARIMA <- function(model, lhs, rhs, yt, ital_vars, use_coefs,
coef_digits, raw_tex, swap_var_names,
swap_subscript_names, ...) {
# Determine if we are working on Regression w/ Arima Errors
regression <- helper_arima_is_regression(model)
# Convert sides into LATEX-like terms
lhs$final_terms <- create_term(lhs, ital_vars, swap_var_names,
swap_subscript_names)
rhs$final_terms <- create_term(rhs, ital_vars, swap_var_names,
swap_subscript_names)
# Combine coefs or greek letters with the terms
if (use_coefs) {
lhs$final_terms <- add_coefs(lhs, lhs$final_terms, coef_digits, side_sign = -1)
rhs$final_terms <- add_coefs(rhs, rhs$final_terms, coef_digits, side_sign = 1)
} else {
lhs$final_terms <- add_greek(lhs, lhs$final_terms, regression, raw_tex, side_sign = -1)
rhs$final_terms <- add_greek(rhs, rhs$final_terms, regression, raw_tex, side_sign = 1)
}
# Convert the final terms into proper Backshift notation for L/RHS
## Setup the parsing functions
parsing_functions <- list(
"ar" = function(x) paste("(1", paste0(x, collapse = " "), ")\\"),
"diffs" = function(x) paste(x, collapse = "\\ "),
"error" = function(x) x
)
parsing_functions["sar"] <- parsing_functions["ar"]
parsing_functions["ma"] <- parsing_functions["ar"]
parsing_functions["sma"] <- parsing_functions["ar"]
## Parse the LHS
lhs_intercept <- lhs$final_terms[lhs$term %in% c("intercept", "drift")]
if (length(lhs_intercept) > 0) {
# An intercept or drift term exists for the ARIMA section.
lhs_intercept <- paste0("(y_{t} ", lhs_intercept, ")")
} else {
lhs_intercept <- "y_{t}"
}
lhs_parse <- list(
"ar" = lhs$final_terms[grepl("^ar", lhs$term)],
"sar" = lhs$final_terms[grepl("^sar", lhs$term)],
"diffs" = lhs$final_terms[lhs$term %in% c("zz_differencing", "zz_seas_Differencing")],
"error" = if (regression) "\\eta_{t}" else lhs_intercept
)
lhs_parse <- lhs_parse[lengths(lhs_parse) > 0L]
lhs_final <- Map(function(x, y) parsing_functions[x][[1]](y), names(lhs_parse), lhs_parse)
## Parse the RHS
rhs_parse <- list(
"ma" = rhs$final_terms[grepl("^ma", rhs$term)],
"sma" = rhs$final_terms[grepl("^sma", rhs$term)],
"diffs" = rhs$final_terms[rhs$term == "zz_seas_Differencing"],
"error" = "\\varepsilon_{t}"
)
rhs_parse <- rhs_parse[lengths(rhs_parse) > 0L]
rhs_final <- Map(function(x, y) parsing_functions[x][[1]](y), names(rhs_parse), rhs_parse)
## Output the ARIMA equation segments.
arima_eq <- list(
lhs = list(unlist(lhs_final)),
rhs = list(unlist(rhs_final))
)
# If this is a linear model, also parse yt
# Note that this is the same set of operations as earlier, but only with yt
if (regression) {
# Convert sides into LATEX-like terms
yt$final_terms <- create_term(yt, ital_vars, swap_var_names,
swap_subscript_names)
# Combine coefs or greek letters with the terms
if (use_coefs) {
yt$final_terms <- add_coefs(yt, yt$final_terms, coef_digits, side_sign = 1)
} else {
yt$final_terms <- add_greek(yt, yt$final_terms, regression, raw_tex, side_sign = 1)
}
# Output the LM equation segments
lm_eq <- list(
lhs = list("y_{t}"),
rhs = list(c(yt$final_terms, "+\\eta_{t}"))
)
# Prep for final output
eq_list <- list(
lm_eq = lm_eq,
arima_eq = arima_eq
)
} else {
# No regression model
# Prep for final output
eq_list <- list(arima_eq = arima_eq)
}
# Explicit return
return(eq_list)
}
create_term <- function(side, ...) {
UseMethod("create_term", side)
}
#' @noRd
create_term.default <- function(side, ital_vars, swap_var_names,
swap_subscript_names, var_colors,
var_subscript_colors, ...) {
check_dots(...)
side$primary <- lapply(side$primary, function(x) {
names(x) <- x
x
})
subscript_nms <- Map(function(.x, .y) {
names(.x) <- .y
.x
},
.x = side$subscripts,
.y = side$primary
)
if (!is.null(swap_var_names)) {
side$primary <- swap_names(swap_var_names, side$primary)
}
if (!is.null(swap_subscript_names)) {
side$subscripts <- swap_names(swap_subscript_names, side$subscripts)
side$subscripts <- Map(function(.x, .y) {
names(.x) <- names(.y)
.x
},
.x = side$subscripts,
.y = subscript_nms
)
}
prim_escaped <- lapply(side$primary, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
prim_escaped <- add_math(prim_escaped, side$subscripts)
prim <- lapply(prim_escaped, add_tex_ital_v, ital_vars)
if (!is.null(var_colors)) {
prim <- colorize_terms(var_colors, side$primary, prim)
}
drop_subscripts <- vapply(side$primary,
function(x) any(grepl("poly|<|>", x)),
FUN.VALUE = logical(1))
subs <- ifelse(drop_subscripts, "", side$subscripts)
subs_escaped <- lapply(subs, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
subs <- lapply(subs_escaped, add_tex_ital_v, ital_vars)
subs <- lapply(subs, add_tex_subscripts_v)
if (!is.null(var_subscript_colors)) {
subs <- Map(function(.x, .y) {
names(.x) <- names(.y)
.x
},
.x = subs,
.y = subscript_nms
)
subs <- colorize_terms(var_subscript_colors, side$primary, subs)
}
final <- Map(paste0, prim, subs)
vapply(final, add_tex_mult, FUN.VALUE = character(1))
}
# swap out log, exp
add_math <- function(primary, subscripts) {
Map(check_math, primary, subscripts)
}
check_math <- function(primary, subscripts) {
checks <- c("log", "exp", "poly\\((.+),.+", "I\\((.+)\\)")
replacements <- c("\\\\log", "\\\\exp", paste0("\\1^", subscripts), "\\1")
for(i in seq_along(checks)) {
primary <- gsub(checks[i], replacements[i], primary)
}
gsub("\\^1$", "", primary)
}
#' Create a full term w/subscripts
#'
#' @keywords internal
#'
#' @param side A data frame of right-hand side variables extracted with
#' \code{extract_rhs} or \code{extract_rhs} or \code{helper_arima_extract_lm}.
#'
#' @inheritParams extract_eq
#' @noRd
create_term.forecast_ARIMA <- function(side, ital_vars, swap_var_names,
swap_subscript_names, ...) {
check_dots(...)
if (!is.null(swap_var_names)) {
side$primary <- swap_names(swap_var_names, side$primary)
}
if (!is.null(swap_subscript_names)) {
side$subscripts <- swap_names(swap_subscript_names, side$subscripts)
}
# Get and format the primaries
# Do not escape seasonal differecing primary
prim_escaped <- lapply(side$primary, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
term_check <- side$term %in% c("zz_differencing", "zz_seas_Differencing")
prim_escaped[term_check] <- side[term_check, "primary"]
prim <- lapply(prim_escaped, add_tex_ital_v, ital_vars)
if (!ital_vars) {
# We don"t want (1-B) inside \\operatorname
prim[term_check] <- gsub("B", "\\\\operatorname{B}", side$primary[term_check])
}
# Get and format the subscripts
subs_escaped <- lapply(side$subscripts, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
subs <- lapply(subs_escaped, add_tex_ital_v, ital_vars)
subs <- lapply(subs, add_tex_subscripts_v)
# Get and format the superscripts
supers_escaped <- lapply(side$superscript, function(x) {
vapply(x, escape_tex, FUN.VALUE = character(1))
})
supers <- lapply(supers_escaped, add_tex_ital_v, ital_vars)
supers <- lapply(supers, add_tex_superscripts_v)
# Combine operators
final <- Map(paste0, prim, subs, supers)
# Add any multiplication for interaction terms
final <- vapply(final, add_tex_mult, FUN.VALUE = character(1))
# Explicit return
return(final)
}
#' Swap out variable names for more human readable forms
#' @param name_vector A vector of the form c("old_var_name" = "new name"). For
#' example: c("bill_length_mm" = "Bill Length (MM)")
#' @param primary The primary column from \code{rhs}
#' @noRd
swap_names <- function(name_vector, primary) {
missing <- setdiff(unique(unlist(primary)), names(name_vector))
names(missing) <- missing
full_name_vector <- c(name_vector, missing)
lapply(primary, function(x) {
full_name_vector[match(x, names(full_name_vector))]
})
}
#' Escape TeX
#'
#' Escape special TeX characters.
#'
#' Ten characters have special meaning in TeX \code{& \% $ # _ { } ~ ^ \\}.
#' This function either escapes them with \\, or in the case of the last three,
#' replaces them with special TeX macros.
#'
#' @keywords internal
#'
#' @param term A character string to escape
#'
#' @return A character string
#' @noRd
escape_tex <- function(term) {
unescaped <- c(" ", "&", "%", "$", "#", "_", "{", "}", "~", "^", "\\")
hat <- ifelse(is_html_output(), "\\texttt{^}", "\\texttt{\\^{}}")
escaped <- c(
"\\ ", "\\&", "\\%", "\\$", "\\#", "\\_", "\\{", "\\}",
"\\char`\\~", hat, "\\backslash "
)
# Split term into a vector of single characters
characters <- strsplit(term, "")[[1]]
# Go through term and replace all unescaped characters with their escaped versions
replaced <- vapply(characters,
function(x) {
ifelse(x %in% unescaped,
escaped[which(x == unescaped)],
x
)
},
FUN.VALUE = character(1)
)
# Return the reassembled term
paste0(replaced, collapse = "")
}
#' Wrap text in \code{\\operatorname{}}
#'
#' Add tex code to make string not italicized within an equation
#'
#' @keywords internal
#'
#' @param term A character to wrap in \code{\\operatorname{}}
#' @param ital_vars Passed from \code{extract_eq}
#'
#' @return A character string
#' @noRd
add_tex_ital <- function(term, ital_vars) {
if (any(nchar(term) == 0, ital_vars)) {
return(term)
}
paste0("\\operatorname{", term, "}")
}
#' Wrap text in \code{\\operatorname{}} (vectorized)
#'
#' Add tex code to make string not italicized within an equation for a vector
#' of strings
#'
#' @keywords internal
#'
#' @return A vector of characters
#' @noRd
add_tex_ital_v <- function(term_v, ital_vars) {
vapply(term_v, add_tex_ital, ital_vars, FUN.VALUE = character(1))
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a single string
#'
#' @keywords internal
#'
#' @param term A character string to TeXify
#'
#' @return A character string
#' @noRd
add_tex_subscripts <- function(term) {
if (any(nchar(term) == 0)) {
return(term)
}
paste0("_{", term, "}")
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a vector of strings
#'
#' @keywords internal
#'
#' @return A vector of characters
#' @noRd
add_tex_subscripts_v <- function(term_v) {
vapply(term_v, add_tex_subscripts, FUN.VALUE = character(1))
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a single string
#'
#' @keywords internal
#'
#' @param term A character string to TeXify
#'
#' @return A character string
#' @noRd
add_tex_superscripts <- function(term) {
if (any(nchar(term) == 0)) {
return(term)
}
paste0("^{", term, "}")
}
#' Wrap text in \code{_{}}
#'
#' Add tex code to make subscripts for a vector of strings
#'
#' @keywords internal
#'
#' @return A vector of characters
#' @noRd
add_tex_superscripts_v <- function(term_v) {
vapply(term_v, add_tex_superscripts, FUN.VALUE = character(1))
}
#' Add multiplication symbol for interaction terms
#'
#' @keywords internal
#' @noRd
add_tex_mult <- function(term) {
paste(term, collapse = " \\times ")
}
#' Add a hat sign to the response variable in lm
#'
#' @keywords internal
#' @noRd
add_hat <- function(term) {
paste0("\\widehat{", term, "}")
}
add_coefs <- function(rhs, ...) {
UseMethod("add_coefs", rhs)
}
#' Add coefficient values to the equation
#'
#' @keywords internal
#' @noRd
add_coefs.default <- function(rhs, term, coef_digits, ...) {
check_dots(...)
ests <- round(rhs$estimate, coef_digits)
ifelse(
rhs$term == "(Intercept)",
paste0(ests, term),
paste0(ests, "(", term, ")")
)
}
#' @keywords internal
#' @noRd
add_coefs.polr <- function(rhs, term, coef_digits, ...) {
check_dots(...)
ests <- round(rhs$estimate, coef_digits)
ifelse(
rhs$coef.type == "scale",
paste0(ests, term),
paste0(ests, "(", term, ")")
)
}
#' @keywords internal
#' @noRd
add_coefs.clm <- function(rhs, term, coef_digits, ...) {
check_dots(...)
ests <- round(rhs$estimate, coef_digits)
ifelse(
rhs$coef.type == "intercept",
paste0(ests, term),
paste0(ests, "(", term, ")")
)
}
#' Add coefficient values for forecast::Arima
#'
#' @keywords internal
#' @noRd
add_coefs.forecast_ARIMA <- function(rhs, term, coef_digits, side_sign = 1, ...) {
check_dots(...)
# Round the estimates and turn to a character vector
ests <- round(rhs$estimate, coef_digits)
# Use signif on anything where the round returns a zero
ests[ests == 0 & !is.na(ests)] <- signif(rhs$estimate[ests == 0 & !is.na(ests)], 1)
# Deal with signs
## Flip sign if needed
ests <- ests * side_sign
## Setup for positive signs. Negative signs come automatically.
signs <- ifelse(ests > 0, "+", "")
# Deal with NAs
signs[is.na(ests)] <- ""
ests[is.na(ests)] <- ""
# Combine final terms and the coeficients
final_terms <- paste0(signs, ests, term)
# Explicit return
return(final_terms)
}
add_greek <- function(rhs, ...) {
UseMethod("add_greek", rhs)
}
#' Adds greek symbols to the equation
#'
#' @keywords internal
#' @noRd
add_greek.default <- function(rhs, terms, greek = "beta", intercept = "alpha",
greek_colors, subscript_colors,
raw_tex = FALSE, ...) {
check_dots(...)
int <- switch(intercept,
"alpha" = "\\alpha",
"beta" = "\\beta_{0}"
)
if (raw_tex & !(intercept %in% c("alpha", "beta"))) {
int <- intercept
}
indices <- if ("(Intercept)" %in% rhs$term) {
seq_len(nrow(rhs)) - 1
} else {
seq_len(nrow(rhs))
}
ifelse(rhs$term == "(Intercept)",
colorize(greek_colors[1], int),
anno_greek(
greek,
indices,
terms,
greek_colors,
subscript_colors,
raw_tex
)
)
}
#' @keywords internal
#' @noRd
add_greek.polr <- function(rhs, terms, greek, intercept, greek_colors,
subscript_colors, raw_tex, ...) {
rhs$idx <- unlist(lapply(split(rhs, rhs$coef.type), function(x) {
seq_along(x$coef.type)
}))
ifelse(
rhs$coef.type == "scale",
anno_greek(
"alpha",
rhs$idx,
greek_colors = greek_colors[1],
subscript_colors = subscript_colors[1]
),
anno_greek(
"beta",
rhs$idx,
terms,
greek_colors = greek_colors[-1],
subscript_colors = subscript_colors[-1]
)
)
}
#' @keywords internal
#' @noRd
add_greek.clm <- function(rhs, terms, greek, intercept, greek_colors,
subscript_colors, raw_tex, ...) {
rhs$idx <- unlist(lapply(split(rhs, rhs$coef.type), function(x) {
seq_along(x$coef.type)
}))
ifelse(
rhs$coef.type == "intercept",
anno_greek(
"alpha",
rhs$idx,
greek_colors = greek_colors[1],
subscript_colors = subscript_colors[1]
),
anno_greek(
"beta",
rhs$idx,
terms,
greek_colors = greek_colors[-1],
subscript_colors = subscript_colors[-1]
)
)
}
#' Add greek placeholders for forecast::Arima
#'
#' @keywords internal
#' @noRd
add_greek.forecast_ARIMA <- function(rhs, terms, regression, raw_tex = FALSE, side_sign = 1, ...) {
# These are the greek letters we need to use in REGEX
# Others will be assigned manually
greek_letters <- c(
"^ar" = "phi",
"^sar" = "Phi",
"^ma" = "theta",
"^sma" = "Theta",
"^intercept$" = "mu",
"^drift$" = "delta"
)
# We are going to use lapply to walk and change things for us.
# Note the <<-. This affects something outside the function.
# This is just a fancy for loop.
greek <- rep("", nrow(rhs))
invisible(
lapply(names(greek_letters), function(x) {
greek[grepl(x, rhs$term)] <<- greek_letters[x]
})
)
# To make life easier, we are including the greek parsing for
# the linear component here too.
if (sum(grepl("^s?ar|^s?ma", rhs$term)) == 0) {
# Then we are dealing with the linear component and not the ARIMA component
# Beta will serve as the main letter for the linear component
# Anything in greek that is blank, wasn"t accounted for with known paramters.
greek[greek == "" & rhs$term != "y0"] <- "beta"
# Generate the subs for the greek letters
## Initialize the vector
subs <- rep("", nrow(rhs))
## Give numbers to non-constants
int_drift_y0 <- !(rhs$term %in% c("intercept", "drift", "y0"))
subs[int_drift_y0] <- as.character(1:sum(int_drift_y0))
} else {
# Deal with ARIMA component
# Format the greek letters to vibe with the final_terms
# This is done, in part, with anno_greek for other functions.
subs <- rep("", nrow(rhs))
subs[grepl("^s?ar|^s?ma", rhs$term)] <- gsub("^s?ar|^s?ma", "", rhs$term[grepl("^s?ar|^s?ma", rhs$term)])
}
# Add subscripts to greek
greek[subs != ""] <- paste0(greek[subs != ""], "_{", subs[subs != ""], "}")
# Finalize greek based on raw_tex
if (!raw_tex) {
greek[greek != ""] <- paste0("\\", greek[greek != ""])
}
# Deal with signs on greek letters
signs <- rep("", length(greek))
signs[!(rhs$term %in% c("zz_differencing", "zz_seas_Differencing"))] <- if (side_sign > 0) "+" else "-"
# Combine the final terms with the greek letters
final_terms <- paste0(signs, greek, terms)
# Explicit return
return(final_terms)
}
#' Intermediary function to wrap text in `\\beta_{}`
#'
#' @keywords internal
#' @noRd
anno_greek <- function(greek, nums, terms = NULL,
greek_colors = NULL, subscript_colors = NULL,
raw_tex = FALSE) {
if (raw_tex) {
out <- paste0(greek, "_{", nums, "}")
} else {
coefs <- colorize(greek_colors, paste0("\\", greek))
subscripts <- colorize(subscript_colors, nums)
out <- paste0(coefs, "_{", subscripts, "}")
}
if (!is.null(terms)) {
out <- paste0(out, "(", terms, ")")
}
out
}
#' Deduplicate operators
#'
#' Convert "+ -" to "-"
#'
#' @keywords internal
#'
#' @param eq String containing a LaTeX equation
#' @noRd
fix_coef_signs <- function(eq) {
# Side-by-side + -
eq_clean <- gsub("\\+ -", "- ", eq)
# + - that spans lines
eq_clean <- gsub(
"\\+ \\\\\\\\\\n&\\\\quad -",
"- \\\\\\\\\n&\\\\quad ",
eq_clean
)
eq_clean
}
Try the equatiomatic package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.