Refactor/perf batch 10

.circleci/config.yml

@@ -26,22 +26,8 @@ jobs:
       - run:
           command: |
               echo "options(Ncpus=4)" >> ~/.Rprofile
-              sudo Rscript -e "install.packages('RANN', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('stringr', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('lme4', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('dplyr', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('reshape2', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('polycor', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('splines', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('gamlss', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('gamlss.dist', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('mice', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('childsds', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('xml2', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('covr', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('devtools', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('DSI', dependencies=TRUE)"
-              sudo Rscript -e "install.packages('DSLite', dependencies=TRUE)"
+
+              sudo R -q -e "options(repos=c(CRAN=paste0('https://packagemanager.posit.co/cran/__linux__/', system('lsb_release -cs', intern=TRUE), '/latest')), HTTPUserAgent=sprintf('R/%s R (%s)', getRversion(), paste(getRversion(), R.version\$platform, R.version\$arch, R.version\$os)), Ncpus=4); install.packages(c('devtools','RANN','stringr','lme4','dplyr','reshape2','polycor','splines','gamlss','gamlss.dist','mice','data.table','childsds'), dependencies=TRUE)"
       - run:
           command: |
               sudo Rscript -e 'library(covr); covr::codecov(token = "'$CODECOV_TOKEN'")'

.gitignore

@@ -8,3 +8,4 @@
 .Rapp.history
 .claude
 .idea
+tests/testthat/Rplots.pdf

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,26 @@
 #' @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())
+  firstPart.name <- firstPart
+  sex <- .loadServersideObject(sex)
+  firstPart <- .loadServersideObject(firstPart)
+  .checkClass(obj = firstPart, obj_name = firstPart.name, permitted_classes = "numeric")
+  if (!is.na(secondPart)){
+    secondPart.name <- secondPart
+    secondPart <- .loadServersideObject(secondPart)
+    .checkClass(obj = secondPart, obj_name = secondPart.name, permitted_classes = "numeric")
+  }
   if (!is.na(thirdPart)){
-    thirdPart <- eval(parse(text=thirdPart), envir = parent.frame())
+    thirdPart.name <- thirdPart
+    thirdPart <- .loadServersideObject(thirdPart)
+    if (index == "bfa"){
+      .checkClass(obj = thirdPart, obj_name = thirdPart.name, permitted_classes = "numeric")
+    }
   }
 
   # 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/isValidDS.R

@@ -2,12 +2,33 @@
 #' @title Checks if an input is valid
 #' @description Tells if an object on the server side is valid.
 #' @details This function checks if an object is valid.
-#' @param obj, a vector (numeric, integer, factor, character), data.frame or matrix
-#' @return a boolean, TRUE if input is valid or FALSE if not.
+#' @param x a character string, the name of a vector (numeric, integer, factor, character,
+#' logical), data.frame or matrix
+#' @return a list with \code{valid}, a boolean that is TRUE if the input is valid or FALSE
+#' if not, and \code{class}, the class of the input object for client-side consistency
+#' checking
 #' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #'@export
 #'
-isValidDS <- function(obj) {
+isValidDS <- function(x) {
+
+  obj <- .loadServersideObject(x)
+  .checkClass(
+    obj = obj,
+    obj_name = x,
+    permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix")
+  )
+
+  list(valid = .checkDisclosureSize(obj), class = class(obj))
+}
+
+#' Check a Server-Side Object Meets the Disclosure Size Threshold
+#'
+#' @param obj The object to check: a vector, data.frame or matrix.
+#' @return A boolean, TRUE if the object meets the threshold or FALSE if not.
+#' @noRd
+.checkDisclosureSize <- function(obj) {
 
   # this filter sets the minimum number of observations that are allowed 
 

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())
+  endtime <- .loadServersideObject(exitCol)
+  starttime <- if(is.null(entryCol)) rep(0, length(endtime)) else .loadServersideObject(entryCol)
+  cens <- .loadServersideObject(statusCol)
+  id.orig <- .loadServersideObject(idCol)
 
   starttime <- as.numeric(starttime)
   endtime <- as.numeric(endtime)
@@ -73,14 +74,21 @@ lexisDS2 <- function(datatext=NULL, intervalWidth, maxmaxtime, idCol, entryCol,
 
   #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())
-  }
-
-  if(!is.null(vartext)){
-    vartext2<-paste0("data.frame(",vartext,")")
-    DF<-eval(parse(text=vartext2), envir = parent.frame())
+  # 'vartext' takes precedence over 'datatext'. A data.frame name is unpacked into its
+  # columns and a single column such as D$var is named make.names("D$var"), matching
+  # how data.frame() named them when the names were parsed as R code.
+  carried.text <- if(is.null(vartext)) datatext else vartext
+  if(!is.null(carried.text)){
+    col.list <- list()
+    for(nm in unlist(strsplit(carried.text, split=","))){
+      obj <- .loadServersideObject(nm)
+      if(is.data.frame(obj)){
+        col.list <- c(col.list, as.list(obj))
+      }else{
+        col.list <- c(col.list, stats::setNames(list(obj), make.names(nm)))
+      }
+    }
+    DF <- data.frame(col.list)
   }
 
   if(is.null(datatext)&&is.null(vartext)){

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/quantileMeanDS.R

@@ -16,7 +16,7 @@ quantileMeanDS <- function (x) {
   .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer"))
 
   # check if the input vector is valid (i.e. meets DataSHIELD criteria)
-  check <- isValidDS(xvect)
+  check <- .checkDisclosureSize(xvect)
 
   if(check){
     # if the input vector is valid

R/rangeDS.R

@@ -2,12 +2,16 @@
 #' @title returns the minimum and maximum of a numeric vector
 #' @description this function is similar to R function \code{range} but instead to not return
 #' the real minimum and maximum, the computed values are multiplied by a very small random number.
-#' @param xvect a numerical
+#' @param x a character string, the name of a numeric or integer vector
 #' @return a numeric vector which contains the minimum and the maximum values of the vector
 #' @author Amadou Gaye, Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
-rangeDS <- function(xvect) {
+rangeDS <- function(x) {
+  xvect <- .loadServersideObject(x)
+  .checkClass(obj = xvect, obj_name = x, permitted_classes = c("numeric", "integer"))
+
   # back-up current .Random.seed and revert on.exit
   if (exists(x = ".Random.seed", envir = globalenv())) {
       assign(x = ".old_seed", value = .Random.seed, envir = parent.frame());

R/recodeLevelsDS.R

@@ -14,7 +14,7 @@ recodeLevelsDS <- function (x=NULL, classes=NULL){
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot'))
 
   # check if the input vector is valid (i.e. meets DataSHIELD criteria)
-  check <- isValidDS(x)
+  check <- .checkDisclosureSize(x)
 
   if(check){
     # generate the new variable with the specified levels

R/replaceNaDS.R

@@ -21,7 +21,7 @@ replaceNaDS <- function(x, replacements){
   xvect <- .loadServersideObject(x)
 
   # check if the input vector is valid (i.e. meets DataSHIELD criteria)
-  check <- dsBase::isValidDS(xvect)
+  check <- .checkDisclosureSize(xvect)
 
   # if the input vector is a factor convert it to numeric
   cls <- class(xvect)

R/rowColCalcDS.R

@@ -4,15 +4,23 @@
 #' '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"))
+  column.classes <- lapply(as.data.frame(dataset), class)
+  if(!all(vapply(column.classes, function(cls) any(cls %in% c("numeric", "integer")), logical(1)))){
+    stop("One or more columns of '", dataset.name, "' are not of numeric type", call. = FALSE)
+  }
+
   if(operation == 1){
     result <- rowSums(dataset, na.rm=TRUE)
   }
@@ -27,7 +35,7 @@ rowColCalcDS <- function (dataset, operation) {
   }
 
   # check if the output is valid (i.e. meets DataSHIELD criteria)
-  check <- isValidDS(result)
+  check <- .checkDisclosureSize(result)
   if(check){
     return(result)
   }else{