V7.0 dev

DESCRIPTION

@@ -79,7 +79,7 @@ Imports:
 Suggests:
     spelling,
     testthat (>= 3.0.0)
-RoxygenNote: 8.0.0
 Encoding: UTF-8
 Language: en-GB
 Config/testthat/edition: 3
+Config/roxygen2/version: 8.1.0

NAMESPACE

@@ -146,17 +146,27 @@ import(dplyr)
 import(gamlss)
 import(gamlss.dist)
 import(mice)
-importFrom(dplyr,"%>%")
-importFrom(dplyr,across)
-importFrom(dplyr,mutate)
-importFrom(dplyr,select)
-importFrom(gamlss.dist,pST3)
-importFrom(gamlss.dist,qST3)
-importFrom(glue,glue)
-importFrom(glue,glue_collapse)
-importFrom(purrr,imap)
-importFrom(purrr,map)
-importFrom(purrr,set_names)
+importFrom(dplyr,
+  "%>%",
+  across,
+  mutate,
+  select
+)
+importFrom(gamlss.dist,
+  pST3,
+  qST3
+)
+importFrom(glue,
+  glue,
+  glue_collapse
+)
+importFrom(purrr,
+  imap,
+  map,
+  set_names
+)
 importFrom(tibble,as_tibble)
-importFrom(tidyselect,all_of)
-importFrom(tidyselect,peek_vars)
+importFrom(tidyselect,
+  all_of,
+  peek_vars
+)

R/asFactorDS1.R

@@ -7,6 +7,7 @@
 #' are of type character.
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @return the levels of the input variable.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorDS1 <- function(input.var.name=NULL){
@@ -24,7 +25,7 @@ asFactorDS1 <- function(input.var.name=NULL){
   nfilter.levels.max <- as.numeric(thr$nfilter.levels.max)         #
   ##################################################################
 
-  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+  input.var <- .loadServersideObject(input.var.name)
   factor.levels.present.in.source <- levels(factor(input.var))
   num.levels<-length(factor.levels.present.in.source)
 

R/asFactorDS2.R

@@ -15,11 +15,12 @@
 #' @param baseline.level a number indicating the baseline level to be used in the creation of the
 #' matrix of dummy variables.
 #' @return an object of class factor
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorDS2 <- function(input.var.name=NULL, all.unique.levels.transmit=NULL, fixed.dummy.vars=NULL, baseline.level=NULL){
 
-  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+  input.var <- .loadServersideObject(input.var.name)
 
   code.input <- all.unique.levels.transmit
   code.c <- unlist(strsplit(code.input, split=","))

R/asFactorSimpleDS.R

@@ -12,11 +12,12 @@
 #' of these things you will have to use the ds.asFactor function.
 #' @param input.var.name the name of the variable that is to be converted to a factor.
 #' @return an object of class factor
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 asFactorSimpleDS <- function(input.var.name=NULL){
 
-    input.var <- eval(parse(text=input.var.name), envir = parent.frame())
+    input.var <- .loadServersideObject(input.var.name)
 
     factor.obj <- factor(input.var)
 

R/changeRefGroupDS.R

@@ -7,16 +7,20 @@
 #' as this can introduce a mismatch of values if the vector is put back
 #' into a table that is not reordered in the same way. Such mismatch
 #' can render the results of operations on that table invalid.
-#' @param xvect a factor vector
+#' @param x a character string, the name of a factor vector.
 #' @param ref a character, the reference level
-#' @param reorderByRef a boolean that tells whether or not the new 
+#' @param reorderByRef a boolean that tells whether or not the new
 #' vector should be ordered by the reference group.
-#' @return  a factor of the same length as xvect
+#' @return  a factor of the same length as the input vector
 #' @author Isaeva, J., Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){
-
+changeRefGroupDS <- function(x, ref=NULL, reorderByRef=NULL){
+
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = "factor")
+
   if(reorderByRef){
     temp_xvect = stats::relevel(xvect, ref)
     # now reorder puting the ref group first
@@ -26,7 +30,7 @@ changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){
   }else{
     new_xvect <- stats::relevel(xvect, ref)
   }
-  
+
   return(new_xvect)
-  
+
 }

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
   }