## The internal routine converting Basic to R expression ===============
asLanguage <- function(x) {
if (!inherits(x, "Basic"))
return(x)
btype <- s4basic_get_type(x)
func <- get0(btype, envir = asLanguageTable, inherits = FALSE)
if (is.null(func))
stop(sprintf("Conversion method for %s has not implemented", btype))
func(x)
}
# A reference can be:
# https://github.com/symengine/symengine.py/blob/master/symengine/lib/symengine_wrapper.pyx#L35
asLanguageTable <- as.environment(list(
Symbol = function(s) as.name(as.character(s)),
Integer = function(s) as.integer(s),
RealDouble = function(s) as.double(s),
Constant = function(s) as.double(evalf(s)),
Rational = function(s) as.double(evalf(s)), ## TODO: preserve div operator?
`NaN` = function(s) NaN,
#Complex = function(s) stop("TODO"),
#ComplexDouble = function(s) stop("TODO"),
#ComplexMPC = function(s) stop("TODO"),
Add = function(s) {
Reduce(x = as.list(s4basic_get_args(s)),
function(a, b) bquote(.(asLanguage(a)) + .(asLanguage(b))))
},
Mul = function(s) {
Reduce(x = as.list(s4basic_get_args(s)),
function(a, b) bquote(.(asLanguage(a)) * .(asLanguage(b))))
},
Pow = function(s) {
args <- s4basic_get_args(s)
stopifnot(length(args) == 2)
bquote(.(asLanguage(args[[1]])) ^ .(asLanguage(args[[2]])))
},
Infty = function(s) {
if (s4basic_number_is_positive(s)) return(Inf)
else if (s4basic_number_is_negative(s)) return(-Inf)
stop("Unexpected")
},
Abs = function(s) bquote(abs( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Log = function(s) bquote(log( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Gamma = function(s) bquote(gamma( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Sin = function(s) bquote(sin( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Cos = function(s) bquote(cos( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Tan = function(s) bquote(tan( .(asLanguage(s4basic_get_args(s)[[1]])) )),
ASin = function(s) bquote(asin( .(asLanguage(s4basic_get_args(s)[[1]])) )),
ACos = function(s) bquote(acos( .(asLanguage(s4basic_get_args(s)[[1]])) )),
ATan = function(s) bquote(atan( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Sinh = function(s) bquote(sinh( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Cosh = function(s) bquote(cosh( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Tanh = function(s) bquote(tanh( .(asLanguage(s4basic_get_args(s)[[1]])) )),
ASinh = function(s) bquote(asinh( .(asLanguage(s4basic_get_args(s)[[1]])) )),
ACosh = function(s) bquote(acosh( .(asLanguage(s4basic_get_args(s)[[1]])) )),
ATanh = function(s) bquote(atanh( .(asLanguage(s4basic_get_args(s)[[1]])) )),
#### These functions are not in base R, but may be provided by 'pracma' ####
Cot = function(s) bquote(cot (.(asLanguage(s4basic_get_args(s)[[1]])) )),
Csc = function(s) bquote(csc (.(asLanguage(s4basic_get_args(s)[[1]])) )),
Sec = function(s) bquote(sec (.(asLanguage(s4basic_get_args(s)[[1]])) )),
ACot = function(s) bquote(acot (.(asLanguage(s4basic_get_args(s)[[1]])) )),
ACsc = function(s) bquote(acsc (.(asLanguage(s4basic_get_args(s)[[1]])) )),
ASec = function(s) bquote(asec (.(asLanguage(s4basic_get_args(s)[[1]])) )),
Coth = function(s) bquote(coth (.(asLanguage(s4basic_get_args(s)[[1]])) )),
Csch = function(s) bquote(csch (.(asLanguage(s4basic_get_args(s)[[1]])) )),
Sech = function(s) bquote(sech (.(asLanguage(s4basic_get_args(s)[[1]])) )),
ACoth = function(s) bquote(acoth (.(asLanguage(s4basic_get_args(s)[[1]])) )),
ACsch = function(s) bquote(acsch (.(asLanguage(s4basic_get_args(s)[[1]])) )),
ASech = function(s) bquote(asech (.(asLanguage(s4basic_get_args(s)[[1]])) )),
############################################################################
ATan2 = function(s) {
args <- s4basic_get_args(s)
bquote(atan2( .(asLanguage(args[[1]])), .(asLanguage(args[[2]])) ))
},
LambertW = function(s) bquote(lambertw( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Zeta = function(s) {
## Zeta has two args, ensure the second arg is One
args <- s4basic_get_args(s)
stopifnot(args[[2L]] == S(1L))
bquote(zeta( .(asLanguage(args[[1]])) ))
},
Dirichlet_eta = function(s) bquote(dirichlet_eta( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Erf = function(s) bquote(erf( .(asLanguage(s4basic_get_args(s)[[1]])) )),
Erfc = function(s) bquote(erfc( .(asLanguage(s4basic_get_args(s)[[1]])) )),
LogGamma = function(s) bquote(lgamma( .(asLanguage(s4basic_get_args(s)[[1]])) )),
KroneckerDelta = function(s) {
args <- get_args(s)
bquote(kronecker_delta( .(asLanguage(args[[1]])), .(asLanguage(args[[2]])) ))
},
LowerGamma = function(s) {
args <- get_args(s)
a <- asLanguage(args[[1]])
x <- asLanguage(args[[2]])
bquote(lowergamma(.(x), .(a)))
},
UpperGamma = function(s) {
args <- get_args(s)
a <- asLanguage(args[[1]])
x <- asLanguage(args[[2]])
bquote(uppergamma(.(x), .(a)))
},
Beta = function(s) {
args <- get_args(s)
bquote(beta( .(asLanguage(args[[1]])), .(asLanguage(args[[2]])) ))
},
PolyGamma = function(s) {
args <- get_args(s)
deriv <- asLanguage(args[[1]])
x <- asLanguage(args[[2]])
bquote(psigamma( .(x), .(deriv) ))
}
#LeviCivita,
#Sign, Floor, Ceiling,
))
## Parse R expression and formula =====================================
## This function will be called by 'S'
RExprSupported <- c(
"(",
"+", "-", "*", "/", "^",
## Supported Math@groupMembers
"abs", "sqrt", "exp", "expm1", "log", "log10", "log2", "log1p",
"cos", "cosh", "sin", "sinh", "tan", "tanh", "acos", "acosh", "asin", "asinh", "atan", "atanh",
"cospi", "sinpi", "tanpi", "gamma", "lgamma", "digamma", "trigamma",
## Unsupported Math@groupMembers
#"sign", "ceiling", "floor", "trunc", "cummax", "cummin", "cumprod", "cumsum",
## Misc
"lambertw", "zeta", "dirichlet_eta", "erf", "erfc",
"atan2", "kronecker_delta", "lowergamma", "uppergamma", "psigamma", "beta"
)
RPkgEnv <- environment()
## TODO: add test case S(~ .(~x))
s4basic_parse_language <- function(x) {
parseLanguage(x, check_whole_number = FALSE, backquote_env = NA)
}
parseLanguage <- function(x, check_whole_number, backquote_env) {
## Formula
if (is.call(x) && x[[1L]] == quote(`~`)) {
if (length(x) != 2)
stop("Can only accept formula with right hand side")
formula_env <- environment(x)
if (is.null(formula_env))
formula_env <- NA ## Ensure it will fail the backquoting
return(parseLanguage(x[[2L]],
check_whole_number = TRUE, backquote_env = formula_env))
}
## Backquote inside an expression
if (is.call(x) && x[[1L]] == as.name(".")) {
inner_x <- x[[2L]]
value <- eval(inner_x, envir = backquote_env)
## Non-Basic value should be converted to Basic
return(s4basic_parse(value, check_whole_number = FALSE))
}
# ## `{{ x }}` style backquoting.
# if (is.call(x) && x[[1L]] == as.name("{")
# && length(x) == 2L && expr[[2]][[1]] == as.name("{")) {
# inner_x <- as.list(expr[[2]][-1])
# for (e in inner_x)
# last <- eval(e, envir = backquote_env)
# return(s4basic_parse(last, check_whole_number = FALSE))
# }
## Supported functions
if (is.call(x) && is.symbol(x[[1L]]) &&
(as.character(x[[1L]]) %in% RExprSupported)) {
args <- lapply(x[-1], parseLanguage,
check_whole_number = check_whole_number,
backquote_env = backquote_env)
func <- get(as.character(x[[1L]]), mode = "function", envir = RPkgEnv)
return(do.call(func, args))
}
if (is.symbol(x))
return(Symbol(as.character(x)))
if (is.integer(x))
return(S(x))
if (is.double(x))
return(s4basic_parse(x, check_whole_number = check_whole_number))
#if (is.character(expr))
# return(S(expr))
if (inherits(x, "Basic"))
return(x)
## i.e. cases like f()(y)
## I am not sure whether this should be allowed. (unless x[[1]] is backquoted?)
## Also note that bquote does not handle bquote(.(func)(x))
if (is.call(x) && (!is.symbol(x[[1L]]))) {
"pass"
}
stop(sprintf("Unable to parse %s", deparse(x)))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.