Refactor/fixes

R/BooleDS.R

@@ -53,9 +53,13 @@ thr <- dsBase::listDisclosureSettingsDS()                               #
 
 V1<-.loadServersideObject(V1.name)
 
-# V2 may be either a server-side object name or a literal scalar (e.g. "3", "-1")
+# V2 may be either a server-side object name or a literal scalar (e.g. "3", "-1", "TRUE", "NA")
 V2.numeric <- suppressWarnings(as.numeric(V2.name))
-if(!is.na(V2.numeric)){
+if(V2.name %in% c("TRUE", "FALSE")){
+  V2 <- as.logical(V2.name)
+}else if(V2.name == "NA"){
+  V2 <- NA
+}else if(!is.na(V2.numeric)){
   V2 <- V2.numeric
 }else{
   V2 <- .loadServersideObject(V2.name)

R/asListDS.R

@@ -1,32 +1,21 @@
-#' @title asListDS a serverside aggregate function called by ds.asList
+#' @title asListDS a serverside assign function called by ds.asList
 #' @description Coerces an R object into a list
-#' @details Unlike most other class coercing functions this is
-#' an aggregate function rather than an assign function. This
-#' is because the \code{datashield.assign} function in the data repository deals specially with
-#' a created object (newobj) if it is of class list. Reconfiguring the
-#' function as an aggregate function works around this problem.
-#' This aggregate function is based on the native R function \code{as.list}
+#' @details This assign function is based on the native R function \code{as.list}
 #' and so additional information can be found in the help for \code{as.list}
 #' @param x.name the name of the input object to be coerced to class
 #' data.matrix. Must be specified in inverted commas. But this argument is
 #' usually specified directly by <x.name> argument of the clientside function
 #' \code{ds.asList}
-#' @param newobj is the object hard assigned '<<-' to be the output of the
-#' function written to the serverside
-#' @return the object specified by the <newobj> argument (or its default name
-#' <x.name>.mat) which is written to the serverside.
-#' In addition, two validity messages are returned. The first confirms an output
-#' object has been created, the second states its class. The way that \code{as.list}
-#' coerces objects to list depends on the class of the object, but in general
-#' the class of the output object should usually be 'list'
+#' @return the input object coerced to a list, which \code{ds.asList} writes to the
+#' serverside. The way that \code{as.list} coerces objects to list depends on the class
+#' of the object
 #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team
 #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
-asListDS <- function (x.name, newobj){
+asListDS <- function (x.name){
   x <- .loadServersideObject(x.name)
 
-  result <- as.list(x)
-  assign(newobj, result, envir = parent.frame())
+  as.list(x)
 }
-# AGGREGATE FUNCTION
+# ASSIGN FUNCTION
 # asListDS

R/aucDS.R

@@ -8,16 +8,13 @@
 #' the complete cases that are used in the regression model.
 #' @return returns the AUC and its standard error
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 aucDS <- function(pred=pred, y=y){
 
-  if(is.character(pred)){
-    pred <- eval(parse(text = pred), envir = parent.frame())
-  }
-  if(is.character(y)){
-    y <- eval(parse(text = y), envir = parent.frame())
-  }
+  pred <- .loadServersideObject(pred)
+  y <- .loadServersideObject(y)
 
   y <- as.numeric(as.character(y))
 

R/bp_standardsDS.R

@@ -20,23 +20,16 @@
 #' @note The z-scores of height based on CDC growth charts are calculated 
 #' by the sds function from the childsds R package.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @import childsds
 #' @export
 #' 
 bp_standardsDS <- function(sex=sex, age=age, height=height, bp=bp, systolic=systolic){
 
-  if(is.character(sex)){
-    sex <- eval(parse(text = sex), envir = parent.frame())
-  }
-  if(is.character(age)){
-    age <- eval(parse(text = age), envir = parent.frame())
-  }
-  if(is.character(height)){
-    height <- eval(parse(text = height), envir = parent.frame())
-  }
-  if(is.character(bp)){
-    bp <- eval(parse(text = bp), envir = parent.frame())
-  }
+  sex <- .loadServersideObject(sex)
+  age <- .loadServersideObject(age)
+  height <- .loadServersideObject(height)
+  bp <- .loadServersideObject(bp)
 
   # convert height to a Z-score relative to age and sex based on CDC growth charts
   Zht <- sds(value=height, age=age, sex=sex, male="1", female="2",

R/corDS.R

@@ -32,7 +32,7 @@ corDS <- function(x=NULL, y=NULL){
   x.val <- .loadServersideObject(x)
   .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
 
-  if (!is.null(y)){
+  if (!is.null(y) && !any(class(x.val) %in% c("matrix", "data.frame"))){
     y.val <- .loadServersideObject(y)
     .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
   }

R/covDS.R

@@ -41,7 +41,7 @@ covDS <- function(x=NULL, y=NULL, use=NULL){
   x.val <- .loadServersideObject(x)
   .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
 
-  if (!is.null(y)){
+  if (!is.null(y) && !any(class(x.val) %in% c("matrix", "data.frame"))){
     y.val <- .loadServersideObject(y)
     .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
   }

R/dataFrameSortDS.R

@@ -30,8 +30,8 @@
 #' R environment as a data.frame named according to the <newobj> argument(or with
 #' default name 'dataframesort.newobj') if no name is specified
 #' @author Paul Burton, with critical error identification by
-#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' Leire Abarrategui-Martinez, for DataSHIELD Development Team, 2/4/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 dataFrameSortDS <- function(df.name=NULL,sort.key.name=NULL,sort.descending,sort.method){

R/dimDS.R

@@ -11,7 +11,6 @@
 #'
 dimDS <- function(x){
   x.val <- .loadServersideObject(x)
-  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix"))
   list(dim = dim(x.val), class = class(x.val))
 }
 #AGGREGATE FUNCTION

R/gamlssDS.R

@@ -83,8 +83,9 @@ gamlssDS <- function(formula=formula, sigma.formula=sigma.formula, nu.formula=nu
   thr <- dsBase::listDisclosureSettingsDS()
   nfilter.glm <- as.numeric(thr$nfilter.glm)
 
-  data <- .loadServersideObject(data)
-  .checkClass(obj = data, obj_name = "data", permitted_classes = c("data.frame", "matrix"))
+  data.name <- data
+  data <- .loadServersideObject(data.name)
+  .checkClass(obj = data, obj_name = data.name, permitted_classes = c("data.frame", "list"))
 
   family <- gsub("left_parenthesis", "(", family, fixed = TRUE)
   family <- gsub("right_parenthesis", ")", family, fixed = TRUE)

R/glmDS1.R

@@ -43,7 +43,7 @@ nfilter.glm <- as.numeric(thr$nfilter.glm)
     dataTable <- NULL 
   }else{
     dataTable <- .loadServersideObject(data)
-    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "list"))
   }
 
   formulatext <- Reduce(paste, deparse(formula))

R/glmDS2.R

@@ -41,7 +41,7 @@ glmDS2 <- function (formula, family, beta.vect, offset, weights, dataName) {
 
   if(!is.null(dataName)){
     dataDF <- .loadServersideObject(dataName)
-    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "list"))
   }else{
     dataDF <- NULL
   }

R/glmSLMADS1.R

@@ -53,7 +53,7 @@ final.family.object<-eval(parse(text=family))
     dataTable <- NULL 
   }else{
     dataTable <- .loadServersideObject(data)
-    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataTable, obj_name = data, permitted_classes = c("data.frame", "list"))
   }
 
 

R/glmSLMADS2.R

@@ -54,7 +54,7 @@ errorMessage2<-"No errors"
 
   if(!is.null(dataName)){
     dataDF <- .loadServersideObject(dataName)
-    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "list"))
   }else{
 	dataDF<-NULL
 	}

R/glmerSLMADS.assign.R

@@ -48,7 +48,7 @@ glmerSLMADS.assign <- function(formula, offset, weights, dataName, family,
 
   if(!is.null(dataName)){
     dataDF <- .loadServersideObject(dataName)
-    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "list"))
   }else{
     dataDF <- NULL
   }

R/glmerSLMADS2.R

@@ -55,7 +55,7 @@ glmerSLMADS2 <- function(formula, offset, weights, dataName, family,
 
   if(!is.null(dataName)){
     dataDF <- .loadServersideObject(dataName)
-    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "list"))
   }else{
     dataDF <- NULL
   }

R/igb_standardsDS.R

@@ -17,6 +17,7 @@
 #' standard is used.
 #' @return assigns the converted measurement as a new object on the server-side
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @import dplyr
 #' @importFrom gamlss.dist qST3 pST3
 #' @export
@@ -228,15 +229,11 @@ igb_standardsDS <- function(gagebrth=gagebrth, z=z, p=p, val=val, var=var, sex=s
 
 
   # Start the analysis
-  if(is.character(gagebrth)){
-    gagebrth <- eval(parse(text = gagebrth), envir = parent.frame())
-  }
-  if(is.character(val)){
-    val <- eval(parse(text = val), envir = parent.frame())
-  }
-  if(is.character(sex)){
-    sex <- eval(parse(text = sex), envir = parent.frame())
+  gagebrth <- .loadServersideObject(gagebrth)
+  if(!is.null(val)){
+    val <- .loadServersideObject(val)
   }
+  sex <- .loadServersideObject(sex)
 
   x.out <- rep(NA, t=length(sex))
   idx.males <- which(sex=="Male")

R/lengthDS.R

@@ -12,7 +12,6 @@
 #'
 lengthDS <- function(x){
   x.val <- .loadServersideObject(x)
-  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list", "data.frame", "array", "matrix"))
   list(length = length(x.val), class = class(x.val))
 }
 #AGGREGATE FUNCTION

R/levelsDS.R

@@ -2,7 +2,7 @@
 #' @title Returns the levels of a factor vector
 #' @description This function is similar to R function \code{levels}.
 #' @details The function returns the levels of the input vector or list.
-#' @param x a factor vector
+#' @param x a character string, the name of a factor vector
 #' @return a list with one element: \code{Levels} (the factor levels present
 #'   in the vector)
 #' @author Alex Westerberg, for DataSHIELD Development Team
@@ -11,12 +11,12 @@
 #'
 levelsDS <- function(x){
 
-  x.val <- .loadServersideObject(x)
-  .checkClass(obj = x.val, obj_name = x, permitted_classes = "factor")
-
   # Check Permissive Privacy Control Level.
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot'))
 
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = "factor")
+
   ##################################################################
   #MODULE 1: CAPTURE THE nfilter SETTINGS                          #
   thr <- dsBase::listDisclosureSettingsDS()                        #

R/lmerSLMADS.assign.R

@@ -39,7 +39,7 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE,
 
   if(!is.null(dataName)){
     dataDF <- .loadServersideObject(dataName)
-    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "list"))
   }else{
     dataDF <- NULL
   }
@@ -126,13 +126,9 @@ 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.
+   # stats::glm() finds offset.to.use/weights.to.use in the caller's frame
+   # (environment(formula2use)) but lme4::lmer() in this function's own frame,
+   # so they are assigned in both.
    if(is.null(offset))
    {
      varname.offset<-NULL
@@ -141,14 +137,14 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE,
    }else{
      varname.offset <- paste0(offset)
    }
-
+   
    if(!(is.null(offset)))
    {
      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
@@ -157,8 +153,8 @@ lmerSLMADS.assign <- function(formula, offset, weights, dataName, REML = TRUE,
    }else{
      varname.weights <- paste0(weights)
    }
-
-
+   
+   
    if(!(is.null(weights)))
    {
      cbindtext.weights <- paste0("cbind(", weights,")")
@@ -367,7 +363,7 @@ if(!is.null(optimizer)&&optimizer!="nloptwrap")
     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())

R/lmerSLMADS2.R

@@ -48,7 +48,7 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE,
 
   if(!is.null(dataName)){
     dataDF <- .loadServersideObject(dataName)
-    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "matrix"))
+    .checkClass(obj = dataDF, obj_name = dataName, permitted_classes = c("data.frame", "list"))
   }else{
     dataDF <- NULL
   }
@@ -135,13 +135,9 @@ lmerSLMADS2 <- 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.
+   # stats::glm() finds offset.to.use/weights.to.use in the caller's frame
+   # (environment(formula2use)) but lme4::lmer() in this function's own frame,
+   # so they are assigned in both.
    if(is.null(offset))
    {
      varname.offset<-NULL
@@ -150,14 +146,14 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE,
    }else{
      varname.offset <- paste0(offset)
    }
-
+   
    if(!(is.null(offset)))
    {
      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
@@ -166,8 +162,8 @@ lmerSLMADS2 <- function(formula, offset, weights, dataName, REML = TRUE,
    }else{
      varname.weights <- paste0(weights)
    }
-
-
+   
+   
    if(!(is.null(weights)))
    {
      cbindtext.weights <- paste0("cbind(", weights,")")