Changeset: 92bf06ce1de6 for MonetDB
URL: http://dev.monetdb.org/hg/MonetDB?cmd=changeset;node=92bf06ce1de6
Modified Files:
clients/R/MonetDB.R/DESCRIPTION
clients/R/MonetDB.R/R/dbapply.R
clients/R/Tests/dbapply.R
clients/R/Tests/dbapply.stable.out
Branch: default
Log Message:
R Connector: mdbapply now supports additional positional parameters
diffs (138 lines):
diff --git a/clients/R/MonetDB.R/DESCRIPTION b/clients/R/MonetDB.R/DESCRIPTION
--- a/clients/R/MonetDB.R/DESCRIPTION
+++ b/clients/R/MonetDB.R/DESCRIPTION
@@ -6,7 +6,8 @@ Authors@R: c(person("Hannes Muehleisen",
person("Anthony Damico", role = "ctb"))
Author: Hannes Muehleisen [aut, cre], Thomas Lumley [ctb], Anthony Damico [ctb]
Maintainer: Hannes Muehleisen <han...@cwi.nl>
-Depends: DBI (>= 0.3.1), digest (>= 0.6.4), methods, R (>= 3.1.1), codetools
+Depends: DBI (>= 0.3.1)
+Imports: digest (>= 0.6.4), methods, codetools
Enhances: dplyr (>= 0.3.0)
Description: Allows to pull data from MonetDB into R. Includes a DBI
implementation and a dplyr backend.
License: MPL (== 1.1)
diff --git a/clients/R/MonetDB.R/R/dbapply.R b/clients/R/MonetDB.R/R/dbapply.R
--- a/clients/R/MonetDB.R/R/dbapply.R
+++ b/clients/R/MonetDB.R/R/dbapply.R
@@ -1,5 +1,6 @@
-# TOOD: support running this on query results?
+# TOOD: support running this on a select in addition to table?
# TODO: support remote dbs, find out whether its local via canary file
+# TODO: don't actually construct the data frame but use attr/class trick to
save copying
if (is.null(getGeneric("mdbapply"))) setGeneric("mdbapply", function(conn,
table, fun, ...)
standardGeneric("mdbapply"))
@@ -33,22 +34,26 @@ setMethod("mdbapply", signature(conn="Mo
',unique(sapply(strsplit(grep("^package:", search(),
value=T),":"), function(x) x[[2]]))), function(pname) library(pname,
character.only=T, quietly=T)))\n')
}
# serialize global variables into ascii string, and add the code to scan it
again into the current env
- vars <- findGlobals(fun,merge=F)$variables
- dotdot <- list(...)
+ vars <- codetools::findGlobals(fun, merge=F)$variables
+ mdbapply_dotdot <- list(...)
+ if (length(mdbapply_dotdot) > 0) {
+ vars <- c(vars,"mdbapply_dotdot")
+ assign("mdbapply_dotdot", mdbapply_dotdot, envir=environment(fun))
+ }
sfilename <- NA
- if (length(vars) > 1 || length(dotdot) > 1) {
+ if (length(vars) > 0) {
if (getOption("monetdb.debug.query",FALSE))
- message("Variable(s) ",paste0(vars,dotdot,collapse=", "))
- #vars$mdbapply_dotdot <- dotdot
- sfilename <- tempfile()
+ message("Variable(s) ",paste0(vars,collapse=", "))
+ #sfilename <- tempfile()
+ sfilename <- '/tmp/args.rds'
save(list=vars,file=sfilename,envir=environment(fun), compress=T)
- dbrcode <- paste0(dbrcode, '# load serialized global variables\nload("',
sfilename, '")\n')
+ dbrcode <- paste0(dbrcode, '# load serialized global variable(s) ',
paste(vars, collapse=", "), '\nload("', sfilename, '")\n')
}
rfilename <- tempfile()
# get source of user function and append
dbrcode <- paste0(dbrcode, "# user-supplied function\nmdbapply_userfun <- ",
paste0(deparse(fun), collapse="\n"),
- "\n# calling user
function\nsaveRDS(mdbapply_userfun(mdbapply_dbdata),file=\"", rfilename,
"\")\nreturn(42L)\n")
+ "\n# calling user function\nsaveRDS(do.call(mdbapply_userfun,
if(exists('mdbapply_dotdot')){c(list(mdbapply_dbdata), mdbapply_dotdot)}
else{list(mdbapply_dbdata)}),file=\"", rfilename, "\")\nreturn(42L)\n")
# find out things about the table, then wrap the R function
query <- paste0("SELECT * FROM ", table, " AS t")
@@ -58,7 +63,7 @@ setMethod("mdbapply", signature(conn="Mo
paste0(res$names, collapse=", "),", stringsAsFactors=F)\n",
dbrcode, "};\n")
# call the function we just created
dbsel <- paste0("SELECT * FROM ", dbfunname, "( (",query,") );\n")
- # ok, talk to DB (EZ)
+ # ok, talk to DB (easiest part of this)
res <- NA
dbBegin(conn)
tryCatch({
@@ -67,7 +72,7 @@ setMethod("mdbapply", signature(conn="Mo
res <- readRDS(rfilename)
}, finally={
dbRollback(conn)
- file.remove(stats::na.omit(c(sfilename, rfilename)))
+ # file.remove(stats::na.omit(c(sfilename, rfilename)))
})
res
})
diff --git a/clients/R/Tests/dbapply.R b/clients/R/Tests/dbapply.R
--- a/clients/R/Tests/dbapply.R
+++ b/clients/R/Tests/dbapply.R
@@ -14,8 +14,6 @@ if (length(args) > 1)
options(monetdb.insert.splitsize=10)
options(monetdb.profile=F)
-options(monetdb.debug.query=T)
-
tname <- "monetdbtest"
@@ -52,6 +50,8 @@ predictions <- mdbapply(con, tname, func
stopifnot(identical(unname(predict(fitted, newdata=mtcars)),
unname(predictions)))
+print(length(predictions))
+
# make sure we bubble up the error
haderror <- FALSE
tryCatch({
@@ -63,20 +63,24 @@ tryCatch({
})
stopifnot(haderror)
+print(haderror)
+
# run simple test again to make sure the error did dbRollback() and we are
consistent
res <- mdbapply(con, tname, function(d) {
d$mpg
})
stopifnot(identical(res, mtcars$mpg))
+print(length(res))
# additional parameters
res <- mdbapply(con,tname,function(d, n, m) {
n+m
}, 20, 22)
+print(res)
+
dbRemoveTable(con,tname)
stopifnot(identical(FALSE, dbExistsTable(con,tname)))
-
print("SUCCESS")
diff --git a/clients/R/Tests/dbapply.stable.out
b/clients/R/Tests/dbapply.stable.out
--- a/clients/R/Tests/dbapply.stable.out
+++ b/clients/R/Tests/dbapply.stable.out
@@ -32,6 +32,10 @@ Ready.
[1] TRUE
[1] TRUE
[1] TRUE
+[1] 32
+[1] TRUE
+[1] 32
+[1] 42
[1] TRUE
[1] "SUCCESS"
_______________________________________________
checkin-list mailing list
checkin-list@monetdb.org
https://www.monetdb.org/mailman/listinfo/checkin-list
