Refactor/perf batch 7

R/gamlssDS.R

@@ -69,6 +69,7 @@
 #' residuals (the normalised quantile residuals of the model) are not disclosed to 
 #' the client-side.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @import gamlss
 #' @import gamlss.dist
 #' @export
@@ -81,8 +82,9 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu
 
   thr <- dsBase::listDisclosureSettingsDS()
   nfilter.glm <- as.numeric(thr$nfilter.glm)
-
-  data <- eval(parse(text = data), envir = parent.frame())
+
+  data <- .loadServersideObject(data)
+  .checkClass(obj = data, obj_name = "data", permitted_classes = c("data.frame", "matrix"))
 
   family <- gsub("left_parenthesis", "(", family, fixed = TRUE)
   family <- gsub("right_parenthesis", ")", family, fixed = TRUE)
@@ -187,8 +189,8 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu
   base::assign(newobj, results$residuals, envir = parent.frame())
 
   if(centiles==TRUE){
-    xvar <- eval(parse(text=xvar), envir = parent.frame())
-    centiles_out <- gamlss::centiles(obj = results, xvar = xvar, points = FALSE, 
+    xvar <- .loadServersideObject(xvar)
+    centiles_out <- gamlss::centiles(obj = results, xvar = xvar, points = FALSE,
                                      save = TRUE)
   }else{
     centiles_out <- NA

R/glmDS1.R

@@ -19,6 +19,7 @@
 #' @return List with values from GLM model.
 #' 
 #' @author Burton PR for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 glmDS1 <- function(formula, family, weights, offset, data){
@@ -41,7 +42,8 @@ nfilter.glm <- as.numeric(thr$nfilter.glm)
   if(is.null(data)){
     dataTable <- NULL 
   }else{
-    dataTable <- eval(parse(text=data), envir = parent.frame())
+    dataTable <- .loadServersideObject(data)
+    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix"))
   }
 
   formulatext <- Reduce(paste, deparse(formula))

R/glmDS2.R

@@ -20,6 +20,7 @@
 #' the data to be analysed under the specified model same 
 #' 
 #' @author Paul Burton, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
 #' @return List with values from GLM model
 #' @export
@@ -39,7 +40,8 @@ glmDS2 <- function (formula, family, beta.vect, offset, weights, dataName) {
   # Same is done for offset and weights lower down function
 
   if(!is.null(dataName)){
-    dataDF <- eval(parse(text=dataName), envir = parent.frame())
+    dataDF <- .loadServersideObject(dataName)
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
   }else{
     dataDF <- NULL
   }

R/glmPredictDS.ag.R

@@ -34,6 +34,7 @@
 #' ds.glmPredict and glmPredict.as and help in native R for predict.glm
 #' predict.glm in native R
 #' @author Paul Burton for DataSHIELD Development Team (20/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 glmPredictDS.ag <- function(glmname.transmit, newdataname.transmit,
@@ -148,13 +149,11 @@ if(!string.safe)
 }
 
 #Activate all arguments
-#glmobj<-eval(parse(text=glmname.transmit))
-glmobj<-get(glmname.transmit)
+glmobj <- .loadServersideObject(glmname.transmit)
 
 if(!is.null(newdataname.transmit))
 	{
-	newdf<-get(newdataname.transmit)
-#	newdf<-geeval(parse(text=newdataname.transmit))
+	newdf <- .loadServersideObject(newdataname.transmit)
 	}else{
 	newdf<-NULL
 	}

R/glmPredictDS.as.R

@@ -32,6 +32,7 @@
 #' For more details see DataSHIELD help for ds.glmPredict and help for
 #' predict.glm in native R
 #' @author Paul Burton for DataSHIELD Development Team (20/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 glmPredictDS.as <- function(glmname.transmit, newdataname.transmit,
                             output.type,se.fit, dispersion, terms.transmit, na.action){
@@ -142,13 +143,11 @@ if(!string.safe)
 }
 
 #Activate all arguments
-#glmobj<-eval(parse(text=glmname.transmit))
-glmobj<-get(glmname.transmit)
+glmobj <- .loadServersideObject(glmname.transmit)
 
 if(!is.null(newdataname.transmit))
 	{
-	newdf<-get(newdataname.transmit)
-#	newdf<-geeval(parse(text=newdataname.transmit))
+	newdf <- .loadServersideObject(newdataname.transmit)
 	}else{
 	newdf<-NULL
 	}

R/glmSLMADS1.R

@@ -17,6 +17,7 @@
 #' such as test of model complexity (saturation).
 #' For more detailed information see help for ds.glmSLMA.
 #' @author Paul Burton for DataSHIELD Development Team (14/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 
 glmSLMADS1<- function(formula, family, weights, offset, data){
@@ -51,7 +52,8 @@ final.family.object<-eval(parse(text=family))
   if(is.null(data)){
     dataTable <- NULL 
   }else{
-    dataTable <- eval(parse(text=data), envir = parent.frame())
+    dataTable <- .loadServersideObject(data)
+    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix"))
   }
 
 

R/glmSLMADS2.R

@@ -22,6 +22,7 @@
 #' in particular including the study-specific regression coefficients and their corresponding
 #' standard errors.
 #' @author Paul Burton for DataSHIELD Development Team (14/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 glmSLMADS2 <- function(formula, family, offset, weights, newobj, dataName){
 
@@ -52,7 +53,8 @@ errorMessage2<-"No errors"
 # Same is done for offset and weights lower down function
 
   if(!is.null(dataName)){
-    dataDF <- eval(parse(text=dataName), envir = parent.frame())
+    dataDF <- .loadServersideObject(dataName)
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
   }else{
 	dataDF<-NULL
 	}
@@ -102,8 +104,7 @@ errorMessage2<-"No errors"
 #bringing back in the mg output saved from that previous call
 #	mg <- stats::glm(formula2use, family=final.family.object, x=TRUE, offset=offset.to.use, weights=weights.to.use, data=dataDF)
 
-activate.text<- paste0("mg<-",newobj)
-eval(parse(text=activate.text))
+mg <- .loadServersideObject(newobj)
 
 y.vect<-mg$y
 X.mat<-mg$x

R/glmSummaryDS.ag.R

@@ -17,6 +17,7 @@
 #' elements (and only the non-disclosive elements) of a specified serverside glm
 #' and its corresponding summary_glm object.
 #' @author Paul Burton for DataSHIELD Development Team (20/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 
 glmSummaryDS.ag <- function(x.transmit){
@@ -55,7 +56,7 @@ if(!string.safe)
 #create safe glm object with disclosive elements deleted for clientside
 #######################################################################
 
-input.obj<-eval(parse(text=x.transmit))
+input.obj <- .loadServersideObject(x.transmit)
 
 
 if (is.null(input.obj)) {
@@ -90,7 +91,7 @@ glm.obj<-input.obj
 #create safe summary.glm object with disclosive elements deleted for clientside
 ###############################################################################
 
-input.obj<-eval(parse(text=x.transmit))
+input.obj <- .loadServersideObject(x.transmit)
 
 summary.obj<-summary(input.obj)
 

R/glmSummaryDS.as.R

@@ -15,6 +15,7 @@
 #' @return writes object to serverside which is precisely equivalent
 #' to summary(glm object) in native R
 #' @author Paul Burton for DataSHIELD Development Team (20/7/20)
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 
 glmSummaryDS.as <- function(x.transmit){
@@ -52,13 +53,13 @@ if(!string.safe)
 
 #create summary.glm object
 
-input.obj<-eval(parse(text=x.transmit))
+input.obj <- .loadServersideObject(x.transmit)
 
 summary.obj<-summary(input.obj)
 
 #block na.action and deviance residual components of summary object
-summary.obj[[12]]<-NA
-summary.obj[[11]]<-NA
+if (!is.null(summary.obj$na.action)) summary.obj$na.action<-NA
+summary.obj$deviance.resid<-NA
 
 summary.obj<-summary.obj
 

R/glmerSLMADS.assign.R

@@ -29,6 +29,7 @@
 #' @return writes glmerMod object summarising the fitted model to the serverside.
 #' For more detailed information see help for ds.glmerSLMA.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 glmerSLMADS.assign <- function(formula, offset, weights, dataName, family,
                 control_type=NULL, control_value.transmit=NULL, nAGQ=1L, verbose = 0, theta = NULL, fixef = NULL){
@@ -46,7 +47,8 @@ glmerSLMADS.assign <- function(formula, offset, weights, dataName, family,
   # Same is done for offset and weights lower down function
 
   if(!is.null(dataName)){
-    dataDF <- eval(parse(text=dataName), envir = parent.frame())
+    dataDF <- .loadServersideObject(dataName)
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
   }else{
     dataDF <- NULL
   }

R/glmerSLMADS2.R

@@ -36,6 +36,7 @@
 #' function ds.glmerSLMA
 #' @return all key model components see help for ds.glmerSLMA
 #' @author Tom Bishop, with some additions by Paul Burton
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 glmerSLMADS2 <- function(formula, offset, weights, dataName, family,
                 control_type=NULL, control_value.transmit=NULL, nAGQ=1L, verbose = 0, theta = NULL, fixef = NULL){
@@ -53,7 +54,8 @@ glmerSLMADS2 <- function(formula, offset, weights, dataName, family,
   # Same is done for offset and weights lower down function
 
   if(!is.null(dataName)){
-    dataDF <- eval(parse(text=dataName), envir = parent.frame())
+    dataDF <- .loadServersideObject(dataName)
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
   }else{
     dataDF <- NULL
   }

R/lmerSLMADS.assign.R

@@ -18,6 +18,7 @@
 #' @return writes lmerMod object summarising the fitted model to the serverside.
 #' For more detailed information see help for ds.lmerSLMA.
 #' @author TDemetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE,
 			   control_type, control_value.transmit, optimizer, verbose=0){
@@ -37,7 +38,8 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE,
   # Same is done for offset and weights lower down function
 
   if(!is.null(dataName)){
-    dataDF <- eval(parse(text=dataName), envir = parent.frame())
+    dataDF <- .loadServersideObject(dataName)
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
   }else{
     dataDF <- NULL
   }
@@ -124,39 +126,44 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE,
 
    ################################################################## 
    #sort out offset and weights
+   #
+   # offset.to.use/weights.to.use are needed in two different environments:
+   # stats::glm() below resolves them via environment(formula2use), which is
+   # this function's *caller* (matching where the other formula variables are
+   # assigned, see the model.variables loop above); lme4::lmer() further down
+   # resolves them relative to its own call frame, i.e. this function's *own*
+   # frame. Assign to both so each modelling call finds them.
    if(is.null(offset))
    {
      varname.offset<-NULL
-     #offset.to.use <- NULL
-     cbindtext.offset <- paste0("offset.to.use <- NULL")
-     eval(parse(text=cbindtext.offset), envir = parent.frame())
+     offset.to.use <- NULL
+     assign("offset.to.use", NULL, envir = parent.frame())
    }else{
      varname.offset <- paste0(offset)
    }
-   
+
    if(!(is.null(offset)))
    {
-     cbindtext.offset <- paste0("offset.to.use <- cbind(", offset,")")
-     eval(parse(text=cbindtext.offset), envir = parent.frame())
+     cbindtext.offset <- paste0("cbind(", offset,")")
+     offset.to.use <- eval(parse(text=cbindtext.offset), envir = parent.frame())
+     assign("offset.to.use", offset.to.use, envir = parent.frame())
    }
-   
+
    if(is.null(weights))
    {
      varname.weights<-NULL
-     cbindtext.weights <- paste0("weights.to.use <- NULL")
-     eval(parse(text=cbindtext.weights), envir = parent.frame())
-     #weights.to.use <- NULL
+     weights.to.use <- NULL
+     assign("weights.to.use", NULL, envir = parent.frame())
    }else{
      varname.weights <- paste0(weights)
    }
-   
-   
+
+
    if(!(is.null(weights)))
    {
-     cbindtext.weights <- paste0("weights.to.use <- cbind(", weights,")")
-     eval(parse(text=cbindtext.weights), envir = parent.frame())
-     #cbindtext.weights <- paste0("cbind(", weights,")")
-     #weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame())
+     cbindtext.weights <- paste0("cbind(", weights,")")
+     weights.to.use <- eval(parse(text=cbindtext.weights), envir = parent.frame())
+     assign("weights.to.use", weights.to.use, envir = parent.frame())
    }
 
   #### BEFORE going further we use the glm1 checks
@@ -357,11 +364,10 @@ if(!is.null(optimizer)&&optimizer!="nloptwrap")
 	}
 
 
-    mg <- lme4::lmer(formula2use, offset=offset, weights=weights, data=dataDF, REML = REML, verbose = verbose, control = control.obj)
-    #iterations <- utils::capture.output(try(mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj)))
+    mg <- lme4::lmer(formula2use, offset=offset.to.use, weights=weights.to.use, data=dataDF, REML = REML, verbose = verbose, control = control.obj)
 
     outlist <- mg
-    
+
   }
   #tidy up in parent.frame()
   eval(quote(rm(offset.to.use)), envir = parent.frame())