From 49ce3403749066a2d856f3c8174df25118c44d9e Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Wed, 4 Nov 2015 16:43:30 -0500 Subject: [PATCH 01/20] Update to SymPy 0.7.6 Use PythonInR instead of Jython to support Python 3.x for SymPy 0.7.6. Update kopy.bat script for my development PC. Accept NULL rather than "NULL" for retclass in Var() and sympy() functions. Fix inconsistent whitespace. --- DESCRIPTION | 2 +- NAMESPACE | 10 ++++++++++ R/Sym.R | 18 +++++++++--------- R/sympy.R | 37 ++++++++++++++++++------------------- inst/kopy.bat | 11 +++-------- inst/kopy.exclude.txt | 1 + 6 files changed, 42 insertions(+), 37 deletions(-) create mode 100644 NAMESPACE create mode 100644 inst/kopy.exclude.txt diff --git a/DESCRIPTION b/DESCRIPTION index 30b5762..353a272 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -6,6 +6,6 @@ Author: G Grothendieck (SymPy itself is by Ondrej Certik and others), Contributors: Carlos J. Gil Bellosta Maintainer: G Grothendieck Description: Access SymPy computer algebra system from R via Jython -Depends: rJython +Depends: PythonInR License: GPL URL: http://rsympy.googlecode.com diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..129615f --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,10 @@ +# Default NAMESPACE created by R +# Remove the previous line if you edit this file + +# Export all names +exportPattern(".") + +# Import all packages listed as Imports or Depends +import( + PythonInR +) diff --git a/R/Sym.R b/R/Sym.R index f27af4c..f4422a3 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -1,17 +1,17 @@ Sym <- function(..., retclass = c("Sym", "character")) { - args <- list(...) - retclass <- match.arg(retclass) - value <- if (length(args) > 1) paste("(", ..., ")") else paste(args[[1]]) - if (retclass == "Sym") class(value) <- c("Sym", "character") - value + args <- list(...) + retclass <- match.arg(retclass) + value <- if (length(args) > 1) paste("(", ..., ")") else paste(args[[1]]) + if (retclass == "Sym") class(value) <- c("Sym", "character") + value } as.character.Sym <- function(x, ...) as.character(unclass(x)) Ops.Sym <- function (e1, e2) - if (missing(e2)) { Sym(.Generic, e1) - } else Sym(e1, .Generic, e2) + if (missing(e2)) { Sym(.Generic, e1) + } else Sym(e1, .Generic, e2) Math.Sym <- function(x, ...) { idx <- match(.Generic, transtab[,1], nomatch = 0) @@ -27,9 +27,9 @@ deriv.Sym <- function(expr, name = "x", n = 1, ...) Limit <- function(expr, name = "x", value) Sym("limit(", expr, ",", name, ",", value, ")") -Var <- function(x, retclass = c("Sym", "character", "NULL")) { +Var <- function(x, retclass = c("Sym", "character")) { x <- paste("var('", x, "')", sep = "") - sympy(x, retclass = match.arg(retclass)) + sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) } solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { diff --git a/R/sympy.R b/R/sympy.R index ac6c2f7..f74275a 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -1,10 +1,4 @@ -jythonStart <- function(jython.jar) { - .jinit(jython.jar) - assign(".Jython", .jnew("org.python.util.PythonInterpreter"), .GlobalEnv) - invisible(.Jython) -} - sympyStart <- function() { # like system.file but on Windows uses \ in path rather than / @@ -13,24 +7,29 @@ sympyStart <- function() { if (.Platform$OS == "windows") gsub("/", "\\", s, fixed = TRUE) else s } - assign(".Jython", rJython( modules = system.file( "Lib", package = "rSymPy" ) ), .GlobalEnv) + if (!pyIsConnected()) pyConnect() - .Jython$exec("import sys") - .Jython$exec("from sympy import *") + pyExecp("import sys") + pyExecp( paste( "sys.path.append(", system.file( "Lib", package = "rSymPy" ), ")", sep = '"' ) ) + pyExecp("from sympy import *") + pyExecp("from sympy.printing.mathml import mathml") + pyExecp("from sympy.utilities.lambdify import lambdify") + assign('.SympyConnected', TRUE) } -sympy <- function(..., retclass = c("character", "Sym", "NULL"), debug = FALSE) { - if (!exists(".Jython", .GlobalEnv)) sympyStart() - retclass <- match.arg(retclass) - if (retclass != "NULL") { - .Jython$exec(paste("__Rsympy=", ...)) - if (debug) .Jython$exec("print __Rsympy") - Rsympy <- .Jython$get("__Rsympy") - out <- if (!is.null(Rsympy)) .jstrVal(Rsympy) - if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") +sympy <- function(..., retclass = c("character", "Sym"), debug = FALSE) { + if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() + retclass <- if (is.null(retclass)) NULL else match.arg(retclass) + if (!is.null(retclass)) { + pyExec(paste("__Rsympy=None")) + pyExecp(paste("__Rsympy=", ..., sep = "")) + if (debug) pyExecp("print(__Rsympy)") + pyExec(paste("__Rsympy = str(__Rsympy)")) + out <- pyGet("__Rsympy") + if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") else out - } else .Jython$exec(paste(...)) + } else pyExecp(paste(...)) } diff --git a/inst/kopy.bat b/inst/kopy.bat index 430ac85..b64a8bb 100644 --- a/inst/kopy.bat +++ b/inst/kopy.bat @@ -3,17 +3,12 @@ rem This batch file only works on the author's system and is used rem for copying jython and sympy to the rSymPy tree. rem rem To use edit the: -rem 1. 1st line to change directory to folder constaining rSymPy source folder -rem 2. 1st xcopy line to identify the jython source tree -rem 3. 2nd xcopy line to identify the sympy tree - -:: gor.bat changes directory to the R development area -call gor svn rSympy inst -copy \jython2.5.1\jython.jar jython.jar +rem 1. 1st xcopy line to identify the sympy tree :: The following xcopy arguments are used: :: /e = recursively copy including empty directories :: /i = target is directory to be created if not already present +:: /exclude = ignore compiled binaries if not exist Lib md Lib if not exist Lib\sympy md Lib\sympy -xcopy /e /i \tmp2\sympy-0.6.5\sympy Lib\sympy +xcopy /e /i /exclude:kopy.exclude.txt C:\Python34\Lib\site-packages\sympy Lib\sympy diff --git a/inst/kopy.exclude.txt b/inst/kopy.exclude.txt new file mode 100644 index 0000000..2ac188d --- /dev/null +++ b/inst/kopy.exclude.txt @@ -0,0 +1 @@ +.pyc\ From dd9b573b943109cb2e514a6b38fe5b258b5db448 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Wed, 4 Nov 2015 17:03:35 -0500 Subject: [PATCH 02/20] Automate SymPy download in R CMD build and R CMD INSTALL Write configure and configure.win shell scripts to download SymPy 0.7.6.1 tarball from GitHub and extract it to inst/Lib. Delete development PC specific kopy.bat. --- .Rbuildignore | 4 +++- .gitattributes | 2 ++ .gitignore | 2 ++ configure | 18 ++++++++++++++++++ configure.win | 18 ++++++++++++++++++ inst/kopy.bat | 14 -------------- inst/kopy.exclude.txt | 1 - 7 files changed, 43 insertions(+), 16 deletions(-) create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100755 configure create mode 100755 configure.win delete mode 100644 inst/kopy.bat delete mode 100644 inst/kopy.exclude.txt diff --git a/.Rbuildignore b/.Rbuildignore index 3c415bf..879a299 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1 +1,3 @@ -inst/jython/Lib/distutils/command/wininst-.*\.exe +sympy-0.7.6.1.tar.gz +.gitignore +.gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..646b76a --- /dev/null +++ b/.gitattributes @@ -0,0 +1,2 @@ +configure.win text eol=lf +configure text eol=lf diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4830257 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +sympy-0.7.6.1.tar.gz +inst/Lib diff --git a/configure b/configure new file mode 100755 index 0000000..e4ad3ae --- /dev/null +++ b/configure @@ -0,0 +1,18 @@ +#!/bin/sh +# BASH script for Unix-likes + +R_SCRIPT="${R_HOME}/bin${R_ARCH_BIN}/Rscript" +SET_INTERNET2=`"${R_SCRIPT}" -e "cat(ifelse(compareVersion(sprintf('%s.%s', R.version['major'], R.version['minor']), '3.2.2') > 0, '', 'setInternet2();'))"` + +# Use libcurl if available +USE_LIBCURL=`"${R_SCRIPT}" -e "cat(ifelse(capabilities('libcurl'), 'method=\'libcurl\',', ''))"` + +if [ ! -d inst/Lib/sympy ]; then + mkdir -p inst/Lib + if [ ! -f sympy-0.7.6.1.tar.gz ]; then + "${R_SCRIPT}" -e "${SET_INTERNET2} download.file('https://github.com/sympy/sympy/releases/download/sympy-0.7.6.1/sympy-0.7.6.1.tar.gz', 'sympy-0.7.6.1.tar.gz', ${USE_LIBCURL} quiet = TRUE)" + fi + tar -xzf sympy-0.7.6.1.tar.gz -C inst/Lib sympy-0.7.6.1/sympy + mv inst/Lib/sympy-0.7.6.1/sympy inst/Lib + rm -r inst/Lib/sympy-0.7.6.1 +fi diff --git a/configure.win b/configure.win new file mode 100755 index 0000000..b0d8863 --- /dev/null +++ b/configure.win @@ -0,0 +1,18 @@ +#!/bin/sh +# Almquist shell script for Windows + +R_SCRIPT="${R_HOME}/bin${R_ARCH_BIN}/Rscript" +SET_INTERNET2=`"${R_SCRIPT}" -e "cat(ifelse(compareVersion(sprintf('%s.%s', R.version['major'], R.version['minor']), '3.2.2') > 0, '', 'setInternet2();'))"` + +# Use libcurl if available +USE_LIBCURL=`"${R_SCRIPT}" -e "cat(ifelse(capabilities('libcurl'), 'method=\'libcurl\',', ''))"` + +if [ ! -d inst/Lib/sympy ]; then + mkdir -p inst/Lib + if [ ! -f sympy-0.7.6.1.tar.gz ]; then + "${R_SCRIPT}" -e "${SET_INTERNET2} download.file('https://github.com/sympy/sympy/releases/download/sympy-0.7.6.1/sympy-0.7.6.1.tar.gz', 'sympy-0.7.6.1.tar.gz', ${USE_LIBCURL} quiet = TRUE)" + fi + tar -xzf sympy-0.7.6.1.tar.gz -C inst/Lib sympy-0.7.6.1/sympy + mv inst/Lib/sympy-0.7.6.1/sympy inst/Lib + rm -r inst/Lib/sympy-0.7.6.1 +fi diff --git a/inst/kopy.bat b/inst/kopy.bat deleted file mode 100644 index b64a8bb..0000000 --- a/inst/kopy.bat +++ /dev/null @@ -1,14 +0,0 @@ - -rem This batch file only works on the author's system and is used -rem for copying jython and sympy to the rSymPy tree. -rem -rem To use edit the: -rem 1. 1st xcopy line to identify the sympy tree - -:: The following xcopy arguments are used: -:: /e = recursively copy including empty directories -:: /i = target is directory to be created if not already present -:: /exclude = ignore compiled binaries -if not exist Lib md Lib -if not exist Lib\sympy md Lib\sympy -xcopy /e /i /exclude:kopy.exclude.txt C:\Python34\Lib\site-packages\sympy Lib\sympy diff --git a/inst/kopy.exclude.txt b/inst/kopy.exclude.txt deleted file mode 100644 index 2ac188d..0000000 --- a/inst/kopy.exclude.txt +++ /dev/null @@ -1 +0,0 @@ -.pyc\ From 23f939d70328aa54feec2b841bd2f79370a584b8 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Wed, 4 Nov 2015 20:18:08 -0500 Subject: [PATCH 03/20] More object-oriented Sym methods Make base integrate() function a generic function and have an implementation for Sym objects. Make a new generic function limit(). Var(), List(), Matrix(), Zero(), Eye(), and Zeros() grouped together as static factories. --- DESCRIPTION | 2 +- NAMESPACE | 3 ++- R/Sym.R | 23 ++++++++++++++++------- 3 files changed, 19 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 353a272..2123aa4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -6,6 +6,6 @@ Author: G Grothendieck (SymPy itself is by Ondrej Certik and others), Contributors: Carlos J. Gil Bellosta Maintainer: G Grothendieck Description: Access SymPy computer algebra system from R via Jython -Depends: PythonInR +Depends: PythonInR, R.methodsS3 License: GPL URL: http://rsympy.googlecode.com diff --git a/NAMESPACE b/NAMESPACE index 129615f..40429e1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,5 +6,6 @@ exportPattern(".") # Import all packages listed as Imports or Depends import( - PythonInR + PythonInR, + R.methodsS3 ) diff --git a/R/Sym.R b/R/Sym.R index f4422a3..fbeb9c4 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -1,4 +1,6 @@ +# constructor + Sym <- function(..., retclass = c("Sym", "character")) { args <- list(...) retclass <- match.arg(retclass) @@ -7,6 +9,8 @@ Sym <- function(..., retclass = c("Sym", "character")) { value } +# methods + as.character.Sym <- function(x, ...) as.character(unclass(x)) Ops.Sym <- function (e1, e2) @@ -24,22 +28,27 @@ print.Sym <- function(x, ...) print(sympy(unclass(x), ...)) deriv.Sym <- function(expr, name = "x", n = 1, ...) Sym("diff(", expr, ", ", name, ",", n, ")") -Limit <- function(expr, name = "x", value) +if (!isGenericS3("limit")) setGenericS3("limit") +limit.Sym <- function(expr, name = "x", value) Sym("limit(", expr, ",", name, ",", value, ")") -Var <- function(x, retclass = c("Sym", "character")) { - x <- paste("var('", x, "')", sep = "") - sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) -} - solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { stopifnot(missing(b)) Sym(paste("(", a, ").inv(", match.arg(method), ")")) } -Integrate <- function(x, ...) Sym("integrate(", paste(x, ..., sep = ","), ")") +if (!isGenericS3("integrate")) setGenericS3("integrate", dontWarn = "stats") +integrate.Sym <- function(x, ...) Sym("integrate(", paste(x, ..., sep = ","), ")") t.Sym <- function(x) Sym(paste("(", x, ").transpose()")) + +# static factories + +Var <- function(x, retclass = c("Sym", "character")) { + x <- paste("var('", x, "')", sep = "") + sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) +} + List <- function(...) Sym("[", paste( ..., sep = ","), "]") Matrix <- function(...) Sym("Matrix(", paste(..., sep = ","), ")") Zero <- function(n) Sym(paste("zero(", n, ")")) From 55a6e8576a76b762c4c04ebd2a2428abb56f363b Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Thu, 5 Nov 2015 15:51:24 -0500 Subject: [PATCH 04/20] Dispatch all R mathematical functions to SymPy Ensure all functions in Math, Ops, Summary, and Complex generic groups are handled by Sym class. Add exception throwing stubs for vector and boolean related R math functions. Implement smarter deriv(), limit(), and integrate() functions that by default grabs the first (alphabetically) variable in the expression as the name of the variable to operate on. Simplify usage of integrate() function. Signature mimics stats integrate() function. Takes in optional lower and upper bounds and follows SymPy syntax to create definite or indefinite integrals. --- R/Sym.GroupGenericFuncs.R | 55 +++++++++++++++++++++++++++++++++++++++ R/Sym.R | 34 +++++++++++++----------- R/sympy.R | 13 +++++++-- 3 files changed, 85 insertions(+), 17 deletions(-) create mode 100644 R/Sym.GroupGenericFuncs.R diff --git a/R/Sym.GroupGenericFuncs.R b/R/Sym.GroupGenericFuncs.R new file mode 100644 index 0000000..60c5d2d --- /dev/null +++ b/R/Sym.GroupGenericFuncs.R @@ -0,0 +1,55 @@ +# methods + +# Ops.Sym group generic overrides +Ops.Sym <- function (e1, e2) if (missing(e2)) Sym(.Generic, e1) else Sym(e1, .Generic, e2) +`^.Sym` <- function(e1, e2) if (missing(e2)) Sym("**", e1) else Sym(e1, "**", e2) +`%%.Sym` <- function(e1, e2) if (missing(e2)) Sym("mod(", e1, ")") else Sym("Mod(", e1, ",", e2, ")") +`%/%.Sym` <- function(e1, e2) if (missing(e2)) trunc(Sym("/", e1)) else trunc(Sym(e1, "/", e2)) # "//" doesn't work +`!.Sym` <- function(e1, e2) if (missing(e2)) Sym("~", e1) else Sym(e1, "~", e2) +# Safer: `&` => And(), `|` => Or(), `!` => Not(), `==` => Eq(), `!=` => Ne(), +# `<` => Lt(), `<=` => Le(), `>=` => Ge(), `>` => Gt() + + +# Math.Sym group generic overrides +transtab <- rbind( + c("Abs", NA, "abs"), + c("lgamma", NA, "loggamma") +) +Math.Sym <- function(x, ...) { + idx <- match(.Generic, transtab[,1], nomatch = 0) + fn <- if (idx > 0) transtab[idx, 3] else .Generic + Sym(fn, "(", x, ")") +} +# TODO: this evaluates the passed expression three times. Very inefficient +trunc.Sym <- function(x) Sym("Piecewise((floor(", x, "),", x, ">= 0), (ceiling(", x, "), True))") +round.Sym <- function(x, digits = 0) Sym("round(", x, ",", digits, ")") +signif.Sym <- function(x, digits = 6) Sym("round(", x, ",", digits, "- (floor(log(", x, ", 10)) + 1))") +expm1.Sym <- function(x) Sym("exp(", x, ") - 1") +log1p.Sym <- function(x) Sym("log(1 +", x, ")") +cospi.Sym <- function(x) Sym("cos(", x, " * pi)") +sinpi.Sym <- function(x) Sym("sin(", x, " * pi)") +tanpi.Sym <- function(x) Sym("tan(", x, " * pi)") +cumsum.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +cumprod.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +cummax.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +cummin.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) + + +# Summary.Sym group generic overrides +all.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +any.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +sum.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +prod.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) +min.Sym <- function(x, na.rm = FALSE) Sym("Min(", x, ")") +max.Sym <- function(x, na.rm = FALSE) Sym("Max(", x, ")") +range.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) + +# Complex.Sym group generic overrides +Arg.Sym <- function(x) Sym("arg(", x, ")") +Conj.Sym <- function(x) Sym("conjugate(", x, ")") +Im.Sym <- function(x) Sym("im(", x, ")") +Mod.Sym <- function(x) abs(x) +Re.Sym <- function(x) Sym("re(", x, ")") + +# TODO: autogenerate wrappers with setGenericS3() for all functions in http://docs.sympy.org/dev/modules/functions/index.html#contents +# that are not in transtab[, 3] and do not have a method named "xxx.Sym" diff --git a/R/Sym.R b/R/Sym.R index fbeb9c4..c15fcc6 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -13,24 +13,14 @@ Sym <- function(..., retclass = c("Sym", "character")) { as.character.Sym <- function(x, ...) as.character(unclass(x)) -Ops.Sym <- function (e1, e2) - if (missing(e2)) { Sym(.Generic, e1) - } else Sym(e1, .Generic, e2) - -Math.Sym <- function(x, ...) { - idx <- match(.Generic, transtab[,1], nomatch = 0) - fn <- if (idx > 0) transtab[idx, 3] else .Generic - Sym(fn, "(", x, ")") -} - print.Sym <- function(x, ...) print(sympy(unclass(x), ...)) -deriv.Sym <- function(expr, name = "x", n = 1, ...) - Sym("diff(", expr, ", ", name, ",", n, ")") +deriv.Sym <- function(expr, name = sympySymbols(x), n = 1, ...) + Sym("diff(", expr, ", ", name[1], ",", n, ")") if (!isGenericS3("limit")) setGenericS3("limit") -limit.Sym <- function(expr, name = "x", value) - Sym("limit(", expr, ",", name, ",", value, ")") +limit.Sym <- function(expr, name = sympySymbols(x), value) + Sym("limit(", expr, ",", name[1], ",", value, ")") solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { stopifnot(missing(b)) @@ -38,7 +28,21 @@ solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { } if (!isGenericS3("integrate")) setGenericS3("integrate", dontWarn = "stats") -integrate.Sym <- function(x, ...) Sym("integrate(", paste(x, ..., sep = ","), ")") +integrate.Sym <- function(x, lower = NULL, upper = NULL, name = sympySymbols(x), ..., subdivisions = Inf, rel.tol = 0, abs.tol = 0, stop.on.error = TRUE, keep.xy = FALSE, aux = NULL) { + if (xor(is.numeric(lower), is.numeric(upper))) + stop("lower or upper must both be specified or both be unspecified") + if (!is.character(name) || length(name) == 0) + stop("name must be a string") + + # TODO: use named arguments ... to plug into other variables as constants + if (is.numeric(lower)) { # == is.numeric(upper) + # definite integral + Sym("integrate(", x, ",(", name[1], ",", lower[1], ",", upper[1], "))") + } else { + # indefinite integral + Sym("integrate(", x, ",", name[1], ")") + } +} t.Sym <- function(x) Sym(paste("(", x, ").transpose()")) diff --git a/R/sympy.R b/R/sympy.R index f74275a..f204c9c 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -14,6 +14,7 @@ sympyStart <- function() { pyExecp("from sympy import *") pyExecp("from sympy.printing.mathml import mathml") pyExecp("from sympy.utilities.lambdify import lambdify") + pyExecp("from sympy.functions.special.gamma_functions import *") assign('.SympyConnected', TRUE) } @@ -22,15 +23,23 @@ sympy <- function(..., retclass = c("character", "Sym"), debug = FALSE) { if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() retclass <- if (is.null(retclass)) NULL else match.arg(retclass) if (!is.null(retclass)) { - pyExec(paste("__Rsympy=None")) + pyExec("__Rsympy=None") pyExecp(paste("__Rsympy=", ..., sep = "")) if (debug) pyExecp("print(__Rsympy)") - pyExec(paste("__Rsympy = str(__Rsympy)")) + pyExec("__Rsympy = str(__Rsympy)") out <- pyGet("__Rsympy") if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") else out } else pyExecp(paste(...)) } +sympySymbols <- function(x, debug = FALSE) { + if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() + pyExec("__Rsympy=None") + pyExecp(paste("__Rsympy=", x, sep = "")) + if (debug) pyExecp("print(__Rsympy)") + pyExec("if isinstance(__Rsympy, Expr): __Rsympy = [str(x) for x in list(__Rsympy.atoms(Symbol))]\n") + pyGet("__Rsympy") +} From c1fb31a53efa283a19d937e6084393832dc6ed92 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Thu, 5 Nov 2015 16:33:14 -0500 Subject: [PATCH 05/20] Implement evalf(subs = ...) and lambdify() Expressions from SymPy can now be numerically computed. Overrides eval() and as.function() generic functions respectively. --- R/Sym.R | 65 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ R/sympy.R | 48 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 113 insertions(+) diff --git a/R/Sym.R b/R/Sym.R index c15fcc6..6038eff 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -44,6 +44,71 @@ integrate.Sym <- function(x, lower = NULL, upper = NULL, name = sympySymbols(x), } } +if (!isGenericS3("eval")) setGenericS3("eval", dontWarn = "base") +eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), retclass = c("character", "Sym")) { + atoms <- sympySymbols(x) + stopifnot(is.character(atoms)) + vals <- numeric(length(atoms)) + + # data frames are lists too + if (is.list(envir)) { + if (is.null(enclos)) enclos = baseenv() + + from.envir <- unlist(lapply(atoms, function(x) is.numeric(envir[[x]]))) + vals[from.envir] <- as.numeric(envir[atoms[from.envir]]) + names(vals)[from.envir] <- atoms[from.envir] + + from.envir <- !from.envir + envir <- enclos + } else { + from.envir <- rep(TRUE, length(atoms)) + } + + # search all symbols from: enclos if envir is a list, envir otherwise + atoms <- atoms[from.envir] + #stopifnot (all(unlist(lapply(atoms, exists, where = envir)))) + # without specifying `ifnotfound`, mget throws an exception if any symbol is not found + vals[from.envir] <- as.numeric(mget(atoms, envir = envir, mode = "numeric", inherits = TRUE)[atoms]) + names(vals)[from.envir] <- atoms + + sympyEvalf(x, vals, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) +} + +# AKA lambda(), turns an expression into an R function that can accept parameters +# TODO: if retclass is Sym, pass all numbers to sympy.core.numbers.Number __new__ +as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym")) { + atoms <- sympySymbols(x) + + if (is.null(param)) param <- atoms + stopifnot(is.character(param)) + + if (!isTRUE(all.equal(retclass, eval(formals()$retclass)))) { + # retclass is not set to default value. + retclass <- match.arg(retclass) + } else { + # retclass is set to the default value. + if (!all(atoms %in% param)) { + # not all free variables in x are bound. + # by default, lambda should output a Sym expression. + retclass <- "Sym" + } else { + # all variables are bound. + # by default, lambda should output a character. + retclass <- "character" + } + } + + f.param <- list() + length(f.param) <- length(param) + names(f.param) <- param + + lambda <- sympyLambdify(param, x) + f <- function() executeLambda(lambda, match.call(), retclass) + formals(f) <- as.pairlist(f.param) + + f +} + t.Sym <- function(x) Sym(paste("(", x, ").transpose()")) # static factories diff --git a/R/sympy.R b/R/sympy.R index f204c9c..9a2fe18 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -42,4 +42,52 @@ sympySymbols <- function(x, debug = FALSE) { pyGet("__Rsympy") } +sympyEvalf <- function(x, subs, retclass = c("character", "Sym", "expr")) { + if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() + pyDict("__Rsympy", subs, regFinalizer = FALSE) # immediately overwrite the dict so no need to del(__Rsympy) + pyExecp(paste("__Rsympy=(", x, ").evalf(subs = __Rsympy)", sep = "")) + if (!is.null(retclass)) { + if (retclass == "expr") { + pyExec("if isinstance(__Rsympy, Expr): __Rsympy = mathml(__Rsympy)\n") + out <- pyGet("__Rsympy") + # TODO: parse MathML + out + } else { + pyExec("__Rsympy = str(__Rsympy)") + out <- pyGet("__Rsympy") + if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") + else out + } + } else pyExecp("print(__Rsympy)") +} + +sympyLambdify <- function(args, expr) { + if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() + pyTuple("__Rsympy", args, regFinalizer = FALSE) # immediately overwrite the tuple so no need to del(__Rsympy) + pyExecp(paste("__Rsympy=lambdify(__Rsympy,", expr, ")", sep = "")) + pyFunction("__Rsympy") +} + +executeLambda <- function(fn, args, retclass) { + # redirect the call to the Python function handle + args[[1]] <- fn + # order of parameters matters, but formal parameter names don't matter + #args <- unname(args) + # execute the function call + result <- eval(args) + + if (!is.null(retclass)) { + if (retclass == "expr") { + out <- pyCall("mathml", result) + # TODO: parse MathML + out + } else { + out <- pyCall("str", result) + if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") + else out + } + } else pyCall("print", result) +} + + From 480b1f10e7294c1915b032421c27ba8660ec1817 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Thu, 5 Nov 2015 18:07:02 -0500 Subject: [PATCH 06/20] Fix default symbol for Sym methods Fix typos in limit() and deriv() for sympySymbols(). Support differentiation, integration, evaluation, and limit of Syms without any variables (i.e. unevaluated constants). Add stubs for parsing MathML expressions into native R. --- R/Sym.R | 24 +++++++++++++++++------- R/sympy.R | 17 ++++++++++++----- 2 files changed, 29 insertions(+), 12 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index 6038eff..afd94d6 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -1,7 +1,7 @@ # constructor -Sym <- function(..., retclass = c("Sym", "character")) { +Sym <- function(..., retclass = c("Sym", "character", "expr")) { args <- list(...) retclass <- match.arg(retclass) value <- if (length(args) > 1) paste("(", ..., ")") else paste(args[[1]]) @@ -9,17 +9,21 @@ Sym <- function(..., retclass = c("Sym", "character")) { value } +# helper functions + +coalesce <- function(x, def) if (mode(x) == mode(def) && length(x) > 0) x else def + # methods as.character.Sym <- function(x, ...) as.character(unclass(x)) print.Sym <- function(x, ...) print(sympy(unclass(x), ...)) -deriv.Sym <- function(expr, name = sympySymbols(x), n = 1, ...) +deriv.Sym <- function(expr, name = coalesce(sympySymbols(expr), "x"), n = 1, ...) Sym("diff(", expr, ", ", name[1], ",", n, ")") if (!isGenericS3("limit")) setGenericS3("limit") -limit.Sym <- function(expr, name = sympySymbols(x), value) +limit.Sym <- function(expr, name = coalesce(sympySymbols(expr), "x"), value) Sym("limit(", expr, ",", name[1], ",", value, ")") solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { @@ -28,7 +32,7 @@ solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { } if (!isGenericS3("integrate")) setGenericS3("integrate", dontWarn = "stats") -integrate.Sym <- function(x, lower = NULL, upper = NULL, name = sympySymbols(x), ..., subdivisions = Inf, rel.tol = 0, abs.tol = 0, stop.on.error = TRUE, keep.xy = FALSE, aux = NULL) { +integrate.Sym <- function(x, lower = NULL, upper = NULL, name = coalesce(sympySymbols(x), "x"), ..., subdivisions = Inf, rel.tol = 0, abs.tol = 0, stop.on.error = TRUE, keep.xy = FALSE, aux = NULL) { if (xor(is.numeric(lower), is.numeric(upper))) stop("lower or upper must both be specified or both be unspecified") if (!is.character(name) || length(name) == 0) @@ -45,8 +49,12 @@ integrate.Sym <- function(x, lower = NULL, upper = NULL, name = sympySymbols(x), } if (!isGenericS3("eval")) setGenericS3("eval", dontWarn = "base") -eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), retclass = c("character", "Sym")) { +eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is.pairlist(envir)) parent.frame() else baseenv(), retclass = c("character", "Sym", "expr")) { atoms <- sympySymbols(x) + if (is.numeric(atoms)) atoms <- NULL + if (length(atoms) == 0) + return(sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass))) + stopifnot(is.character(atoms)) vals <- numeric(length(atoms)) @@ -76,7 +84,7 @@ eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is # AKA lambda(), turns an expression into an R function that can accept parameters # TODO: if retclass is Sym, pass all numbers to sympy.core.numbers.Number __new__ -as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym")) { +as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym", "expr")) { atoms <- sympySymbols(x) if (is.null(param)) param <- atoms @@ -109,11 +117,13 @@ as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym")) { f } +as.expression.Sym <- function(x) sympy(unclass(x), retclass = "expr") + t.Sym <- function(x) Sym(paste("(", x, ").transpose()")) # static factories -Var <- function(x, retclass = c("Sym", "character")) { +Var <- function(x, retclass = c("Sym", "character", "expr")) { x <- paste("var('", x, "')", sep = "") sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) } diff --git a/R/sympy.R b/R/sympy.R index 9a2fe18..c1d1275 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -19,17 +19,24 @@ sympyStart <- function() { assign('.SympyConnected', TRUE) } -sympy <- function(..., retclass = c("character", "Sym"), debug = FALSE) { +sympy <- function(..., retclass = c("character", "Sym", "expr"), debug = FALSE) { if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() retclass <- if (is.null(retclass)) NULL else match.arg(retclass) if (!is.null(retclass)) { pyExec("__Rsympy=None") pyExecp(paste("__Rsympy=", ..., sep = "")) if (debug) pyExecp("print(__Rsympy)") - pyExec("__Rsympy = str(__Rsympy)") - out <- pyGet("__Rsympy") - if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") - else out + if (retclass == "expr") { + pyExec("if isinstance(__Rsympy, Expr): __Rsympy = mathml(__Rsympy)\n") + out <- pyGet("__Rsympy") + # TODO: parse MathML + out + } else { + pyExec("__Rsympy = str(__Rsympy)") + out <- pyGet("__Rsympy") + if (!is.null(out) && retclass == "Sym") structure(out, class = "Sym") + else out + } } else pyExecp(paste(...)) } From 3f69a6a573ba26be371f3194e5b015fa61f074f2 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Fri, 6 Nov 2015 10:22:34 -0500 Subject: [PATCH 07/20] Implement sum(), prod(), min(), max() Sym methods Fix sympySymbols() to ignore dummy variables in e.g. summations, products, integrals. Fix eval.Sym() not simplifying any summations, products, integrals when there are no free symbols remaining. --- R/Sym.GroupGenericFuncs.R | 20 ++++++++++++++++---- R/Sym.R | 4 ++-- R/sympy.R | 16 +++++++++++++--- 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/R/Sym.GroupGenericFuncs.R b/R/Sym.GroupGenericFuncs.R index 60c5d2d..75d7d83 100644 --- a/R/Sym.GroupGenericFuncs.R +++ b/R/Sym.GroupGenericFuncs.R @@ -38,10 +38,22 @@ cummin.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", se # Summary.Sym group generic overrides all.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) any.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) -sum.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) -prod.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) -min.Sym <- function(x, na.rm = FALSE) Sym("Min(", x, ")") -max.Sym <- function(x, na.rm = FALSE) Sym("Max(", x, ")") +sum.Sym <- function(x, lower, upper, name = coalesce(sympySymbols(x), "x"), ...) { + if (!is.numeric(lower) || !is.numeric(upper)) + stop("lower and upper must both be specified") + + # TODO: use named arguments ... to plug into other variables as constants + Sym("Sum(", x, ",(", name[1], ",", lower[1], ",", upper[1], "))") +} +prod.Sym <- function(x, lower, upper, name = coalesce(sympySymbols(x), "x"), ...) { + if (!is.numeric(lower) || !is.numeric(upper)) + stop("lower and upper must both be specified") + + # TODO: use named arguments ... to plug into other variables as constants + Sym("Product(", x, ",(", name[1], ",", lower[1], ",", upper[1], "))") +} +min.Sym <- function(..., na.rm = FALSE) Sym("Min(", paste(..., sep = ","), ")") +max.Sym <- function(..., na.rm = FALSE) Sym("Max(", paste(..., sep = ","), ")") range.Sym <- function(x) stop(paste(match.call()[[1]], "() not implemented", sep = "")) # Complex.Sym group generic overrides diff --git a/R/Sym.R b/R/Sym.R index afd94d6..9a68b05 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -34,7 +34,7 @@ solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { if (!isGenericS3("integrate")) setGenericS3("integrate", dontWarn = "stats") integrate.Sym <- function(x, lower = NULL, upper = NULL, name = coalesce(sympySymbols(x), "x"), ..., subdivisions = Inf, rel.tol = 0, abs.tol = 0, stop.on.error = TRUE, keep.xy = FALSE, aux = NULL) { if (xor(is.numeric(lower), is.numeric(upper))) - stop("lower or upper must both be specified or both be unspecified") + stop("lower and upper must both be specified or both be unspecified") if (!is.character(name) || length(name) == 0) stop("name must be a string") @@ -53,7 +53,7 @@ eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is atoms <- sympySymbols(x) if (is.numeric(atoms)) atoms <- NULL if (length(atoms) == 0) - return(sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass))) + return(sympyEvalf(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass))) stopifnot(is.character(atoms)) vals <- numeric(length(atoms)) diff --git a/R/sympy.R b/R/sympy.R index c1d1275..2c3ecfd 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -12,6 +12,7 @@ sympyStart <- function() { pyExecp("import sys") pyExecp( paste( "sys.path.append(", system.file( "Lib", package = "rSymPy" ), ")", sep = '"' ) ) pyExecp("from sympy import *") + pyExecp("from sympy.mpmath import *") pyExecp("from sympy.printing.mathml import mathml") pyExecp("from sympy.utilities.lambdify import lambdify") pyExecp("from sympy.functions.special.gamma_functions import *") @@ -40,19 +41,28 @@ sympy <- function(..., retclass = c("character", "Sym", "expr"), debug = FALSE) } else pyExecp(paste(...)) } +# if the returned value is.numeric, then there are no free symbols in x sympySymbols <- function(x, debug = FALSE) { if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() pyExec("__Rsympy=None") pyExecp(paste("__Rsympy=", x, sep = "")) if (debug) pyExecp("print(__Rsympy)") - pyExec("if isinstance(__Rsympy, Expr): __Rsympy = [str(x) for x in list(__Rsympy.atoms(Symbol))]\n") + pyExec("if isinstance(__Rsympy, Expr): __Rsympy = [str(x) for x in list(__Rsympy.free_symbols)]\n") + # PythonInR bug "IndexError: list index out of range" when pyGet an empty list + pyExec("if len(__Rsympy) == 0: __Rsympy = [-1]\n") pyGet("__Rsympy") } sympyEvalf <- function(x, subs, retclass = c("character", "Sym", "expr")) { if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() - pyDict("__Rsympy", subs, regFinalizer = FALSE) # immediately overwrite the dict so no need to del(__Rsympy) - pyExecp(paste("__Rsympy=(", x, ").evalf(subs = __Rsympy)", sep = "")) + if (!missing(subs) && is.numeric(subs)) { + pyDict("__Rsympy", subs, regFinalizer = FALSE) # immediately overwrite the dict so no need to del(__Rsympy) + pyExecp(paste("__Rsympy=(", x, ").evalf(subs = __Rsympy)", sep = "")) + } else { + pyExec("__Rsympy = None") + pyExecp(paste("__Rsympy=(", x, ").evalf()", sep = "")) + } + retclass <- if (is.null(retclass)) NULL else match.arg(retclass) if (!is.null(retclass)) { if (retclass == "expr") { pyExec("if isinstance(__Rsympy, Expr): __Rsympy = mathml(__Rsympy)\n") From 2dceeee907cac294f550dd8cfe5581ffd21895ec Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Fri, 6 Nov 2015 10:27:20 -0500 Subject: [PATCH 08/20] Implement as.Sym() and fix as.function.Sym() Eliminate need to manually call Var() on all undeclared symbols. E.g. if x and y are not defined in the current scope and z == 5, then as.Sym(x + deriv(y) + z) is equivalent to (Var('x') + deriv(Var('y')) + 5). The lambda returned by as.function.Sym() no longer provides defaults for formal arguments. Fix logical error in as.function.Sym() when x requires no variables. --- R/Sym.R | 39 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 37 insertions(+), 2 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index 9a68b05..e515cd8 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -86,6 +86,7 @@ eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is # TODO: if retclass is Sym, pass all numbers to sympy.core.numbers.Number __new__ as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym", "expr")) { atoms <- sympySymbols(x) + if (is.numeric(atoms)) atoms <- NULL if (is.null(param)) param <- atoms stopifnot(is.character(param)) @@ -106,14 +107,17 @@ as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym", "e } } - f.param <- list() - length(f.param) <- length(param) + # getting the empty symbol (for formal arguments with no default value) is + # a bit hacky since as.name("") does not work + f.param <- rep(c(quote(f(emptyname=))$emptyname), length(param)) names(f.param) <- param lambda <- sympyLambdify(param, x) f <- function() executeLambda(lambda, match.call(), retclass) formals(f) <- as.pairlist(f.param) + #reg.finalizer(environment(), function(obj) { str(f); str(obj); }) + f } @@ -123,6 +127,37 @@ t.Sym <- function(x) Sym(paste("(", x, ").transpose()")) # static factories +as.Sym <- function(x) { + # basically equivalent to x <- quote() + # from the caller's context + x <- substitute(x) + + # in case the expr x makes reference to variables + # named e.g. x, env, unknown.symbols, or vars, we want + # to prevent this function's local variables from + # being improperly substituted into the passed expr x + env <- parent.frame() + + # call objects can be recursively descended to get constants and names + unknown.symbols <- (f <- function(x) { + if (is.name(x)) # symbols + # eval() uses the same environment + if (!exists(as.character(x), where = env)) x else NULL + else if (!is.call(x)) # constants + # constants by definition are already known + NULL + else # nested function call/operator + # x[-1] to skip the function name. ignore unknown functions + unlist(lapply(x[-1], f)) + })(x) + + # substitute in those unknown symbols in x with declared SymPy symbols + vars <- unlist(lapply(unknown.symbols, as.character)) + vars <- setNames(lapply(vars, Var), vars) + + eval(x, envir = vars, enclos = env) +} + Var <- function(x, retclass = c("Sym", "character", "expr")) { x <- paste("var('", x, "')", sep = "") sympy(x, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) From 93f8d0ac01b38c5d82a0ab2dd88f4d28badf795a Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Fri, 6 Nov 2015 10:38:35 -0500 Subject: [PATCH 09/20] Version bump Add myself to authors. --- DESCRIPTION | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2123aa4..4304ee9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,9 @@ Package: rSymPy -Version: 0.2-1.1 -Date: 2010-07-31 +Version: 0.3-1 +Date: 2015-11-06 Title: R interface to SymPy computer algebra system Author: G Grothendieck (SymPy itself is by Ondrej Certik and others), + Kevin Jin, Contributors: Carlos J. Gil Bellosta Maintainer: G Grothendieck Description: Access SymPy computer algebra system from R via Jython From 4711e7ab9a71809eb6789d70503368076d829e21 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Fri, 6 Nov 2015 11:02:18 -0500 Subject: [PATCH 10/20] Fix error with deriv() Do not import mpmath because its diff() function overwrites SymPy's. --- R/sympy.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/sympy.R b/R/sympy.R index 2c3ecfd..8081eb9 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -12,7 +12,6 @@ sympyStart <- function() { pyExecp("import sys") pyExecp( paste( "sys.path.append(", system.file( "Lib", package = "rSymPy" ), ")", sep = '"' ) ) pyExecp("from sympy import *") - pyExecp("from sympy.mpmath import *") pyExecp("from sympy.printing.mathml import mathml") pyExecp("from sympy.utilities.lambdify import lambdify") pyExecp("from sympy.functions.special.gamma_functions import *") From 1598dbb75c9c39caeb4917bf0be3f4e7c25a0305 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Sun, 8 Nov 2015 10:54:38 -0500 Subject: [PATCH 11/20] More robust as.Sym() Fix problems when passing in just a single variable name to as.Sym(), without any function calls or operations. Fix overwriting of variables already declared in Python but not in R. If both R and Python variables exist, the R variable has precedence. Only when a variable does not exist in both R and Python do we call var('x') in Python. Fix passing of Inf and NaN to SymPy. Any functions that are not recognized in R are passed through to Python with the function name intact. Ensure that as.Sym() wraps even constant expressions with the Sym class. --- R/Sym.R | 91 +++++++++++++++++++++++++++++++++++++++++++++++++------ R/sympy.R | 6 ++++ 2 files changed, 87 insertions(+), 10 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index e515cd8..da991fa 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -138,24 +138,95 @@ as.Sym <- function(x) { # being improperly substituted into the passed expr x env <- parent.frame() - # call objects can be recursively descended to get constants and names - unknown.symbols <- (f <- function(x) { + if (!is.call(x)) + # no operations or function calls, just a single variable or constant + x <- as.call(list(quote(`identity`), x)) + + # call objects can be recursively descended to get constants and names. + # if a variable exists in R, use the value in the R variable. + # if a variable exists only in Python, use the value in the Python variable. + # otherwise, call Var() to create a new Python variable. + to.replace <- (f <- function(x) { if (is.name(x)) # symbols - # eval() uses the same environment - if (!exists(as.character(x), where = env)) x else NULL + if (exists(as.character(x), where = env)) + # Substitute in R variable that exists in the caller's context + NULL + else if (pythonHasVariable(as.character(x))) + # Sym(x): no R variable, but use the Python variable + as.character(x) + else + # Var(x): create a Python symbol + x else if (!is.call(x)) # constants - # constants by definition are already known - NULL + if (is.nan(x)) + # Python uses nan for not-a-number + "nan" + else if (x == Inf) + # SymPy represents infinity as two lowercase `o`s + "oo" + else + # constants by definition are already known + NULL else # nested function call/operator - # x[-1] to skip the function name. ignore unknown functions - unlist(lapply(x[-1], f)) + if (!exists(as.character(x), where = env)) + # x[-1] to skip the function name + c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f), 2:length(x)))) + else + # x[-1] to skip the function name + unlist(setNames(lapply(x[-1], f), 2:length(x))) })(x) - # substitute in those unknown symbols in x with declared SymPy symbols + if (!is.list(to.replace)) + # characters only + to.replace <- as.list(to.replace) + + # in the case of passing through functions to SymPy, reversing the list + # substitutes innermost function calls first, so addresses are not messed up + # for outermost function calls + to.replace <- rev(to.replace) + + # pass-through literal Python symbols not found in R + unknown.symbols <- as.logical(unlist(lapply(to.replace, is.name))) + # because of copy-on-write and scoping issues when trying to modify a value + # in x inside another function, just keep carrying x-prime forward to the + # next transform and finally return the final image (thus Reduce()) + x <- Reduce(function(x, name) { + # unlist() set names of nested lists [[i]][[j]][[k]] to "i.j.k" + address <- as.numeric(unlist(strsplit(name, ".", fixed = TRUE))) + # first child of any parent must be a function name + stopifnot(tail(address, 1) != 1 || length(x) == 1) + # creates an expression to access e.g. x[[3]][[2]] when address==c(3,2) + deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), address, quote(x)) + # finally, assign our replacement string to e.g. x[[3]][[2]] + eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), to.replace[[name]])))))) + # carry the transformed x to the next transformation function + x + }, names(to.replace)[!is.na(to.replace) & !unknown.symbols], x) + + # declare SymPy symbols for symbols not found in R or Python, and plug them in R + unknown.symbols <- to.replace[unknown.symbols] vars <- unlist(lapply(unknown.symbols, as.character)) vars <- setNames(lapply(vars, Var), vars) - eval(x, envir = vars, enclos = env) + # pass through function names that aren't implemented in R to SymPy + x <- Reduce(function(x, name) { + # unlist() set names of nested lists [[i]][[j]][[k]] to "i.j.k" + address <- as.numeric(unlist(strsplit(name, ".", fixed = TRUE))) + # first child of any parent must be a function name + stopifnot(tail(address, 1) == 1) + # go to container for function call + deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), head(address, -1), quote(x)) + # get the function name + fn.name <- eval(deref)[[1]] + # get all right siblings (parameters to function) + arguments <- lapply(eval(deref)[-1], eval, envir = vars, enclos = env) + # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") + eval(as.call(list(quote(`<-`), deref, quote(as.call(c(list(quote(Sym), as.character(fn.name), "("), arguments, list(")"))))))) + # carry the transformed x to the next transformation function + x + }, names(to.replace)[is.na(to.replace)], x) + + Sym(eval.default(x, envir = vars, enclos = env)) } Var <- function(x, retclass = c("Sym", "character", "expr")) { diff --git a/R/sympy.R b/R/sympy.R index 8081eb9..efb7fe7 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -105,5 +105,11 @@ executeLambda <- function(fn, args, retclass) { } else pyCall("print", result) } +pythonHasVariable <- function(x) { + pySet("__Rsympy", x) + pyExec("__Rsympy = __Rsympy in locals() or __Rsympy in globals()") + pyGet("__Rsympy") +} + From 4708d199aac9453b62f6af4320e5aec23ef1aeff Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Wed, 10 Feb 2016 01:37:50 -0500 Subject: [PATCH 12/20] Fix sum.Sym(), prod.Sym(), and as.Sym() sum.Sym() and prod.Sym() simplify the sums and products. deriv.Sym(), limit.Sym(), and integrate.Sym() updated to use a similar form. Implement variable assignment in as.Sym(). Implement named arguments in wrapped functions in as.Sym(). Fix as.Sym() improperly wrapping functions with multiple arguments. Fix as.Sym() improperly wrapping string constants. Use .onLoad() and .onUnload() hooks instead of calls to an initialization function in all functions in sympy.R. Add code stubs for future features. --- R/Sym.GroupGenericFuncs.R | 7 ++-- R/Sym.R | 67 +++++++++++++++++++++++++++++++++------ R/sympy.R | 22 +++++++++---- 3 files changed, 76 insertions(+), 20 deletions(-) diff --git a/R/Sym.GroupGenericFuncs.R b/R/Sym.GroupGenericFuncs.R index 75d7d83..23424a3 100644 --- a/R/Sym.GroupGenericFuncs.R +++ b/R/Sym.GroupGenericFuncs.R @@ -43,14 +43,14 @@ sum.Sym <- function(x, lower, upper, name = coalesce(sympySymbols(x), "x"), ...) stop("lower and upper must both be specified") # TODO: use named arguments ... to plug into other variables as constants - Sym("Sum(", x, ",(", name[1], ",", lower[1], ",", upper[1], "))") + Sym("Sum(", x, ",(", name[1], ",", lower[1], ",", upper[1], ")).doit()") } prod.Sym <- function(x, lower, upper, name = coalesce(sympySymbols(x), "x"), ...) { if (!is.numeric(lower) || !is.numeric(upper)) stop("lower and upper must both be specified") # TODO: use named arguments ... to plug into other variables as constants - Sym("Product(", x, ",(", name[1], ",", lower[1], ",", upper[1], "))") + Sym("Product(", x, ",(", name[1], ",", lower[1], ",", upper[1], ")).doit()") } min.Sym <- function(..., na.rm = FALSE) Sym("Min(", paste(..., sep = ","), ")") max.Sym <- function(..., na.rm = FALSE) Sym("Max(", paste(..., sep = ","), ")") @@ -62,6 +62,3 @@ Conj.Sym <- function(x) Sym("conjugate(", x, ")") Im.Sym <- function(x) Sym("im(", x, ")") Mod.Sym <- function(x) abs(x) Re.Sym <- function(x) Sym("re(", x, ")") - -# TODO: autogenerate wrappers with setGenericS3() for all functions in http://docs.sympy.org/dev/modules/functions/index.html#contents -# that are not in transtab[, 3] and do not have a method named "xxx.Sym" diff --git a/R/Sym.R b/R/Sym.R index da991fa..9f79574 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -20,11 +20,11 @@ as.character.Sym <- function(x, ...) as.character(unclass(x)) print.Sym <- function(x, ...) print(sympy(unclass(x), ...)) deriv.Sym <- function(expr, name = coalesce(sympySymbols(expr), "x"), n = 1, ...) - Sym("diff(", expr, ", ", name[1], ",", n, ")") + Sym("Derivative(", expr, ", ", name[1], ",", n, ").doit()") if (!isGenericS3("limit")) setGenericS3("limit") limit.Sym <- function(expr, name = coalesce(sympySymbols(expr), "x"), value) - Sym("limit(", expr, ",", name[1], ",", value, ")") + Sym("Limit(", expr, ",", name[1], ",", value, ").doit()") solve.Sym <- function(a, b, method = c("'GE'", "'ADJ'", "'LU'"), ...) { stopifnot(missing(b)) @@ -41,11 +41,18 @@ integrate.Sym <- function(x, lower = NULL, upper = NULL, name = coalesce(sympySy # TODO: use named arguments ... to plug into other variables as constants if (is.numeric(lower)) { # == is.numeric(upper) # definite integral - Sym("integrate(", x, ",(", name[1], ",", lower[1], ",", upper[1], "))") + Sym("Integral(", x, ",(", name[1], ",", lower[1], ",", upper[1], ")).doit()") } else { # indefinite integral - Sym("integrate(", x, ",", name[1], ")") + Sym("Integral(", x, ",", name[1], ").doit()") } + + # TODO: if analytic integration fails, do numeric integration with quad() +} + +# CDF +pnorm.Sym <- function() { + } if (!isGenericS3("eval")) setGenericS3("eval", dontWarn = "base") @@ -82,6 +89,19 @@ eval.Sym <- function(x, envir = parent.frame(), enclos = if(is.list(envir) || is sympyEvalf(x, vals, retclass = if (is.null(retclass)) NULL else match.arg(retclass)) } +# if (!isGenericS3("substitute")) setGenericS3("substitute", dontWarn = "base") +# substitute.Sym <- function(expr, env = parent.frame()) { +# # TODO: same as eval() but calls subs() function on expr instead of evalf() +# } + +if (!isGenericS3("solve")) setGenericS3("solve", dontWarn = "base") +solve.Sym <- function(x, y) { + # "try:solve(x,y) or None\nexcept(NotImplementedError):None\n" + # "if x != None: return x\n" + # "try:nsolve(x,y,0) or None\nexcept(ValueError):None\n" + # "if x == None: return x" +} + # AKA lambda(), turns an expression into an R function that can accept parameters # TODO: if retclass is Sym, pass all numbers to sympy.core.numbers.Number __new__ as.function.Sym <- function(x, param = NULL, retclass = c("character", "Sym", "expr")) { @@ -127,6 +147,8 @@ t.Sym <- function(x) Sym(paste("(", x, ").transpose()")) # static factories +# TODO: replace `==`(a,b) with Eq(a,b) when (isinstance(a, Basic) || isinstance(b, Basic)) +# i.e. a or b is an expression that is some subclass of sympy.core.basic.Basic as.Sym <- function(x) { # basically equivalent to x <- quote() # from the caller's context @@ -142,6 +164,12 @@ as.Sym <- function(x) { # no operations or function calls, just a single variable or constant x <- as.call(list(quote(`identity`), x)) + assign.to <- NULL + if (as.character(x[[1]]) == "<-") { + assign.to <- as.character(x[[2]]) + x <- x[[3]] + } + # call objects can be recursively descended to get constants and names. # if a variable exists in R, use the value in the R variable. # if a variable exists only in Python, use the value in the Python variable. @@ -168,7 +196,10 @@ as.Sym <- function(x) { # constants by definition are already known NULL else # nested function call/operator - if (!exists(as.character(x), where = env)) + if (as.character(x[[1]]) == "<-") + # Python assignments are statements, not expressions + stop("Assignments are allowed only at the top level") + else if (!exists(as.character(x[[1]]), where = env)) # x[-1] to skip the function name c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f), 2:length(x)))) else @@ -216,17 +247,35 @@ as.Sym <- function(x) { stopifnot(tail(address, 1) == 1) # go to container for function call deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), head(address, -1), quote(x)) + deref.evaled <- eval(deref) # get the function name - fn.name <- eval(deref)[[1]] + fn.name <- deref.evaled[[1]] # get all right siblings (parameters to function) - arguments <- lapply(eval(deref)[-1], eval, envir = vars, enclos = env) + arguments <- setNames(lapply(deref.evaled[-1], eval, envir = vars, enclos = env), names(deref.evaled)[-1]) + # prepend argument values with argument names + named.arguments <- names(arguments) != "" + arguments[named.arguments] <- paste(names(arguments)[named.arguments], arguments[named.arguments], sep = "=") + # quote strings + arguments <- lapply(arguments, function(arg) + if (is.character(arg) && !any(class(arg) == 'Sym')) + # R's escape sequences map directly to Python unicode strings, + # except for "\`" because backtick are not quotes in Python, + # but this doesn't matter since encodeString() quotes with "\"". + paste("u", encodeString(arg, quote = "\""), sep = "") + else + arg + ) # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") - eval(as.call(list(quote(`<-`), deref, quote(as.call(c(list(quote(Sym), as.character(fn.name), "("), arguments, list(")"))))))) + eval(as.call(list(quote(`<-`), deref, quote(as.call(c(list(quote(Sym), as.character(fn.name), "("), paste(arguments, collapse = ","), list(")"))))))) # carry the transformed x to the next transformation function x }, names(to.replace)[is.na(to.replace)], x) - Sym(eval.default(x, envir = vars, enclos = env)) + output <- eval.default(x, envir = vars, enclos = env) + if (!is.null(assign.to)) + output <- Sym(paste(assign.to, "=", output)) + + output } Var <- function(x, retclass = c("Sym", "character", "expr")) { diff --git a/R/sympy.R b/R/sympy.R index efb7fe7..48a2358 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -1,5 +1,9 @@ -sympyStart <- function() { +# R is fundamentally single threaded, so we don't have to make anything thread +# local or surround assignments and retrievals of __Rsympy in atomic blocks + +.onLoad <- function(libname, pkgname) { + if (exists(".SympyConnected", .GlobalEnv)) return() # like system.file but on Windows uses \ in path rather than / system.file. <- function(...) { @@ -12,15 +16,24 @@ sympyStart <- function() { pyExecp("import sys") pyExecp( paste( "sys.path.append(", system.file( "Lib", package = "rSymPy" ), ")", sep = '"' ) ) pyExecp("from sympy import *") + pyExecp("from sympy.stats import *") + pyExecp("from sympy.solvers import nsolve") pyExecp("from sympy.printing.mathml import mathml") pyExecp("from sympy.utilities.lambdify import lambdify") pyExecp("from sympy.functions.special.gamma_functions import *") - assign('.SympyConnected', TRUE) + invisible(assign('.SympyConnected', TRUE, pos = .GlobalEnv)) +} + +.onUnload <- function(libname, pkgname) { + if (!exists(".SympyConnected", .GlobalEnv)) return() + + if (pyIsConnected()) pyExit() + + invisible(remove('.SympyConnected', pos = .GlobalEnv)) } sympy <- function(..., retclass = c("character", "Sym", "expr"), debug = FALSE) { - if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() retclass <- if (is.null(retclass)) NULL else match.arg(retclass) if (!is.null(retclass)) { pyExec("__Rsympy=None") @@ -42,7 +55,6 @@ sympy <- function(..., retclass = c("character", "Sym", "expr"), debug = FALSE) # if the returned value is.numeric, then there are no free symbols in x sympySymbols <- function(x, debug = FALSE) { - if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() pyExec("__Rsympy=None") pyExecp(paste("__Rsympy=", x, sep = "")) if (debug) pyExecp("print(__Rsympy)") @@ -53,7 +65,6 @@ sympySymbols <- function(x, debug = FALSE) { } sympyEvalf <- function(x, subs, retclass = c("character", "Sym", "expr")) { - if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() if (!missing(subs) && is.numeric(subs)) { pyDict("__Rsympy", subs, regFinalizer = FALSE) # immediately overwrite the dict so no need to del(__Rsympy) pyExecp(paste("__Rsympy=(", x, ").evalf(subs = __Rsympy)", sep = "")) @@ -78,7 +89,6 @@ sympyEvalf <- function(x, subs, retclass = c("character", "Sym", "expr")) { } sympyLambdify <- function(args, expr) { - if (!exists(".SympyConnected", .GlobalEnv)) sympyStart() pyTuple("__Rsympy", args, regFinalizer = FALSE) # immediately overwrite the tuple so no need to del(__Rsympy) pyExecp(paste("__Rsympy=lambdify(__Rsympy,", expr, ")", sep = "")) pyFunction("__Rsympy") From 545cc10668a26bb2853314e18fbbd13a5e6fceb2 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Wed, 10 Feb 2016 19:35:18 -0500 Subject: [PATCH 13/20] Handle complex numbers, Dates, datediffs, and 'POSIXt's as.Sym() converts R objects of class complex, Date, datediff, POSIXlt, POSIXct into the equivalent Python objects. as.Sym() converts R keyword literals NULL, NA, TRUE, FALSE into the equivalent Python keyword literals. as.Sym() no longer fails if calling a Python function that takes no arguments. pyGet() converts Python objects of the class complex, date, timedelta, datetime, and time into the equivalent R objects. pyGet() converts Python lists by recursive calls to pyGet() and simplifies mixed int/double lists into numeric vectors. --- R/Sym.R | 42 +++++++++++++++++++++------ R/sympy.R | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 118 insertions(+), 9 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index 9f79574..838fd28 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -186,12 +186,23 @@ as.Sym <- function(x) { # Var(x): create a Python symbol x else if (!is.call(x)) # constants - if (is.nan(x)) - # Python uses nan for not-a-number + if (is.null(x) || is.na(x)) + # Python uses None for NULL + "None" + else if (is.nan(x)) + # Python uses float("nan") for not-a-number + #"float(\"NaN\")" "nan" - else if (x == Inf) - # SymPy represents infinity as two lowercase `o`s + else if (is.infinite(x)) + # Python uses float("inf") for positive infinity + #"float(\"Inf\")" "oo" + else if (identical(x, TRUE)) + # Python uses camel case booleans + "True" + else if (identical(x, FALSE)) + # Python uses camel case booleans + "False" else # constants by definition are already known NULL @@ -201,10 +212,10 @@ as.Sym <- function(x) { stop("Assignments are allowed only at the top level") else if (!exists(as.character(x[[1]]), where = env)) # x[-1] to skip the function name - c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f), 2:length(x)))) + c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f), if (length(x) > 1) 2:length(x) else c()))) else # x[-1] to skip the function name - unlist(setNames(lapply(x[-1], f), 2:length(x))) + unlist(setNames(lapply(x[-1], f), if (length(x) > 1) 2:length(x) else c())) })(x) if (!is.list(to.replace)) @@ -255,14 +266,27 @@ as.Sym <- function(x) { # prepend argument values with argument names named.arguments <- names(arguments) != "" arguments[named.arguments] <- paste(names(arguments)[named.arguments], arguments[named.arguments], sep = "=") - # quote strings arguments <- lapply(arguments, function(arg) - if (is.character(arg) && !any(class(arg) == 'Sym')) + if (inherits(arg, "Date")) + # create datetime.date instance + Sym("date(", as.integer(format(arg, "%Y")), ",", as.integer(format(arg, "%m")), ",", as.integer(format(arg, "%d")), ")") + else if (inherits(arg, "POSIXt")) + # create datetime.datetime instance + Sym("datetime(", (arg <- as.POSIXlt(arg))$year + 1900, ",", arg$mon + 1, ",", arg$mday, ",", arg$hour, ",", arg$min, ",", trunc(arg$sec), ",", round((arg$sec %% 1) * 1000000), if (!is.null(arg$gmtoff)) paste(",timezone(timedelta(seconds = ", arg$gmtoff, "))") else "", ")") + else if (inherits(arg, "difftime")) + # create datetime.timedelta instance + Sym("timedelta(0,", as.double(arg, units = "secs"), ")") + else if (is.complex(arg)) + # R formats with a+bi. Python formats with a+bj. + Sym(paste(Re(arg), "+", Im(arg), "j", sep = "")) + else if (is.character(arg) && !any(class(arg) == 'Sym')) + # quote strings # R's escape sequences map directly to Python unicode strings, # except for "\`" because backtick are not quotes in Python, # but this doesn't matter since encodeString() quotes with "\"". - paste("u", encodeString(arg, quote = "\""), sep = "") + Sym(paste("u", encodeString(arg, quote = "\""), sep = "")) else + # pass-through arg ) # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") diff --git a/R/sympy.R b/R/sympy.R index 48a2358..5a045de 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -14,6 +14,7 @@ if (!pyIsConnected()) pyConnect() pyExecp("import sys") + pyExecp("from datetime import *") pyExecp( paste( "sys.path.append(", system.file( "Lib", package = "rSymPy" ), ")", sep = '"' ) ) pyExecp("from sympy import *") pyExecp("from sympy.stats import *") @@ -33,6 +34,90 @@ invisible(remove('.SympyConnected', pos = .GlobalEnv)) } +pyGetPoly <- PythonInR:::pyGetPoly +setMethod("pyGetPoly", signature(key = "character", autoTypecast = "logical", simplify = "logical", pyClass = "complex"), function(key, autoTypecast, simplify, pyClass) + do.call(complex, as.list(pyExecg(sprintf("%s = [1, (%s).real, (%s).imag]", paste(key, "0", sep = ""), key, key))[[paste(key, "0", sep = "")]])) +) + +setMethod("pyGetPoly", signature(key = "character", autoTypecast = "logical", simplify = "logical", pyClass = "list"), function(key, autoTypecast, simplify, pyClass) { + is.scalar <- function(cond) return(function(x) length(x) == 1 && cond(x)) + homogenous <- function(x) all((type <- unlist(lapply(x, mode)))[1] == type) + list.is <- function(x, cond) all(unlist(lapply(x, cond))) + + # Not sure why pyGetPoly() call doesn't cause infinite recursion, but it + # doesn't, so it's a good way to call the super() method pyGetSimple()! + base <- pyGetPoly(key, autoTypecast, simplify, "list") + if (length(base) > 0) { + non.numeric <- !unlist(lapply(base, is.scalar(is.numeric))) + base[non.numeric] <- lapply(which(non.numeric) - 1, function(i) { + pyExecp(sprintf("%s = (%s)[%d]", paste(key, "0", sep = ""), key, i)) + pyGet(paste(key, "0", sep = ""), autoTypecast, simplify) + }) + if (simplify && list.is(base, is.scalar(is.vector)) && homogenous(base)) + base <- unlist(base) + } + base +}) + +timedelta.to.difftime <- function(pyObj) + as.difftime(pyObj$days, units = "days") + as.difftime(pyObj$seconds + pyObj$microseconds / 1000000, units = "secs") + +set.time <- function(pyObj) { + tz.name <- pyObj$tzname() + if (!is.null(tz.name)) + rObj <- as.POSIXlt(Sys.time(), tz = tz.name) + else + rObj <- as.POSIXlt(Sys.time()) + tz.offset <- pyObj$utcoffset() + if (!is.null(tz.offset)) + rObj$gmtoff <- as.double(timedelta.to.difftime(tz.offset), units = "secs") + + rObj$hour <- pyObj$hour + rObj$min <- pyObj$minute + rObj$sec <- pyObj$second + pyObj$microsecond / 1000000 + rObj +} + +setClass("datetime") +setMethod("pyGetPoly", signature(key = "character", autoTypecast = "logical", simplify = "logical", pyClass = "datetime"), function(key, autoTypecast, simplify, pyClass) { + pyObj <- pyGetPoly(key, autoTypecast, simplify, "datetime") + # See PythonInR::pyTransformReturn() + pyObj <- pyObject(sprintf("__R__.namespace[%i]", pyObj$id)) + rObj <- set.time(pyObj) + rObj$year <- pyObj$year - 1900 + rObj$mon <- pyObj$month - 1 + rObj$mday <- pyObj$day + rObj +}) + +setClass("time") +setMethod("pyGetPoly", signature(key = "character", autoTypecast = "logical", simplify = "logical", pyClass = "time"), function(key, autoTypecast, simplify, pyClass) { + pyObj <- pyGetPoly(key, autoTypecast, simplify, "time") + # See PythonInR::pyTransformReturn() + pyObj <- pyObject(sprintf("__R__.namespace[%i]", pyObj$id)) + rObj <- set.time(pyObj) + rObj$year <- 0 + rObj$mon <- 0 + rObj$mday <- 1 + rObj +}) + +setClass("date") +setMethod("pyGetPoly", signature(key = "character", autoTypecast = "logical", simplify = "logical", pyClass = "date"), function(key, autoTypecast, simplify, pyClass) { + pyObj <- pyGetPoly(key, autoTypecast, simplify, "date") + # See PythonInR::pyTransformReturn() + pyObj <- pyObject(sprintf("__R__.namespace[%i]", pyObj$id)) + as.Date(pyObj$isoformat()) +}) + +setClass("timedelta") +setMethod("pyGetPoly", signature(key = "character", autoTypecast = "logical", simplify = "logical", pyClass = "timedelta"), function(key, autoTypecast, simplify, pyClass) { + pyObj <- pyGetPoly(key, autoTypecast, simplify, "timedelta") + # See PythonInR::pyTransformReturn() + pyObj <- pyObject(sprintf("__R__.namespace[%i]", pyObj$id)) + timedelta.to.difftime(pyObj) +}) + sympy <- function(..., retclass = c("character", "Sym", "expr"), debug = FALSE) { retclass <- if (is.null(retclass)) NULL else match.arg(retclass) if (!is.null(retclass)) { From 9cab7301ffaba2de3140a9dbb6dfefcda6121b55 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Thu, 11 Feb 2016 02:31:05 -0500 Subject: [PATCH 14/20] Translate simplest of R closures into Python lambdas --- R/Sym.R | 38 +++++++++++++++++++++++++++++++++----- 1 file changed, 33 insertions(+), 5 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index 838fd28..e851ba1 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -170,13 +170,20 @@ as.Sym <- function(x) { x <- x[[3]] } + # Conditions are based on the observation that the call: + # is.function(eval(as.call(list(quote(`function`), as.pairlist(alist(x=)), NULL)))) + # is TRUE for pretty much any value for the 3rd element in the call object. + is.closure <- function(call.obj) + # x[[2]] is formal parameters, x[[3]] is body, x[[4]] is debug info. + as.character(call.obj[[1]]) == "function" && is.pairlist(call.obj[[2]]) && length(call.obj) >= 3 + # call objects can be recursively descended to get constants and names. # if a variable exists in R, use the value in the R variable. # if a variable exists only in Python, use the value in the Python variable. # otherwise, call Var() to create a new Python variable. - to.replace <- (f <- function(x) { + to.replace <- (f <- function(x, ignore = NULL) { if (is.name(x)) # symbols - if (exists(as.character(x), where = env)) + if (exists(as.character(x), where = env) || as.character(x) %in% ignore) # Substitute in R variable that exists in the caller's context NULL else if (pythonHasVariable(as.character(x))) @@ -206,16 +213,19 @@ as.Sym <- function(x) { else # constants by definition are already known NULL + else if (is.closure(x)) # function declaration + # don't create any SymPy symbols for usages of the formal parameters + unlist(c(`1` = NA, `3` = f(x[[3]], names(x[[2]])))) else # nested function call/operator if (as.character(x[[1]]) == "<-") # Python assignments are statements, not expressions stop("Assignments are allowed only at the top level") else if (!exists(as.character(x[[1]]), where = env)) # x[-1] to skip the function name - c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f), if (length(x) > 1) 2:length(x) else c()))) + c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c()))) else # x[-1] to skip the function name - unlist(setNames(lapply(x[-1], f), if (length(x) > 1) 2:length(x) else c())) + unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c())) })(x) if (!is.list(to.replace)) @@ -250,7 +260,10 @@ as.Sym <- function(x) { vars <- unlist(lapply(unknown.symbols, as.character)) vars <- setNames(lapply(vars, Var), vars) - # pass through function names that aren't implemented in R to SymPy + # process lambdas and pass through function names that aren't implemented in R to SymPy. + # Both kinds of replacements replace entire R expression trees with strings + # of Python code, so deepest replacements of EITHER kind must be done before + # any replacements towards the root of the expression tree x <- Reduce(function(x, name) { # unlist() set names of nested lists [[i]][[j]][[k]] to "i.j.k" address <- as.numeric(unlist(strsplit(name, ".", fixed = TRUE))) @@ -259,6 +272,21 @@ as.Sym <- function(x) { # go to container for function call deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), head(address, -1), quote(x)) deref.evaled <- eval(deref) + + # branch for lambda instead of pass through function name processing + if (is.closure(deref.evaled)) { + fn.formals <- names(deref.evaled[[2]]) + fn.body <- deref.evaled[[3]] + if (class(fn.body) == "{") + # Python doesn't support multiline anonymous functions + stop("Multi-statement lambdas not yet translatable") + + fn.body <- eval(fn.body, envir = c(vars, setNames(lapply(fn.formals, Sym), fn.formals)), enclos = env) # deparse(fn.body) + fn.formals <- paste(fn.formals, collapse = ",") + eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), "lambda", fn.formals, ":", fn.body)))))) + return(x) + } + # get the function name fn.name <- deref.evaled[[1]] # get all right siblings (parameters to function) From 0c7e81c54e39211d9ca641fb1c62b26c319add78 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Fri, 12 Feb 2016 12:07:30 -0500 Subject: [PATCH 15/20] Treat R function handles as lambdas, and bug fixes E.g. simple R functions such as `identity` are expanded to Sym("lambda x: x") rather than Sym("function(x) x"). Use deparse() instead of as.character(). Syntax such as `a(b)(c)` - i.e. `a(b)` evaluates to a function that takes in the argument `c` - was being converted into string vectors rather than the expected Sym("a(b)", "(", "c", ")"). pythonHasVariable() checks if a variable is defined in Python's __builtin__ module. --- R/Sym.R | 75 +++++++++++++++++++++++++++++++++++++++---------------- R/sympy.R | 11 +++++++- 2 files changed, 64 insertions(+), 22 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index e851ba1..d6e0a37 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -154,38 +154,42 @@ as.Sym <- function(x) { # from the caller's context x <- substitute(x) - # in case the expr x makes reference to variables - # named e.g. x, env, unknown.symbols, or vars, we want - # to prevent this function's local variables from - # being improperly substituted into the passed expr x - env <- parent.frame() - if (!is.call(x)) # no operations or function calls, just a single variable or constant x <- as.call(list(quote(`identity`), x)) assign.to <- NULL - if (as.character(x[[1]]) == "<-") { - assign.to <- as.character(x[[2]]) + if (deparse(x[[1]]) == "<-") { + assign.to <- deparse(x[[2]]) x <- x[[3]] } + # in case the expr x makes reference to variables + # named e.g. x, env, unknown.symbols, or vars, we want + # to prevent this function's local variables from + # being improperly substituted into the passed expr x + env <- parent.frame() + # Conditions are based on the observation that the call: # is.function(eval(as.call(list(quote(`function`), as.pairlist(alist(x=)), NULL)))) # is TRUE for pretty much any value for the 3rd element in the call object. is.closure <- function(call.obj) # x[[2]] is formal parameters, x[[3]] is body, x[[4]] is debug info. - as.character(call.obj[[1]]) == "function" && is.pairlist(call.obj[[2]]) && length(call.obj) >= 3 + deparse(call.obj[[1]]) == "function" && is.pairlist(call.obj[[2]]) && length(call.obj) >= 3 # call objects can be recursively descended to get constants and names. # if a variable exists in R, use the value in the R variable. # if a variable exists only in Python, use the value in the Python variable. # otherwise, call Var() to create a new Python variable. - to.replace <- (f <- function(x, ignore = NULL) { + to.replace <- as.list((f <- function(x, ignore = NULL) { if (is.name(x)) # symbols if (exists(as.character(x), where = env) || as.character(x) %in% ignore) - # Substitute in R variable that exists in the caller's context - NULL + if (is.function(fn <- eval(x))) + # Replace the function handle with a closure + fn + else + # Substitute in R variable that exists in caller's context + NULL else if (pythonHasVariable(as.character(x))) # Sym(x): no R variable, but use the Python variable as.character(x) @@ -217,20 +221,49 @@ as.Sym <- function(x) { # don't create any SymPy symbols for usages of the formal parameters unlist(c(`1` = NA, `3` = f(x[[3]], names(x[[2]])))) else # nested function call/operator - if (as.character(x[[1]]) == "<-") + if (deparse(x[[1]]) == "<-") # Python assignments are statements, not expressions stop("Assignments are allowed only at the top level") - else if (!exists(as.character(x[[1]]), where = env)) - # x[-1] to skip the function name - c(setNames(list(NA), 1), unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c()))) + else if (!exists(deparse(x[[1]]), where = env)) + # x[-1] to skip the function name. NA means use Python function + c(list(`1` = NA), unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c()))) else # x[-1] to skip the function name unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c())) - })(x) + })(x)) - if (!is.list(to.replace)) - # characters only - to.replace <- as.list(to.replace) + # attempt to rewrite trivial R functions, referred by name, into Python + function.handles <- sort(which(as.logical(unlist(lapply(to.replace, is.function)))), decreasing = TRUE) + # replace the function handle with the closure itself + x <- Reduce(function(x, name) { + # unlist() set names of nested lists [[i]][[j]][[k]] to "i.j.k" + address <- as.numeric(unlist(strsplit(name, ".", fixed = TRUE))) + # first child of any parent must be a function name + stopifnot(tail(address, 1) != 1 || length(x) == 1) + # creates an expression to access e.g. x[[3]][[2]] when address==c(3,2) + deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), address, quote(x)) + #str(as.call(list(quote(`<-`), deref, enquote(to.replace[[name]])))) + #eval(as.call(list(quote(`<-`), deref, bquote(enquote(.(to.replace[[name]])))))) + #eval(as.call(list(quote(`<-`), deref, quote(enquote(to.replace[[name]]))))) + #eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(quote), to.replace[[name]])))))) + #eval(as.call(list(quote(`<-`), deref, as.call(list(quote(quote), enquote(to.replace[[name]])))))) + eval(as.call(list(quote(`<-`), deref, enquote(as.call(list(quote(`function`), formals(to.replace[[name]]), body(to.replace[[name]]))))))) + x + }, names(to.replace)[function.handles], x) + # replace the function handle in to.replace with the replacements needed within its body + to.replace <- Reduce(function(to.replace, loc) { + # splice in replacements needed for closure + fn <- to.replace[[loc]] + inner.to.replace <- as.list(unlist(setNames(list(list(`1` = NA, `3` = f(body(fn), names(formals(fn))))), names(to.replace)[loc]))) + if (loc == 1 && loc == length(to.replace)) + NULL + else if (loc == length(to.replace)) + c(to.replace[1:(loc - 1)], inner.to.replace) + else if (loc == 1) + c(inner.to.replace, to.replace[(loc + 1):length(to.replace)]) + else + c(to.replace[1:(loc - 1)], inner.to.replace, to.replace[(loc + 1):length(to.replace)]) + }, function.handles, to.replace) # in the case of passing through functions to SymPy, reversing the list # substitutes innermost function calls first, so addresses are not messed up @@ -281,7 +314,7 @@ as.Sym <- function(x) { # Python doesn't support multiline anonymous functions stop("Multi-statement lambdas not yet translatable") - fn.body <- eval(fn.body, envir = c(vars, setNames(lapply(fn.formals, Sym), fn.formals)), enclos = env) # deparse(fn.body) + fn.body <- eval(fn.body, envir = c(vars, setNames(lapply(fn.formals, Sym), fn.formals)), enclos = env) fn.formals <- paste(fn.formals, collapse = ",") eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), "lambda", fn.formals, ":", fn.body)))))) return(x) diff --git a/R/sympy.R b/R/sympy.R index 5a045de..4fed435 100644 --- a/R/sympy.R +++ b/R/sympy.R @@ -202,7 +202,16 @@ executeLambda <- function(fn, args, retclass) { pythonHasVariable <- function(x) { pySet("__Rsympy", x) - pyExec("__Rsympy = __Rsympy in locals() or __Rsympy in globals()") + pyExec("__Rsympy = __Rsympy in locals() or __Rsympy in globals() or __Rsympy in vars(__builtins__)") + pyGet("__Rsympy") +} + +pythonHasFunction <- function(x) { + if (!pythonHasVariable(x)) + return(FALSE) + + pySet("__Rsympy", x) + pyExec("__Rsympy = hasattr(eval(__Rsympy), '__call__')") pyGet("__Rsympy") } From 50d8064f2825dc3837678dfb0785bdfcca27a6c2 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Fri, 12 Feb 2016 22:46:01 -0500 Subject: [PATCH 16/20] Refactor as.Sym() Move most of the pass-through function processing logic to two other functions defined within as.Sym(). Reuse some of the R to Python object translation logic for the lambda body processing logic. --- R/Sym.R | 78 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 42 insertions(+), 36 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index d6e0a37..56af417 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -177,6 +177,45 @@ as.Sym <- function(x) { # x[[2]] is formal parameters, x[[3]] is body, x[[4]] is debug info. deparse(call.obj[[1]]) == "function" && is.pairlist(call.obj[[2]]) && length(call.obj) >= 3 + r.to.Sym <- function(arg) { + if (inherits(arg, "Date")) + # create datetime.date instance + Sym("date(", as.integer(format(arg, "%Y")), ",", as.integer(format(arg, "%m")), ",", as.integer(format(arg, "%d")), ")") + else if (inherits(arg, "POSIXt")) + # create datetime.datetime instance + Sym("datetime(", (arg <- as.POSIXlt(arg))$year + 1900, ",", arg$mon + 1, ",", arg$mday, ",", arg$hour, ",", arg$min, ",", trunc(arg$sec), ",", round((arg$sec %% 1) * 1000000), if (!is.null(arg$gmtoff)) paste(",timezone(timedelta(seconds = ", arg$gmtoff, "))") else "", ")") + else if (inherits(arg, "difftime")) + # create datetime.timedelta instance + Sym("timedelta(0,", as.double(arg, units = "secs"), ")") + else if (is.complex(arg)) + # R formats with a+bi. Python formats with a+bj. + Sym(paste(Re(arg), "+", Im(arg), "j", sep = "")) + else if (is.character(arg) && !any(class(arg) == 'Sym')) + # quote strings + # R's escape sequences map directly to Python unicode strings, + # except for "\`" because backtick are not quotes in Python, + # but this doesn't matter since encodeString() quotes with "\"". + Sym(paste("u", encodeString(arg, quote = "\""), sep = "")) + else + # pass-through + arg + } + + pass.through.function <- function(deref.evaled, uneval = FALSE) { + # get the function name + fn.name <- deref.evaled[[1]] + # get all right siblings (parameters to function) + arguments <- setNames(lapply(deref.evaled[-1], eval, envir = vars, enclos = env), names(deref.evaled)[-1]) + # prepend argument values with argument names + named.arguments <- names(arguments) != "" + arguments[named.arguments] <- paste(names(arguments)[named.arguments], arguments[named.arguments], sep = "=") + arguments <- lapply(arguments, r.to.Sym) + if (uneval) + bquote(as.call(.(c(list(quote(Sym), deparse(fn.name), "("), paste(arguments, collapse = ","), list(")"))))) + else + Sym(deparse(fn.name), "(", paste(arguments, collapse = ","), ")") + } + # call objects can be recursively descended to get constants and names. # if a variable exists in R, use the value in the R variable. # if a variable exists only in Python, use the value in the Python variable. @@ -242,11 +281,6 @@ as.Sym <- function(x) { stopifnot(tail(address, 1) != 1 || length(x) == 1) # creates an expression to access e.g. x[[3]][[2]] when address==c(3,2) deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), address, quote(x)) - #str(as.call(list(quote(`<-`), deref, enquote(to.replace[[name]])))) - #eval(as.call(list(quote(`<-`), deref, bquote(enquote(.(to.replace[[name]])))))) - #eval(as.call(list(quote(`<-`), deref, quote(enquote(to.replace[[name]]))))) - #eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(quote), to.replace[[name]])))))) - #eval(as.call(list(quote(`<-`), deref, as.call(list(quote(quote), enquote(to.replace[[name]])))))) eval(as.call(list(quote(`<-`), deref, enquote(as.call(list(quote(`function`), formals(to.replace[[name]]), body(to.replace[[name]]))))))) x }, names(to.replace)[function.handles], x) @@ -316,42 +350,14 @@ as.Sym <- function(x) { fn.body <- eval(fn.body, envir = c(vars, setNames(lapply(fn.formals, Sym), fn.formals)), enclos = env) fn.formals <- paste(fn.formals, collapse = ",") + fn.body <- r.to.Sym(fn.body) + # TODO: convert default values for formals into Python eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), "lambda", fn.formals, ":", fn.body)))))) return(x) } - # get the function name - fn.name <- deref.evaled[[1]] - # get all right siblings (parameters to function) - arguments <- setNames(lapply(deref.evaled[-1], eval, envir = vars, enclos = env), names(deref.evaled)[-1]) - # prepend argument values with argument names - named.arguments <- names(arguments) != "" - arguments[named.arguments] <- paste(names(arguments)[named.arguments], arguments[named.arguments], sep = "=") - arguments <- lapply(arguments, function(arg) - if (inherits(arg, "Date")) - # create datetime.date instance - Sym("date(", as.integer(format(arg, "%Y")), ",", as.integer(format(arg, "%m")), ",", as.integer(format(arg, "%d")), ")") - else if (inherits(arg, "POSIXt")) - # create datetime.datetime instance - Sym("datetime(", (arg <- as.POSIXlt(arg))$year + 1900, ",", arg$mon + 1, ",", arg$mday, ",", arg$hour, ",", arg$min, ",", trunc(arg$sec), ",", round((arg$sec %% 1) * 1000000), if (!is.null(arg$gmtoff)) paste(",timezone(timedelta(seconds = ", arg$gmtoff, "))") else "", ")") - else if (inherits(arg, "difftime")) - # create datetime.timedelta instance - Sym("timedelta(0,", as.double(arg, units = "secs"), ")") - else if (is.complex(arg)) - # R formats with a+bi. Python formats with a+bj. - Sym(paste(Re(arg), "+", Im(arg), "j", sep = "")) - else if (is.character(arg) && !any(class(arg) == 'Sym')) - # quote strings - # R's escape sequences map directly to Python unicode strings, - # except for "\`" because backtick are not quotes in Python, - # but this doesn't matter since encodeString() quotes with "\"". - Sym(paste("u", encodeString(arg, quote = "\""), sep = "")) - else - # pass-through - arg - ) # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") - eval(as.call(list(quote(`<-`), deref, quote(as.call(c(list(quote(Sym), as.character(fn.name), "("), paste(arguments, collapse = ","), list(")"))))))) + eval(as.call(list(quote(`<-`), deref, pass.through.function(deref.evaled, uneval = TRUE)))) # carry the transformed x to the next transformation function x }, names(to.replace)[is.na(to.replace)], x) From da2df3cffa02dd3eaec6b3b40edc4fa9bc3c8b72 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Sat, 13 Feb 2016 11:33:30 -0500 Subject: [PATCH 17/20] Support more pass-through to Python functionality in as.Sym() Within the scope of the as.Sym() argument, provide functions pl() for creating Python tuples and as.pl() for converting lists to tuples. Within the scope of the as.Sym() argument, provide function .() for escaping the first symbol within its argument as a Python variable or call, e.g. .(print(x)) will force the translator to not execute print() in R but may still resolve `x` in R. Also prevents the translator from interpreting R keywords, e.g. .(FALSE) will translate to a reference to a Python variable named FALSE rather than to the equivalent constant False. Translate any resolved R data.frames, arrays, matrices, lists, or vectors into row-major jagged lists in Python. --- R/Sym.R | 69 +++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 60 insertions(+), 9 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index 56af417..018861c 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -168,7 +168,7 @@ as.Sym <- function(x) { # named e.g. x, env, unknown.symbols, or vars, we want # to prevent this function's local variables from # being improperly substituted into the passed expr x - env <- parent.frame() + env <- new.env(parent = parent.frame()) # Conditions are based on the observation that the call: # is.function(eval(as.call(list(quote(`function`), as.pairlist(alist(x=)), NULL)))) @@ -177,8 +177,40 @@ as.Sym <- function(x) { # x[[2]] is formal parameters, x[[3]] is body, x[[4]] is debug info. deparse(call.obj[[1]]) == "function" && is.pairlist(call.obj[[2]]) && length(call.obj) >= 3 + to.jagged.array <- function(x) { + # Base case: already 1 dimensional + if (is.null(dim(x)) || length(dim(x)) == 1 || dim(x)[1] == 1) + if (length(x) == 1) + # Scalar + return(unname(do.call(c, as.list(x)))) + else + # List + return(unname(as.list(x))) + + # Peel off the first dimension, so that we create a list of rows + empty.indices <- rep(list(bquote()), length(dim(x)) - 1) + lapply(1:dim(x)[1], function(i) + to.jagged.array(do.call(`[`, c(list(quote(x), i), empty.indices))) + ) + } + + jagged.array.to.Sym <- function(arg) { + if (!is.list(arg)) + return(r.to.Sym(arg)) + + Sym("[", paste(lapply(arg, function(x) { + if (is.list(x)) + jagged.array.to.Sym(x) + else + r.to.Sym(x) + }), collapse = ","), "]") + } + r.to.Sym <- function(arg) { - if (inherits(arg, "Date")) + if (!is.null(dim(arg)) || length(arg) != 1 || is.list(arg)) + # mutual recursion + jagged.array.to.Sym(to.jagged.array(arg)) + else if (inherits(arg, "Date")) # create datetime.date instance Sym("date(", as.integer(format(arg, "%Y")), ",", as.integer(format(arg, "%m")), ",", as.integer(format(arg, "%d")), ")") else if (inherits(arg, "POSIXt")) @@ -216,27 +248,43 @@ as.Sym <- function(x) { Sym(deparse(fn.name), "(", paste(arguments, collapse = ","), ")") } + # tuple + env$pl <- function(...) + Sym(paste("(", paste(lapply(list(...), function(x) as.Sym(x)), collapse = ","), ")")) + + env$as.pl <- function(lst) do.call(env$pl, as.list(lst)) + + # pyEval + env$`.` <- function(...) { + args <- list(...) + args[Position(is.null, args)] <- "NULL" + do.call(Sym, args) + } + # call objects can be recursively descended to get constants and names. # if a variable exists in R, use the value in the R variable. # if a variable exists only in Python, use the value in the Python variable. # otherwise, call Var() to create a new Python variable. - to.replace <- as.list((f <- function(x, ignore = NULL) { + to.replace <- as.list((f <- function(x, ignore = NULL, pyEval = FALSE) { if (is.name(x)) # symbols - if (exists(as.character(x), where = env) || as.character(x) %in% ignore) + if (exists(deparse(x), where = env) && !pyEval || deparse(x) %in% ignore) if (is.function(fn <- eval(x))) # Replace the function handle with a closure fn else # Substitute in R variable that exists in caller's context NULL - else if (pythonHasVariable(as.character(x))) + else if (pythonHasVariable(deparse(x))) # Sym(x): no R variable, but use the Python variable - as.character(x) + deparse(x) else # Var(x): create a Python symbol x else if (!is.call(x)) # constants - if (is.null(x) || is.na(x)) + if (pyEval) + # in case Python has a variable named e.g. FALSE, do not touch + NULL + else if (is.null(x) || is.na(x)) # Python uses None for NULL "None" else if (is.nan(x)) @@ -263,7 +311,10 @@ as.Sym <- function(x) { if (deparse(x[[1]]) == "<-") # Python assignments are statements, not expressions stop("Assignments are allowed only at the top level") - else if (!exists(deparse(x[[1]]), where = env)) + else if (deparse(x[[1]]) == ".") + # don't parse following symbol as R but as Python + unlist(setNames(lapply(x[-1], f, ignore, pyEval = TRUE), if (length(x) > 1) 2:length(x) else c())) + else if (!exists(deparse(x[[1]]), where = env) || pyEval) # x[-1] to skip the function name. NA means use Python function c(list(`1` = NA), unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c()))) else @@ -324,7 +375,7 @@ as.Sym <- function(x) { # declare SymPy symbols for symbols not found in R or Python, and plug them in R unknown.symbols <- to.replace[unknown.symbols] - vars <- unlist(lapply(unknown.symbols, as.character)) + vars <- unlist(lapply(unknown.symbols, deparse)) vars <- setNames(lapply(vars, Var), vars) # process lambdas and pass through function names that aren't implemented in R to SymPy. From 096eb9fb8ab7bc9e3da8fa9529862d4a4da08550 Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Sat, 13 Feb 2016 12:06:06 -0500 Subject: [PATCH 18/20] Translate defaults and fix bugs for lambda formals in as.Sym() Translate default values of lambda formals to Python. Append equals sign and default value to formal parameter name if there is a default value. Fix usages of formal parameters in function calls inside a lambda e.g. `function(x) type(x)` failing to be resolved. Fix formal parameters being expanded if they share the same name as a function handle in an ancestor scope e.g. `function(identity) identity(2)`. Local variables of a function, including formal parameters, should hide global variables. Fix outer formal parameters not being resolved in nested lambdas e.g. translator won't resolve usage of `x` in `function(x) function(y) type(x, y)`. --- R/Sym.R | 28 +++++++++++++++++++++------- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index 018861c..e0e142d 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -267,7 +267,13 @@ as.Sym <- function(x) { # otherwise, call Var() to create a new Python variable. to.replace <- as.list((f <- function(x, ignore = NULL, pyEval = FALSE) { if (is.name(x)) # symbols - if (exists(deparse(x), where = env) && !pyEval || deparse(x) %in% ignore) + if (deparse(x) == "") + # empty default value for a formal argument + NULL + else if (deparse(x) %in% ignore) + # Sym(x): make sure that formal parameter usages are never evaled + deparse(x) + else if (exists(deparse(x), where = env) && !pyEval) if (is.function(fn <- eval(x))) # Replace the function handle with a closure fn @@ -306,7 +312,7 @@ as.Sym <- function(x) { NULL else if (is.closure(x)) # function declaration # don't create any SymPy symbols for usages of the formal parameters - unlist(c(`1` = NA, `3` = f(x[[3]], names(x[[2]])))) + unlist(c(`1` = NA, `2` = setNames(lapply(x[[2]], f, ignore), if (length(x[[2]]) > 0) 1:length(x[[2]]) else c()), `3` = f(x[[3]], c(ignore, names(x[[2]]))))) else # nested function call/operator if (deparse(x[[1]]) == "<-") # Python assignments are statements, not expressions @@ -314,7 +320,7 @@ as.Sym <- function(x) { else if (deparse(x[[1]]) == ".") # don't parse following symbol as R but as Python unlist(setNames(lapply(x[-1], f, ignore, pyEval = TRUE), if (length(x) > 1) 2:length(x) else c())) - else if (!exists(deparse(x[[1]]), where = env) || pyEval) + else if (deparse(x[[1]]) %in% ignore || !exists(deparse(x[[1]]), where = env) || pyEval) # x[-1] to skip the function name. NA means use Python function c(list(`1` = NA), unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c()))) else @@ -393,16 +399,24 @@ as.Sym <- function(x) { # branch for lambda instead of pass through function name processing if (is.closure(deref.evaled)) { - fn.formals <- names(deref.evaled[[2]]) + fn.formals <- deref.evaled[[2]] fn.body <- deref.evaled[[3]] if (class(fn.body) == "{") # Python doesn't support multiline anonymous functions stop("Multi-statement lambdas not yet translatable") - fn.body <- eval(fn.body, envir = c(vars, setNames(lapply(fn.formals, Sym), fn.formals)), enclos = env) - fn.formals <- paste(fn.formals, collapse = ",") + fn.body <- eval(fn.body, envir = c(vars, setNames(lapply(names(fn.formals), Sym), names(fn.formals))), enclos = env) fn.body <- r.to.Sym(fn.body) - # TODO: convert default values for formals into Python + + fn.formals[unlist(lapply(fn.formals, deparse)) == ""] <- list(NULL) + # unlike in R, default values can't reference other formal parameters in Python, so no using fn.formals in envir + fn.formals <- lapply(fn.formals, eval, envir = vars, enclos = env) + fn.formals <- lapply(fn.formals, function(x) if (is.null(x)) NULL else r.to.Sym(x)) + empty.defaults <- unlist(lapply(fn.formals, is.null)) + fn.formals[empty.defaults] <- names(fn.formals)[empty.defaults] + fn.formals[!empty.defaults] <- paste(names(fn.formals)[!empty.defaults], fn.formals[!empty.defaults], sep = "=") + fn.formals <- paste(fn.formals, collapse = ",") + eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), "lambda", fn.formals, ":", fn.body)))))) return(x) } From 201aab0819c2c2250a89e2cde07c37058568394d Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Sat, 13 Feb 2016 13:15:28 -0500 Subject: [PATCH 19/20] Fix functions that return functions in as.Sym() Pass-through function processing evaluates functions called on a function. Pass-through and lambda function processing convert instances of Sym("f()")() to Sym("f()()") to fix "attempt to apply non-function" errors. --- R/Sym.R | 45 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 40 insertions(+), 5 deletions(-) diff --git a/R/Sym.R b/R/Sym.R index e0e142d..22ba55a 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -236,6 +236,10 @@ as.Sym <- function(x) { pass.through.function <- function(deref.evaled, uneval = FALSE) { # get the function name fn.name <- deref.evaled[[1]] + if (is.call(fn.name)) + fn.name <- eval(fn.name) + else + fn.name <- deparse(fn.name) # get all right siblings (parameters to function) arguments <- setNames(lapply(deref.evaled[-1], eval, envir = vars, enclos = env), names(deref.evaled)[-1]) # prepend argument values with argument names @@ -243,9 +247,23 @@ as.Sym <- function(x) { arguments[named.arguments] <- paste(names(arguments)[named.arguments], arguments[named.arguments], sep = "=") arguments <- lapply(arguments, r.to.Sym) if (uneval) - bquote(as.call(.(c(list(quote(Sym), deparse(fn.name), "("), paste(arguments, collapse = ","), list(")"))))) + bquote(as.call(.(c(list(quote(Sym), fn.name, "("), paste(arguments, collapse = ","), list(")"))))) else - Sym(deparse(fn.name), "(", paste(arguments, collapse = ","), ")") + Sym(fn.name, "(", paste(arguments, collapse = ","), ")") + } + + unnest.parentheses <- function(x, address) { + if (length(address) < 2) + return(NULL) + + deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), head(address, -2), quote(x)) + deref.evaled <- eval(deref) + fn <- deparse(deref.evaled[[1]]) + if (length(fn) != 1 || fn != "(") + return(NULL) + + eval(as.call(list(quote(`<-`), deref, quote(deref.evaled[[2]])))) + return(x) } # tuple @@ -320,6 +338,9 @@ as.Sym <- function(x) { else if (deparse(x[[1]]) == ".") # don't parse following symbol as R but as Python unlist(setNames(lapply(x[-1], f, ignore, pyEval = TRUE), if (length(x) > 1) 2:length(x) else c())) + else if (is.call(x[[1]])) + # the function we call is itself a function that returns a closure + unlist(setNames(lapply(x, f, ignore), if (length(x) > 0) 1:length(x) else c())) else if (deparse(x[[1]]) %in% ignore || !exists(deparse(x[[1]]), where = env) || pyEval) # x[-1] to skip the function name. NA means use Python function c(list(`1` = NA), unlist(setNames(lapply(x[-1], f, ignore), if (length(x) > 1) 2:length(x) else c()))) @@ -418,11 +439,25 @@ as.Sym <- function(x) { fn.formals <- paste(fn.formals, collapse = ",") eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), "lambda", fn.formals, ":", fn.body)))))) - return(x) + } else { + # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") + eval(as.call(list(quote(`<-`), deref, pass.through.function(deref.evaled, uneval = TRUE)))) + } + + while (!is.null(new.x <- unnest.parentheses(x, address))) { + x <- new.x + address <- address[-(length(address) - 1)] + } + + if (length(address) >= 2 && head(tail(address, 2), 1) == 1) { + # e.g. we're processing f(), where f() is used in the call (f())(). + # f() is now substituted with a Sym, but Sym("f()")() can't be + # called, so replace our parent call with Sym("f()()") + deref <- Reduce(function(acc, add) as.call(list(quote(`[[`), acc, add)), head(address, -2), quote(x)) + deref.evaled <- eval(deref) + eval(as.call(list(quote(`<-`), deref, pass.through.function(deref.evaled, uneval = TRUE)))) } - # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") - eval(as.call(list(quote(`<-`), deref, pass.through.function(deref.evaled, uneval = TRUE)))) # carry the transformed x to the next transformation function x }, names(to.replace)[is.na(to.replace)], x) From 3e2d40d727f8756e6713b49cb6fbc0600db8fb8e Mon Sep 17 00:00:00 2001 From: Kevin Jin Date: Sat, 13 Feb 2016 13:27:08 -0500 Subject: [PATCH 20/20] Translate member operator in as.Sym() `$` in R is equivalent to `.` in Python. --- R/Sym.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/R/Sym.R b/R/Sym.R index 22ba55a..7b43faf 100644 --- a/R/Sym.R +++ b/R/Sym.R @@ -338,6 +338,14 @@ as.Sym <- function(x) { else if (deparse(x[[1]]) == ".") # don't parse following symbol as R but as Python unlist(setNames(lapply(x[-1], f, ignore, pyEval = TRUE), if (length(x) > 1) 2:length(x) else c())) + else if (deparse(x[[1]]) == "$") + # member operator + if (!is.null(container <- f(x[[2]], ignore)) || pyEval) + # y is a Python variable. y$a -> y.a + unlist(c(`1` = NA, `2` = container, `3` = deparse(x[[3]]))) + else + # y is an R variable. evaluate y$a, no translation needed + NULL else if (is.call(x[[1]])) # the function we call is itself a function that returns a closure unlist(setNames(lapply(x, f, ignore), if (length(x) > 0) 1:length(x) else c())) @@ -439,6 +447,9 @@ as.Sym <- function(x) { fn.formals <- paste(fn.formals, collapse = ",") eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), "lambda", fn.formals, ":", fn.body)))))) + } else if (deparse(deref.evaled[[1]]) == "$") { + sides <- lapply(deref.evaled[-1], eval, envir = vars, enclos = env) + eval(as.call(list(quote(`<-`), deref, quote(as.call(list(quote(Sym), sides[[1]], ".", sides[[2]])))))) } else { # replace e.g. x[[i]][[j]] with e.g. Sym(x[[i]][[j]][[1]], "(", x[[i]][[j]][[2]], x[[i]][[j]][[3]], ")") eval(as.call(list(quote(`<-`), deref, pass.through.function(deref.evaled, uneval = TRUE))))