diff --git a/DESCRIPTION b/DESCRIPTION index f718bed..a0ea04a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: nlmixr2extra Title: Nonlinear Mixed Effects Models in Population PK/PD, Extra Support Functions -Version: 2.0.8 +Version: 2.0.8.9000 Authors@R: c( person("Matthew", "Fidler", email="matthew.fidler@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0001-8538-6691")), @@ -31,9 +31,11 @@ Imports: crayon, data.table, digest, + equatiomatic, ggplot2, ggtext, lotri, + methods, nlme, nlmixr2est (>= 2.1.1), Rcpp, @@ -43,6 +45,7 @@ Imports: utils Suggests: brms, + knitr, nlmixr2data, testthat (>= 3.0.0), withr, diff --git a/NAMESPACE b/NAMESPACE index 715038e..e013be9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,8 @@ # Generated by roxygen2: do not edit by hand S3method(bootplot,nlmixr2FitCore) +S3method(extract_eq,nlmixr2FitCore) +S3method(extract_eq,rxUi) S3method(print,nlmixr2BoostrapSummary) export(adaptivelassoCoefficients) export(addCatCovariates) @@ -12,6 +14,7 @@ export(bootstrapFit) export(buildcovInfo) export(buildupatedUI) export(covarSearchAuto) +export(extract_eq) export(foldgen) export(forwardSearch) export(horseshoeSummardf) @@ -29,6 +32,7 @@ export(regularmodel) import(lotri) import(utils) importFrom(Rcpp,evalCpp) +importFrom(equatiomatic,extract_eq) importFrom(ggplot2,.data) importFrom(nlmixr2est,nlmixr) importFrom(nlmixr2est,nlmixr2) diff --git a/NEWS.md b/NEWS.md index 0f3dcb2..67d7327 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# nlmixr2extra 2.0.9 + +* New function `extract_eq()` will generate model equations for LaTeX reporting + automatically. + # nlmixr2extra 2.0.8 * Use `assignInMyNamespace()` instead of using the global assignment diff --git a/R/extract_eq.R b/R/extract_eq.R new file mode 100644 index 0000000..a0398a3 --- /dev/null +++ b/R/extract_eq.R @@ -0,0 +1,462 @@ +#' @importFrom equatiomatic extract_eq +#' @export +equatiomatic::extract_eq + +#' Extract the equations from an nlmixr2/rxode2 model to produce a 'LaTeX' +#' equation. +#' +#' @param model The model to extract equations from +#' @param intercept,greek,greek_colors,subscript_colors,var_colors,var_subscript_colors,raw_tex,swap_var_names,swap_subscript_names,ital_vars,label,index_factors,show_distribution,wrap,terms_per_line,operator_location,align_env,use_coefs,coef_digits,fix_signs,font_size,mean_separate,return_variances,se_subscripts Ignored +#' @export +extract_eq.nlmixr2FitCore <- function(model, intercept = "alpha", greek = "beta", + greek_colors = NULL, subscript_colors = NULL, + var_colors = NULL, var_subscript_colors = NULL, + raw_tex = FALSE, + swap_var_names = NULL, swap_subscript_names = NULL, + ital_vars = FALSE, label = NULL, + index_factors = FALSE, show_distribution = FALSE, + wrap = FALSE, terms_per_line = 4, + operator_location = "end", align_env = "aligned", + use_coefs = FALSE, coef_digits = 2, + fix_signs = TRUE, font_size = NULL, + mean_separate, return_variances = FALSE, + se_subscripts = FALSE, ...) { + stopifnot(identical(intercept, "alpha")) + stopifnot(identical(greek, "beta")) + stopifnot(is.null(greek_colors)) + stopifnot(is.null(subscript_colors)) + stopifnot(is.null(var_colors)) + stopifnot(is.null(var_subscript_colors)) + stopifnot(identical(raw_tex, FALSE)) + stopifnot(is.null(swap_var_names)) + stopifnot(is.null(swap_subscript_names)) + stopifnot(identical(ital_vars, FALSE)) + stopifnot(is.null(label)) + stopifnot(identical(index_factors, FALSE)) + stopifnot(identical(show_distribution, FALSE)) + stopifnot(identical(wrap, FALSE)) + stopifnot(identical(terms_per_line, 4)) + stopifnot(identical(operator_location, "end")) + stopifnot(identical(align_env, "aligned")) + stopifnot(identical(use_coefs, FALSE)) + stopifnot(identical(coef_digits, 2)) + stopifnot(identical(fix_signs, TRUE)) + stopifnot(is.null(font_size)) + stopifnot(missing(mean_separate)) + stopifnot(identical(return_variances, FALSE)) + stopifnot(identical(se_subscripts, FALSE)) + ret <- + paste0( + "\\begin{align*}\n", + paste( + extractEqHelper(x = model, ...), + collapse = " \\\\\n" + ), + "\n\\end{align*}\n" + ) + knitr::asis_output(ret) +} + +#' @rdname extract_eq.nlmixr2FitCore +#' @export +extract_eq.rxUi <- function(model, intercept = "alpha", greek = "beta", + greek_colors = NULL, subscript_colors = NULL, + var_colors = NULL, var_subscript_colors = NULL, + raw_tex = FALSE, + swap_var_names = NULL, swap_subscript_names = NULL, + ital_vars = FALSE, label = NULL, + index_factors = FALSE, show_distribution = FALSE, + wrap = FALSE, terms_per_line = 4, + operator_location = "end", align_env = "aligned", + use_coefs = FALSE, coef_digits = 2, + fix_signs = TRUE, font_size = NULL, + mean_separate, return_variances = FALSE, + se_subscripts = FALSE, ...) { + extract_eq.nlmixr2FitCore(model, intercept = intercept, greek = greek, + greek_colors = greek_colors, subscript_colors = subscript_colors, + var_colors = var_colors, var_subscript_colors = var_colors, + raw_tex = raw_tex, + swap_var_names = swap_var_names, swap_subscript_names = swap_subscript_names, + ital_vars = ital_vars, label = label, + index_factors = index_factors, show_distribution = show_distribution, + wrap = wrap, terms_per_line = terms_per_line, + operator_location = operator_location, align_env = align_env, + use_coefs = use_coefs, coef_digits = coef_digits, + fix_signs = fix_signs, font_size = font_size, + mean_separate = mean_separate, return_variances = return_variances, + se_subscripts = se_subscripts, ...) +} + +extractEqHelper <- function(x, ..., inModel) { + UseMethod("extractEqHelper") +} + +# Ignore one (or more) items in a sequence. Typically used for {} and () +extractEqHelperSeqDrop <- function(x, ..., inModel, dropIdx = 1) { + ret <- character() + retNames <- names(x) + for (idx in setdiff(seq_along(x), dropIdx)) { + ret <- c(ret, extractEqHelper(x[[idx]], name=retNames[[idx]], ..., inModel = inModel)) + } + ret +} + +# Generate something with a left and right hand side +extractEqHelperLhsRhs <- function(x, ..., inModel, prefix = "", middle, suffix = "", lhsForce = NULL, rhsForce = NULL) { + stopifnot(length(prefix) == 1) + stopifnot(length(middle) == 1) + stopifnot(length(suffix) == 1) + if (length(x) != 3) { + stop("extractEqHelperLhsRhs requires length of 3, please report a bug") # nocov + } + stopifnot(length(x) == 3) + if (!is.null(lhsForce)) { + lhs <- lhsForce + } else { + lhs <- extractEqHelper(x[[2]], ..., inModel = inModel) + } + if (!is.null(rhsForce)) { + rhs <- rhsForce + } else { + rhs <- extractEqHelper(x[[3]], ..., inModel = inModel) + } + stopifnot(length(lhs) == 1) + stopifnot(length(rhs) == 1) + paste0(prefix, lhs, middle, rhs, suffix) +} + +extractEqHelper.nlmixr2FitCore <- function(x, ..., inModel) { + extractEqHelper(as.function(x), ..., inModel=FALSE) +} + +extractEqHelper.rxUi <- function(x, ..., inModel, name) { + extractEqHelper(as.function(x), ..., inModel=FALSE) +} + +extractEqHelper.function <- function(x, ..., inModel, name) { + extractEqHelper(methods::functionBody(x), ..., inModel=FALSE) +} + +"extractEqHelper.{" <- function(x, ..., inModel, name) { + extractEqHelperSeqDrop(x, ..., inModel = inModel) +} + +"extractEqHelper.(" <- function(x, ..., inModel, dropParen = FALSE, name) { + stopifnot(length(x) == 2) + if (dropParen) { + ret <- extractEqHelper(x[[2]], ..., inModel = inModel) + } else { + # This inherently respects inModel = FALSE because sprintf() with + # character(0) input returns character(0) + ret <- + sprintf( + "\\left(%s\\right)", + extractEqHelper(x[[2]], ..., inModel = inModel) + ) + } + ret +} + +matchesTemplate <- function(x, template) { + ret <- class(x) == class(template) + if (ret) { + if (length(x) == length(template)) { + if (length(x) > 1) { + for (idx in seq_along(x)) { + ret <- ret && matchesTemplate(x[[idx]], template[[idx]]) + } + } else if (is.name(x)) { + if (as.character(template) != "name") { + # Check for a value if the name is not "name" + ret <- x == template + } + } else { + # Do nothing for numeric, character, etc. + } + } else { + ret <- FALSE + } + } + ret +} + +isOdeAssign <- function(x) { + matchesTemplate(x[[2]], str2lang("d/dt(name)")) +} + +# @param alignment gives the text to provide before the equal sign to align on +# the sign +# This function is named `extractEqHelperAssign` instead of `extractEqHelper.<-` +# to fix an R CMD check issue. It is used via the `extractEqHelper.default` +# function. +extractEqHelperAssign <- function(x, ..., inModel, alignment = "&", name) { + if (inModel) { + lhsForce <- NULL + rhsForce <- NULL + if (isOdeAssign(x)) { + cmtName <- as.character(x[[2]][[3]][[2]]) + if (nchar(cmtName) > 1) { + # \: forces a medium space in LaTeX equations, do it for state names + # with more than one character. + spacesep <- " \\: " + } else { + spacesep <- "" + } + lhsForce <- sprintf("\\frac{d%s%s}{dt}", spacesep, cmtName) + rhsForce <- extractEqHelper(x[[3]], ..., inModel = inModel) + } + middleForce <- sprintf(" %s = ", alignment) + ret <- + extractEqHelperLhsRhs( + x, ..., inModel = inModel, + middle = middleForce, + lhsForce = lhsForce, + rhsForce = rhsForce + ) + } else { + ret <- character() + } + ret +} + +latexOpMap <- + list( + "<"="<", + "<="="\\leq", + "=="="\\equiv", + ">="="\\geq", + ">"=">", + "&"="\\land", + "&&"="\\land", + "|"="\\lor", + "||"="\\lor", + "!="="\\ne", + "!"="\\lnot" + ) + +extractEqHelper.call <- function(x, ..., inModel, name) { + if (inModel) { + if (is.name(x[[1]])) { + x1c <- as.character(x[[1]]) + if (x1c %in% c("exp", "log")) { + stopifnot(length(x) == 2) + ret <- + sprintf( + "\\%s\\left(%s\\right)", + x1c, + extractEqHelper(x[[2]], ..., inModel = inModel) + ) + stopifnot(length(ret) == 1) + } else if (x1c %in% c("<", "<=", "==", ">=", ">", "&", "&&", "|", "||", "!=")) { + # binary logical operators + ret <- extractEqHelperLhsRhs(x, ..., inModel = inModel, middle = latexOpMap[[x1c]]) + } else if (x1c %in% "!") { + # unary logical operator + stopifnot(length(x) == 2) + ret <- + sprintf( + "%s %s", + latexOpMap[[x1c]], + extractEqHelper(x[[2]], ..., inModel = inModel) + ) + } else if (x1c %in% c("+", "-")) { + if (length(x) == 2) { + # Handle unary plus and minus + ret <- sprintf("%s%s", x1c, extractEqHelper(x[[2]], ..., inModel = inModel)) + } else if (length(x) == 3) { + # Handle binary plus and minus + ret <- extractEqHelperLhsRhs(x, ..., inModel = inModel, middle = x1c) + } else { + cli::cli_abort("Cannot handle addition or subtraction with length that is not 2 or 3") # nocov + } + } else if (x1c == "*") { + ret <- extractEqHelperLhsRhs(x, ..., inModel = inModel, middle = " {\\times} ") + } else if (x1c == "/") { + ret <- + extractEqHelperLhsRhs( + x, ..., inModel = inModel, + prefix = "\\frac{", + middle = "}{", + suffix = "}" + ) + } else if (x1c %in% c("**", "^")) { + ret <- + extractEqHelperLhsRhs( + x, ..., inModel = inModel, + prefix = "{", + middle = "}^{", + suffix = "}" + ) + } else if (x1c == "~") { + ret <- + extractEqHelperLhsRhs( + x, ..., + inModel = inModel, + middle = " & \\sim " + ) + } else { + # A generic call that is printed using parentheses + ret <- + sprintf( + "%s(%s)", + x1c, + paste( + extractEqHelperSeqDrop(x, ..., inModel = inModel), + collapse = ", " + ) + ) + } + } else { + stop("a call that does not start with a name is in the model, please report a bug") # nocov + } + } else if (length(x) == 1) { + stop("a one-length call is not inModel, please report a bug") # nocov + } else { + if (is.name(x[[1]])) { + if (x[[1]] == as.name("model")) { + ret <- extractEqHelperSeqDrop(x, ..., inModel = TRUE, dropBrace = TRUE) + } else { + # When not in the model, calls don't matter unless they are `model()` + ret <- character() + } + } else { + stop("a call that does not start with a name does not have inModel set, please report a bug") # nocov + } + } + ret +} + +extractEqHelper.name <- function(x, ..., inModel, underscoreToSubscript = FALSE, name) { + if (inModel) { + ret <- as.character(x) + if (underscoreToSubscript && grepl(x = ret, pattern = "_", fixed = TRUE)) { + firstSecondPattern <- "^(.*?)_(.*)$" + # The first underscore becomes a subscript + firstPart <- gsub(x = ret, pattern = firstSecondPattern, replacement = "\\1") + # Remaining underscores become commas + secondPartPrep <- gsub(x = ret, pattern = firstSecondPattern, replacement = "\\2") + secondPart <- gsub(x = secondPartPrep, pattern = "_", replacement = ", ", fixed = TRUE) + ret <- sprintf("%s_{%s}", firstPart, secondPart) + } else { + # Otherwise underscores are protected from LaTeX interpretation + ret <- gsub(x = ret, pattern = "_", replacement = "\\_", fixed = TRUE) + } + } else { + ret <- character() + } + ret +} + +extractEqHelper.numeric <- function(x, ..., inModel, name = NULL) { + if (inModel) { + ret <- format(x) + # Convert SI to exponents + patternSi <- "^([0-9]+(?:\\.[0-9]+)?)e([+-][0-9]+)$" + if (grepl(x = ret, pattern = patternSi)) { + base <- gsub(x = ret, pattern = patternSi, replacement = "\\1") + # as.numeric will remove the leading zeros + exponent <- as.numeric(gsub(x = ret, pattern = patternSi, replacement = "\\2")) + ret <- sprintf("{%s \\times 10^{%d}}", base, exponent) + } + if (!is.null(name) && !(name == "")) { + # Hopefully this is right; it occurs in named arguments to calls + ret <- sprintf("%s=%s", name, ret) + } + } else { + ret <- character() + } + ret +} + +# copied from knitr:::escape_latex +escapeLatex <- function (x, newlines = FALSE, spaces = FALSE) { + x = gsub("\\\\", "\\\\textbackslash", x) + x = gsub("([#$%&_{}])", "\\\\\\1", x) + x = gsub("\\\\textbackslash", "\\\\textbackslash{}", x) + x = gsub("~", "\\\\textasciitilde{}", x) + x = gsub("\\^", "\\\\textasciicircum{}", x) + if (newlines) + x = gsub("(? 1) { + bracedPart[length(bracedPart)] <- paste(bracedPart[length(bracedPart)], appendPart[1]) + c(bracedPart[-1], appendPart[-1]) + } else { + appendPart + } + ret <- c(firstPart, lastPart) + ret +} + +extractEqHelper.default <- function(x, ..., inModel) { + if (inherits(x, "<-") | inherits(x, "=")) { + # The assignment classes go via extractEqHelper.default to fix an R CMD + # check issue: + # Warning: 'extractEqHelper.<-' + # The argument of a replacement function which corresponds to the right + # hand side must be named 'value'. + ret <- extractEqHelperAssign(x, ..., inModel = inModel) + } else { + stop("cannot handle class, please report a bug: ", class(x)[1]) # nocov + } + ret +} diff --git a/man/reexports.Rd b/man/reexports.Rd index 85cfbca..91782ea 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -1,8 +1,9 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/reexport.R +% Please edit documentation in R/extract_eq.R, R/reexport.R \docType{import} \name{reexports} \alias{reexports} +\alias{extract_eq} \alias{ini} \alias{model} \alias{nlmixrWithTiming} @@ -16,6 +17,8 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ + \item{equatiomatic}{\code{\link[equatiomatic]{extract_eq}}} + \item{nlmixr2est}{\code{\link[nlmixr2est:nlmixr2]{nlmixr}}, \code{\link[nlmixr2est]{nlmixr2}}, \code{\link[nlmixr2est]{nlmixrWithTiming}}, \code{\link[nlmixr2est]{setCov}}} \item{rxode2}{\code{\link[rxode2]{ini}}, \code{\link[rxode2]{model}}} diff --git a/tests/testthat/test-extract_eq.R b/tests/testthat/test-extract_eq.R new file mode 100644 index 0000000..7244e65 --- /dev/null +++ b/tests/testthat/test-extract_eq.R @@ -0,0 +1,293 @@ +test_that("extract_eq, simple version", { + mod <- function() { + ini({ + lka <- 0.45 + lcl <- 1 + lvc <- 3.45 + propSd <- 0.5 + }) + model({ + ka <- exp(lka) + cl <- exp(lcl) + vc <- exp(lvc) + + cp <- linCmt() + cp ~ prop(propSd) + }) + } + ui <- rxode2::rxode(mod) + expect_equal( + extract_eq(ui), + knitr::asis_output("\\begin{align*}\nka & = \\exp\\left(lka\\right) \\\\\ncl & = \\exp\\left(lcl\\right) \\\\\nvc & = \\exp\\left(lvc\\right) \\\\\ncp & = linCmt() \\\\\ncp & \\sim prop(propSd)\n\\end{align*}\n") + ) + + suppressMessages( + fit <- nlmixr2est::nlmixr(mod, data = nlmixr2data::theo_sd, est = "focei", control = nlmixr2est::foceiControl(eval.max = 1, print = 0)) + ) + expect_equal( + extract_eq(fit), + knitr::asis_output("\\begin{align*}\nka & = \\exp\\left(lka\\right) \\\\\ncl & = \\exp\\left(lcl\\right) \\\\\nvc & = \\exp\\left(lvc\\right) \\\\\ncp & = linCmt() \\\\\ncp & \\sim prop(propSd)\n\\end{align*}\n") + ) +}) + +test_that("extract_eq, less common models", { + mod <- function() { + ini({ + lka <- 0.45 + lcl <- 1 + lvc <- 3.45 + }) + model({ + ka <- exp(lka) < 1 + cl <- exp(lcl) <= 2 + vc <- exp(lvc) == 3 + vc4 <- vc >= 4 + vc5 <- vc > 5 + vc6 <- vc & 6 + vc7 <- vc && 7 + vc8 <- vc | 8 + vc9 <- vc || 9 + vc10 <- vc != 10 + vc11 <- !vc + if (vc > 11) { + cl <- 12 + } else if (vc > 13) { + cl <- 14 + cl <- 15 + } else { + cl <- 16 + } + + cp <- linCmt() + # ordinal model + cp ~ c(p0=0, p1=1, p2=2, 3) + }) + } + ui <- rxode2::rxode(mod) + expect_equal( + extract_eq(ui), + knitr::asis_output("\\begin{align*}\nka & = \\exp\\left(lka\\right)<1 \\\\\ncl & = \\exp\\left(lcl\\right)\\leq2 \\\\\nvc & = \\exp\\left(lvc\\right)\\equiv3 \\\\\nvc4 & = vc\\geq4 \\\\\nvc5 & = vc>5 \\\\\nvc6 & = vc\\land6 \\\\\nvc7 & = vc\\land7 \\\\\nvc8 & = vc\\lor8 \\\\\nvc9 & = vc\\lor9 \\\\\nvc10 & = vc\\ne10 \\\\\nvc11 & = \\lnot vc \\\\\n\\mathrm{if} & \\left(vc>11\\right) \\{ \\\\\n & cl = 12 \\\\\n\\} \\quad & \\mathrm{else} \\: \\mathrm{if} \\left(vc>13\\right) \\{ \\\\\n & cl = 14 \\\\\n & cl = 15 \\\\\n\\} \\quad & \\mathrm{else} \\: cl = 16 \\\\\ncp & = linCmt() \\\\\ncp & \\sim c(p0=0, p1=1, p2=2, 3)\n\\end{align*}\n") + ) +}) + +test_that("extract_eq, model with 'if' and a character string", { + mod <- function() { + ini({ + lka <- 0.45 + lcl <- 1 + lvc <- 3.45 + }) + model({ + ka <- exp(lka) < 1 + cl <- exp(lcl) <= 2 + vc <- exp(lvc) == 3 + if (vc == "a") { + cl <- 12 + } else { + cl <- 16 + } + + cp <- linCmt() + # ordinal model + cp ~ c(p0=0, p1=1, p2=2, 3) + }) + } + ui <- rxode2::rxode(mod) + expect_equal( + extract_eq(ui), + knitr::asis_output("\\begin{align*}\nka & = \\exp\\left(lka\\right)<1 \\\\\ncl & = \\exp\\left(lcl\\right)\\leq2 \\\\\nvc & = \\exp\\left(lvc\\right)\\equiv3 \\\\\n\\mathrm{if} & \\left(vc\\equiv\\text{\"a\"}\\right) \\{ \\\\\n & cl = 12 \\\\\n\\} \\quad & \\mathrm{else} \\: cl = 16 \\\\\ncp & = linCmt() \\\\\ncp & \\sim c(p0=0, p1=1, p2=2, 3)\n\\end{align*}\n") + ) +}) + +expect_equal( + extractEqHelper.function(function() {ini({a <- 1});model({log(foo)+exp(bar)})}, inModel = FALSE), + "\\log\\left(foo\\right)+\\exp\\left(bar\\right)" +) + +test_that("extractEqHelper.(", { + expect_equal( + "extractEqHelper.("(str2lang("(foo)"), inModel = TRUE), + "\\left(foo\\right)" + ) + expect_equal( + "extractEqHelper.("(str2lang("(foo)"), inModel = FALSE), + character() + ) +}) + +test_that("extractEqHelperAssign", { + # ODE, space with multiple-character state ("abc") + expect_equal( + extractEqHelperAssign(str2lang("d/dt(abc) = d"), inModel = TRUE), + "\\frac{d \\: abc}{dt} & = d" + ) + # ODE, no space with single-character state ("a") + expect_equal( + extractEqHelperAssign(str2lang("d/dt(a) = b"), inModel = TRUE), + "\\frac{da}{dt} & = b" + ) + expect_equal( + extractEqHelperAssign(str2lang("a = b"), inModel = TRUE), + "a & = b" + ) + expect_equal( + extractEqHelperAssign(str2lang("a <- b"), inModel = TRUE), + "a & = b" + ) + expect_equal( + extractEqHelperAssign(str2lang("a <- b"), inModel = FALSE), + character() + ) +}) + +test_that("extractEqHelper.call", { + # named functions are escaped + expect_equal( + extractEqHelper.call(str2lang("model({log(foo)+exp(bar)})"), inModel = FALSE), + "\\log\\left(foo\\right)+\\exp\\left(bar\\right)" + ) + # binary plus and unary minus + expect_equal( + extractEqHelper.call(str2lang("model({-foo+add(bar)})"), inModel = FALSE), + "-foo+add(bar)" + ) + # multiplication + expect_equal( + extractEqHelper.call(str2lang("model({foo*add(bar)})"), inModel = FALSE), + "foo {\\times} add(bar)" + ) + # division + expect_equal( + extractEqHelper.call(str2lang("model({foo/add(bar)})"), inModel = FALSE), + "\\frac{foo}{add(bar)}" + ) + # exponent with both operators + expect_equal( + extractEqHelper.call(str2lang("model({foo**add(bar)})"), inModel = FALSE), + "{foo}^{add(bar)}" + ) + expect_equal( + extractEqHelper.call(str2lang("model({foo^add(bar)})"), inModel = FALSE), + "{foo}^{add(bar)}" + ) + expect_equal( + extractEqHelper.call(str2lang("model({foo~add(bar)})"), inModel = FALSE), + "foo & \\sim add(bar)" + ) + # transition to inModel works + expect_equal( + extractEqHelper.call(str2lang("model({foo(bar)})"), inModel = FALSE), + "foo(bar)" + ) + expect_equal( + extractEqHelper.call(str2lang("foo(bar)"), inModel = FALSE), + character() + ) +}) + +test_that("extractEqHelper.name", { + expect_equal( + extractEqHelper.name(as.name("fo_o_bar"), inModel = TRUE, underscoreToSubscript = FALSE), + "fo\\_o\\_bar" + ) + expect_equal( + extractEqHelper.name(as.name("fo_o_bar"), inModel = TRUE, underscoreToSubscript = TRUE), + "fo_{o, bar}" + ) + expect_equal( + extractEqHelper.name(as.name("fo_o"), inModel = TRUE, underscoreToSubscript = TRUE), + "fo_{o}" + ) + expect_equal( + extractEqHelper.name(as.name("foo"), inModel = TRUE, underscoreToSubscript = TRUE), + "foo" + ) + expect_equal( + extractEqHelper.name(as.name("foo"), inModel = FALSE), + character() + ) +}) + +test_that("extractEqHelper.numeric", { + expect_equal( + extractEqHelper.numeric(5, inModel = TRUE), + "5" + ) + expect_equal( + extractEqHelper.numeric(pi, inModel = TRUE), + "3.141593" + ) + # test SI + expect_equal( + extractEqHelper.numeric(1.234567890123456789e15, inModel = TRUE), + "{1.234568 \\times 10^{15}}" + ) + expect_equal( + extractEqHelper.numeric(5, inModel = FALSE), + character() + ) +}) + +test_that("extractEqHelper.character", { + # no escape required + expect_equal( + extractEqHelper.character("foo", inModel = TRUE), + '\\text{"foo"}' + ) + # escape LaTeX + expect_equal( + extractEqHelper.character("fo%o", inModel = TRUE), + '\\text{"fo\\%o"}' + ) + # not in model outputs empty + expect_equal( + extractEqHelper.character("foo", inModel = FALSE), + character() + ) +}) + +test_that("extractEqHelper.if", { + ifOnly <- str2lang(" + if (vc > 11) { + cl <- 12 + }") + ifOnlyNoBrace <- str2lang("if (vc > 11) cl <- 12") + ifOnlyMultiline <- str2lang(" + if (vc > 11) { + cl <- 12 + cl2 <- 13 + }") + ifElse <- str2lang("if (vc > 11) { + cl <- 12 + } else { + cl <- 16 + }") + ifElseIf <- str2lang("if (vc > 11) { + cl <- 12 + } else if (vc > 13) { + cl <- 14 + cl <- 15 + } else { + cl <- 16 + }") + expect_equal( + extractEqHelper.if(ifOnly, inModel = TRUE), + c("\\mathrm{if} & \\left(vc>11\\right) \\{", " & cl = 12", "\\} ") + ) + expect_equal( + extractEqHelper.if(ifOnlyNoBrace, inModel = TRUE), + "\\mathrm{if} & \\left(vc>11\\right) cl = 12" + ) + expect_equal( + extractEqHelper.if(ifOnlyMultiline, inModel = TRUE), + c("\\mathrm{if} & \\left(vc>11\\right) \\{", " & cl = 12", " & cl2 = 13", "\\} ") + ) + expect_equal( + extractEqHelper.if(ifElse, inModel = TRUE), + c("\\mathrm{if} & \\left(vc>11\\right) \\{", " & cl = 12", "\\} \\quad & \\mathrm{else} \\: cl = 16") + ) + expect_equal( + extractEqHelper.if(ifElseIf, inModel = TRUE), + c("\\mathrm{if} & \\left(vc>11\\right) \\{", " & cl = 12", "\\} \\quad & \\mathrm{else} \\: \\mathrm{if} \\left(vc>13\\right) \\{", " & cl = 14", " & cl = 15", "\\} \\quad & \\mathrm{else} \\: cl = 16") + ) +})