Refactor/perf batch 10

R/elsplineDS.R

@@ -18,6 +18,7 @@
 #' @return an object of class "lspline" and "matrix", which its name is specified by the
 #' \code{newobj} argument (or its default name "elspline.newobj"), is assigned on the serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 elsplineDS <- function(x = x, n = n, marginal = FALSE, names = NULL){
@@ -54,7 +55,7 @@ elsplineDS <- function(x = x, n = n, marginal = FALSE, names = NULL){
     structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix"))
   }
 
-  x <- eval(parse(text=x), envir = parent.frame())
+  x <- .loadServersideObject(x)
 
   stopifnot(n >= 2)
   k <- seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n + 1)[-c(1, n + 1)]

R/getWGSRDS.R

@@ -49,15 +49,25 @@
 #' @return \code{ds.getWGSR} assigns a numeric vector that includes the z-scores for the
 #' specified index.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 getWGSRDS <- function(sex, firstPart, secondPart, index, standing=NA, thirdPart=NA){
 
-  sex <- eval(parse(text=sex), envir = parent.frame())
-  firstPart <- eval(parse(text=firstPart), envir = parent.frame())
-  secondPart <- eval(parse(text=secondPart), envir = parent.frame())
+  sex.name <- sex
+  firstPart.name <- firstPart
+  sex <- .loadServersideObject(sex)
+  firstPart <- .loadServersideObject(firstPart)
+  .checkClass(obj = firstPart, obj_name = firstPart.name, permitted_classes = c("numeric", "integer"))
+  if (!is.na(secondPart)){
+    secondPart.name <- secondPart
+    secondPart <- .loadServersideObject(secondPart)
+    .checkClass(obj = secondPart, obj_name = secondPart.name, permitted_classes = c("numeric", "integer"))
+  }
   if (!is.na(thirdPart)){
-    thirdPart <- eval(parse(text=thirdPart), envir = parent.frame())
+    thirdPart.name <- thirdPart
+    thirdPart <- .loadServersideObject(thirdPart)
+    .checkClass(obj = thirdPart, obj_name = thirdPart.name, permitted_classes = c("numeric", "integer"))
   }
 
   # access the internal reference data

R/hetcorDS.R

@@ -24,11 +24,12 @@
 #' any missing data were handled: "complete.obs" or "pairwise.complete.obs"; TRUE for ML estimates,
 #' FALSE for two-step estimates.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 hetcorDS <- function(data, ML, std.err, bins, pd, use){
 
-  data <- eval(parse(text=data), envir = parent.frame())
+  data <- .loadServersideObject(data)
 
   out <- polycor::hetcor(data = data, ML = ML, std.err = std.err, bins = bins, pd = pd, use = use)
 

R/lexisDS1.R

@@ -7,6 +7,7 @@
 #' @param exitCol a character string specifying the variable holding the time that each individual is censored or fails
 #' 
 #' @author Burton PR
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
 #' @return List with `max.time`
 #' @export
@@ -28,7 +29,7 @@ lexisDS1 <- function(exitCol=NULL){
     stop(errorMessage, call. = FALSE)
   }
 
-  exposure <- eval(parse(text=exitCol), envir = parent.frame())
+  exposure <- .loadServersideObject(exitCol)
 
   max.time <- max(exposure, na.rm=TRUE)
   random.multiplier <- stats::runif(1,1.01,1.05)

R/lexisDS2.R

@@ -31,6 +31,7 @@
 #' 'data' argument is set the full data.frame will be expanded and carried forward
 #' 
 #' @author Burton PR
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
 #' @return List with `expanded.table`
 #' @export
@@ -46,10 +47,10 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol,
   #nfilter.string<-as.numeric(thr$nfilter.string)
   #############################################################
 
-  starttime <- eval(parse(text=entryCol), envir = parent.frame())
-  endtime <- eval(parse(text=exitCol), envir = parent.frame())
-  cens <- eval(parse(text=statusCol), envir = parent.frame())
-  id.orig <- eval(parse(text=idCol), envir = parent.frame())
+  starttime <- .loadServersideObject(entryCol)
+  endtime <- .loadServersideObject(exitCol)
+  cens <- .loadServersideObject(statusCol)
+  id.orig <- .loadServersideObject(idCol)
 
   starttime <- as.numeric(starttime)
   endtime <- as.numeric(endtime)
@@ -72,17 +73,39 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol,
   length.collapseDF <- length(idSeq)
 
   #IDENTIFY VARIABLES TO BE CARRIED WITH THE EXPANDED SURVIVAL DATA
-
-  if(is.null(vartext)){
-    datatext2<-paste0("data.frame(",datatext,")")
-    DF <- eval(parse(text=datatext2), envir = parent.frame())
+
+  # loads each comma-separated name; whole data.frame names are unpacked into
+  # their own columns (matching data.frame()'s handling of a data.frame argument),
+  # single columns are added under their make.names()-sanitised name (matching
+  # data.frame()'s default naming for a non-symbol argument such as D$var)
+  if(is.null(vartext) && !is.null(datatext)){
+    col.names <- unlist(strsplit(datatext, split=","))
+    col.list <- list()
+    for(nm in col.names){
+      obj <- .loadServersideObject(nm)
+      if(is.data.frame(obj)){
+        col.list <- c(col.list, as.list(obj))
+      }else{
+        col.list[[make.names(nm)]] <- obj
+      }
+    }
+    DF <- data.frame(col.list)
   }
-  
+
   if(!is.null(vartext)){
-    vartext2<-paste0("data.frame(",vartext,")")
-    DF<-eval(parse(text=vartext2), envir = parent.frame())
+    col.names <- unlist(strsplit(vartext, split=","))
+    col.list <- list()
+    for(nm in col.names){
+      obj <- .loadServersideObject(nm)
+      if(is.data.frame(obj)){
+        col.list <- c(col.list, as.list(obj))
+      }else{
+        col.list[[make.names(nm)]] <- obj
+      }
+    }
+    DF <- data.frame(col.list)
   }
-  
+
   if(is.null(datatext)&&is.null(vartext)){
     DF<-data.frame(SURVTIME,CENS)
   }

R/lsplineDS.R

@@ -15,6 +15,7 @@
 #' @return an object of class "lspline" and "matrix", which its name is specified by the
 #' \code{newobj} argument (or its default name "lspline.newobj"), is assigned on the serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 lsplineDS <- function(x = x, knots = NULL, marginal = FALSE, names = NULL){
@@ -51,7 +52,7 @@ lsplineDS <- function(x = x, knots = NULL, marginal = FALSE, names = NULL){
     structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix"))
   }
 
-  x <- eval(parse(text=x), envir = parent.frame())
+  x <- .loadServersideObject(x)
 
   out <- lspline_copy(x = x, knots = knots, marginal = marginal, names = names)
 

R/metadataDS.R

@@ -6,6 +6,7 @@
 #' @return a list containing the metadata. The elements of the list will depend
 #' on the metadata available.
 #' @author Stuart Wheater, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 metadataDS <- function(x)
@@ -16,7 +17,7 @@ metadataDS <- function(x)
     if ((! is.character(x)) || (length(x) != 1))
         stop("Variable's name isn't be single character vector", call. = FALSE)
 
-    x.var <- eval(parse(text=x), envir = parent.frame())
+    x.var <- .loadServersideObject(x)
 
     if (is.null(x.var))
         stop("Variable can't be NULL", call. = FALSE)

R/nsDS.R

@@ -25,6 +25,7 @@
 #' arguments to ns, and explicitly give the knots, Boundary.knots etc for use by predict.ns().
 #' The object is assigned at each serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 nsDS <- function(x, df, knots, intercept, Boundary.knots){
@@ -33,7 +34,7 @@ nsDS <- function(x, df, knots, intercept, Boundary.knots){
   thr <- dsBase::listDisclosureSettingsDS()
   nfilter.tab <- as.numeric(thr$nfilter.tab) 
 
-  x <- eval(parse(text=x), envir = parent.frame())
+  x <- .loadServersideObject(x)
 
   if(is.null(Boundary.knots)){
     Boundary.knots <- range(x, na.rm=TRUE)

R/qlsplineDS.R

@@ -23,6 +23,7 @@
 #' @return an object of class "lspline" and "matrix", which its name is specified by the
 #' \code{newobj} argument (or its default name "qlspline.newobj"), is assigned on the serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NULL){
@@ -59,7 +60,7 @@ qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NUL
     structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix"))
   }
 
-  x <- eval(parse(text=x), envir = parent.frame())
+  x <- .loadServersideObject(x)
 
   if (length(q) == 1 && q >= 2) {
     q <- seq(0, 1, length.out = q + 1)[-c(1, q + 1)]

R/rowColCalcDS.R

@@ -4,15 +4,19 @@
 #' 'rowMeans' and 'colMeans'.
 #' @details the output is returned to the user only the number of entries in the 
 #' output vector is greater or equal to the allowed size. 
-#' @param dataset an array of two or more dimensions.
+#' @param dataset.name a character string providing the name of a server-side array of two or more dimensions.
 #' @param operation an integer that indicates the operation to carry out:
 #' 1 for 'rowSums', 2 for 'colSums', 3 for 'rowMeans' or 4 for 'colMeans'
 #' @return a numeric vector
 #' @export
 #' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
-rowColCalcDS <- function (dataset, operation) {
-
+rowColCalcDS <- function (dataset.name, operation) {
+
+  dataset <- .loadServersideObject(dataset.name)
+  .checkClass(obj = dataset, obj_name = dataset.name, permitted_classes = c("data.frame", "matrix"))
+
   if(operation == 1){
     result <- rowSums(dataset, na.rm=TRUE)
   }
@@ -25,16 +29,15 @@ rowColCalcDS <- function (dataset, operation) {
   if(operation == 4){
     result <- colMeans(dataset, na.rm=TRUE)
   }
-
-  # check if the output is valid (i.e. meets DataSHIELD criteria)
-  check <- isValidDS(result)
-  if(check){
-    return(result)
-  }else{
-    resultNA <- rep(NA, length(result))
-    return(resultNA)
+
+  # check if the output is valid (i.e. meets DataSHIELD criteria); result is
+  # always numeric, so only the numeric-vector branch of isValidDS applies
+  thr <- dsBase::listDisclosureSettingsDS()
+  nfilter.tab <- as.numeric(thr$nfilter.tab)
+  if(length(result) > 0 && length(result) < nfilter.tab){
+    result <- rep(NA, length(result))
   }
-  
+
   return(result)
-  
+
 }

R/tableDS.R

@@ -33,6 +33,7 @@
 #' of \code{ds.table}. Fully specified by <force.nfilter> argument of \code{ds.table}
 #' @return For information see help for \code{ds.table}
 #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 tableDS<-function(rvar.transmit, cvar.transmit, stvar.transmit, rvar.all.unique.levels.transmit, cvar.all.unique.levels.transmit, 
                   stvar.all.unique.levels.transmit, exclude.transmit, useNA.transmit, force.nfilter.transmit){
@@ -55,7 +56,7 @@ nfilter.tab<-as.numeric(thr$nfilter.tab)                                #
 
 if(!is.null(force.nfilter.transmit))
 {
-force.nfilter.active<-eval(parse(text=force.nfilter.transmit), envir = parent.frame())
+force.nfilter.active<-.loadServersideObject(force.nfilter.transmit)
 
 	if(force.nfilter.active<nfilter.tab)
 	{
@@ -77,7 +78,7 @@ nfilter.tab<-force.nfilter.active
 
 #Activate via eval when needed
 #rvar
-  rvar<-eval(parse(text=rvar.transmit), envir = parent.frame())
+  rvar<-.loadServersideObject(rvar.transmit)
   if(!is.factor(rvar))
   {
     rvar.all.unique.levels <- unlist(strsplit(rvar.all.unique.levels.transmit,split=","))
@@ -89,7 +90,7 @@ nfilter.tab<-force.nfilter.active
 #cvar
   if(!is.null(cvar.transmit))
 {
-    cvar<-eval(parse(text=cvar.transmit), envir = parent.frame())
+    cvar<-.loadServersideObject(cvar.transmit)
     if(!is.factor(cvar))
     {
       cvar.all.unique.levels <- unlist(strsplit(cvar.all.unique.levels.transmit,split=","))
@@ -107,7 +108,7 @@ cvar<-NULL
 #stvar
 if(!is.null(stvar.transmit))
 {
-  stvar<-eval(parse(text=stvar.transmit), envir = parent.frame())
+  stvar<-.loadServersideObject(stvar.transmit)
   if(!is.factor(stvar))
   {
     stvar.all.unique.levels<- unlist(strsplit(stvar.all.unique.levels.transmit,split=","))

R/tableDS.assign.R

@@ -33,13 +33,14 @@
 #' of \code{ds.table}. Fully specified by <useNA> argument of \code{ds.table}
 #' @return For information see help for \code{ds.table}
 #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 tableDS.assign<-function(rvar.transmit, cvar.transmit, stvar.transmit, rvar.all.unique.levels.transmit, cvar.all.unique.levels.transmit,
                   stvar.all.unique.levels.transmit, exclude.transmit, useNA.transmit){
 
 #Activate via eval when needed
 #rvar
-rvar<-eval(parse(text=rvar.transmit), envir = parent.frame())
+rvar<-.loadServersideObject(rvar.transmit)
 
 #coerce to factor if required
 if(!is.factor(rvar))
@@ -53,7 +54,7 @@ if(!is.factor(rvar))
 #cvar
 if(!is.null(cvar.transmit))
 {
-cvar<-eval(parse(text=cvar.transmit), envir = parent.frame())
+cvar<-.loadServersideObject(cvar.transmit)
 
 #coerce to factor if required
 if(!is.factor(cvar))
@@ -73,7 +74,7 @@ cvar<-NULL
 #stvar
 if(!is.null(stvar.transmit))
 {
-stvar<-eval(parse(text=stvar.transmit), envir = parent.frame())
+stvar<-.loadServersideObject(stvar.transmit)
 
 #coerce to factor if required
 if(!is.factor(stvar))

R/tableDS2.R

@@ -28,19 +28,18 @@
 #' For more information see help for \code{ds.table}
 #' @return For information see help for \code{ds.table}
 #' @author Paul Burton for DataSHIELD Development Team, 13/11/2019
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 tableDS2 <- function(newobj,rvar.transmit,cvar.transmit,stvar.transmit){
 
 
-calltext1<-paste0("out.table.real<-",newobj,"[[2]]")
-eval(parse(text=calltext1), envir = parent.frame())
+table.obj <- .loadServersideObject(newobj)
+out.table.real <- table.obj[[2]]
 out.table.cell.IDs<-as.vector(1:length(out.table.real))
 
-calltext2<-paste0("out.table.dim<-",newobj,"[[3]]")
-eval(parse(text=calltext2), envir = parent.frame())
+out.table.dim <- table.obj[[3]]
 
-calltext3<-paste0("out.table.dimnames<-",newobj,"[[4]]")
-eval(parse(text=calltext3), envir = parent.frame())
+out.table.dimnames <- table.obj[[4]]
 
 out.table.structure<-array(out.table.cell.IDs,dim=out.table.dim,dimnames=out.table.dimnames)