V7.0 dev update 20260726

.Rbuildignore

@@ -13,3 +13,5 @@
 ^cran-comments\.md$
 ^pull_request_template$
 PULL_REQUEST_TEMPLATE.md
+.claude
+.idea

.circleci/config.yml

@@ -22,7 +22,7 @@ jobs:
               sudo apt-get install -y r-base-core cmake
       - run:
           command: |
-              sudo apt-get install -y libxml2-dev
+              sudo apt-get install -y libxml2-dev libuv1-dev
       - run:
           command: |
               echo "options(Ncpus=4)" >> ~/.Rprofile

.github/workflows/dsBase_test_suite.yaml

@@ -15,7 +15,6 @@ on:
   push:
   schedule:
     - cron: '0 0 * * 0'   # Weekly
-    - cron: '0 1 * * *'   # Nightly
 
 jobs:
   dsBase_test_suite:
@@ -153,28 +152,30 @@ jobs:
           echo "branch:${{ env.BRANCH_NAME }}" > ${{ env.WORKFLOW_ID }}.txt
           echo "os:$(lsb_release -ds)" >> ${{ env.WORKFLOW_ID }}.txt
           echo "R:$(R --version | head -n1)" >> ${{ env.WORKFLOW_ID }}.txt
+          Rscript --vanilla -e 'sessionInfo()' >> session_info_${{ env.WORKFLOW_ID }}.txt
         working-directory: dsBase/logs
 
       - name: Parse results from testthat and covr
         run: |
-          Rscript --verbose --vanilla ../testStatus/source/parse_test_report.R logs/
+          Rscript --verbose --vanilla ../testStatus/source/parse_test_report.R logs/ logs/ https://github.com/datashield/${{ env.PROJECT_NAME }}/blob/${{ env.BRANCH_NAME }} '[^-:.]+' '(?<=::)[^:]+(?=::)'
         working-directory: dsBase
+        env:
+          PROJECT_NAME: ${{ env.PROJECT_NAME }}
+          BRANCH_NAME: ${{ env.BRANCH_NAME }}
 
       - name: Render report
         run: |
           cd testStatus
 
           mkdir -p new/logs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
-          mkdir -p new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
           mkdir -p new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/latest/
 
           # Copy logs to new logs directory location
           cp -rv ../${{ env.PROJECT_NAME }}/logs/* new/logs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
           cp -rv ../${{ env.PROJECT_NAME }}/logs/${{ env.WORKFLOW_ID }}.txt new/logs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
 
           R -e 'input_dir <- file.path("../new/logs", Sys.getenv("PROJECT_NAME"), Sys.getenv("BRANCH_NAME"), Sys.getenv("WORKFLOW_ID")); quarto::quarto_render("source/test_report.qmd", execute_params = list(input_dir = input_dir))'
-          mv source/test_report.html new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/index.html
-          cp -r new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/* new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/latest
+          mv source/test_report.html new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/latest/index.html
 
         env:
           PROJECT_NAME: ${{ env.PROJECT_NAME }}

.gitignore

@@ -6,3 +6,5 @@
 .Rproj.user
 .DS_Store
 .Rapp.history
+.claude
+.idea

DESCRIPTION

@@ -59,12 +59,15 @@ Authors@R: c(person(given = "Paul",
                     comment = c(ORCID = "0009-0003-2419-1964")))
 License: GPL-3
 Depends: 
-    R (>= 4.0.0)
+    R (>= 4.1.0)
 Imports:
     RANN,
     stringr,
     lme4,
     dplyr,
+    tibble,
+    purrr,
+    tidyselect,
     reshape2,
     polycor (>= 0.8),
     splines,

NAMESPACE

@@ -42,7 +42,12 @@ export(elsplineDS)
 export(expDS)
 export(extractQuantilesDS1)
 export(extractQuantilesDS2)
+export(fixClassDS)
+export(fixColsDS)
+export(fixLevelsDS)
 export(gamlssDS)
+export(getAllLevelsDS)
+export(getClassAllColsDS)
 export(getWGSRDS)
 export(glmDS1)
 export(glmDS2)
@@ -84,6 +89,7 @@ export(matrixDimnamesDS)
 export(matrixInvertDS)
 export(matrixMultDS)
 export(matrixTransposeDS)
+export(mdPatternDS)
 export(meanDS)
 export(meanSdGpDS)
 export(mergeDS)
@@ -140,7 +146,17 @@ 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(tibble,as_tibble)
+importFrom(tidyselect,all_of)
+importFrom(tidyselect,peek_vars)

R/BooleDS.R

@@ -21,6 +21,7 @@
 #' input vector are all converted to 1 or 0 respectively.
 #' 
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' 
 #' @return the levels of the input variable.
 #' @export
@@ -50,8 +51,15 @@ thr <- dsBase::listDisclosureSettingsDS()                               #
 
 ##########CHECK NOT LONG SPECIFIED VECTOR##############
 
-V1<-eval(parse(text=V1.name), envir = parent.frame())
-V2<-eval(parse(text=V2.name), envir = parent.frame())
+V1<-.loadServersideObject(V1.name)
+
+# V2 may be either a server-side object name or a literal scalar (e.g. "3", "-1")
+V2.numeric <- suppressWarnings(as.numeric(V2.name))
+if(!is.na(V2.numeric)){
+  V2 <- V2.numeric
+}else{
+  V2 <- .loadServersideObject(V2.name)
+}
 
 
 if(is.character(V1)){

R/cDS.R

@@ -3,28 +3,30 @@
 #' @description This function is similar to the R base function 'c'.
 #' @details Unlike the R base function 'c' on vector or list of certain 
 #' length are allowed as output
-#' @param objs a list which contains the the objects to concatenate.
+#' @param x.names a character vector of object names to concatenate.
 #' @return a vector or list
 #' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
-#' 
-cDS <- function (objs) {
-  
+#'
+cDS <- function (x.names) {
+
   # Check Permissive Privacy Control Level.
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'avocado'))
-  
-  # this filter sets the minimum number of observations that are allowed 
+
+  # this filter sets the minimum number of observations that are allowed
 
   #############################################################
   # MODULE 1: CAPTURE THE nfilter SETTINGS
   thr <- dsBase::listDisclosureSettingsDS()
   nfilter.tab <- as.numeric(thr$nfilter.tab)
-  #nfilter.glm <- as.numeric(thr$nfilter.glm)
-  #nfilter.subset <- as.numeric(thr$nfilter.subset)
-  #nfilter.string <- as.numeric(thr$nfilter.string)
   #############################################################
-
-  x <-  unlist(objs)
+
+  objs <- list()
+  for (i in seq_along(x.names)) {
+    objs[[i]] <- .loadServersideObject(x.names[i])
+  }
+  x <- unlist(objs)
 
   # check if the output is valid and output accordingly
   if(length(x) < nfilter.tab){

R/cbindDS.R

@@ -19,6 +19,7 @@
 #' of \code{ds.cbind} (or default name \code{cbind.newobj})
 #' which is written to the serverside. The output object is of class data.frame.
 #' @author Paul Burton and Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){
@@ -28,11 +29,13 @@ cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){
 
   x.names.input <- x.names.transmit
   x.names.act1 <- unlist(strsplit(x.names.input, split=","))
-  x.names.act2 <- paste(x.names.act1, collapse=",")
-
-  eval.code.x.names <- paste0("data.frame(", x.names.act2, ")")
-
-  output.cbind <- eval(parse(text=eval.code.x.names), envir = parent.frame())
+
+  loaded.objects <- vector("list", length(x.names.act1))
+  for(i in seq_along(x.names.act1)) {
+    loaded.objects[[i]] <- .loadServersideObject(x.names.act1[i])
+  }
+
+  output.cbind <- do.call(data.frame, loaded.objects)
 
   colnames.input <- colnames.transmit
   colnames.act1 <- unlist(strsplit(colnames.input, split=","))

R/corDS.R

@@ -14,8 +14,10 @@
 #' sum of squares of each variable. The first disclosure control checks that the number of variables is
 #' not bigger than a percentage of the individual-level records (the allowed percentage is pre-specified
 #' by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a
-#' level having fewer counts than the pre-specified 'nfilter.tab' threshold.
+#' level having fewer counts than the pre-specified 'nfilter.tab' threshold. The list also includes
+#' \code{class}, the class of the input object for client-side consistency checking.
 #' @author Paul Burton, and Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 corDS <- function(x=NULL, y=NULL){
@@ -27,14 +29,21 @@ corDS <- function(x=NULL, y=NULL){
   nfilter.glm <- as.numeric(thr$nfilter.glm)
   #############################################################
 
-  x.val <- eval(parse(text=x), envir = parent.frame())
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+
   if (!is.null(y)){
-    y.val <- eval(parse(text=y), envir = parent.frame())
+    y.val <- .loadServersideObject(y)
+    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
   }
   else{
     y.val <- NULL
   }
-
+
+  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) {
+    stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE)
+  }
+
   # create a data frame for the variables
   if (is.null(y.val)){
     dataframe <- as.data.frame(x.val)
@@ -165,7 +174,7 @@ corDS <- function(x=NULL, y=NULL){
 
   }
 
-  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, sums.of.squares=sums.of.squares))
+  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, sums.of.squares=sums.of.squares, class=class(x.val)))
 
 }
 # AGGREGATE FUNCTION

R/corTestDS.R

@@ -11,24 +11,28 @@
 #' @param conf.level confidence level for the returned confidence interval. Currently
 #' only used for the Pearson product moment correlation coefficient if there are at least
 #' 4 complete pairs of observations.
-#' @return the results of the correlation test.
+#' @return a list with the results of the correlation test and \code{class}, the class of the
+#' input object for client-side consistency checking.
 #' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 corTestDS <- function(x, y, method, exact, conf.level){
 
-  x.var <- eval(parse(text=x), envir = parent.frame())
-  y.var <- eval(parse(text=y), envir = parent.frame())
+  x.var <- .loadServersideObject(x)
+  .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer"))
+  y.var <- .loadServersideObject(y)
+  .checkClass(obj = y.var, obj_name = y, permitted_classes = c("numeric", "integer"))
 
   # get the number of pairwise complete cases
   n <- sum(stats::complete.cases(x.var, y.var))
 
   # runs a two-sided correlation test
   corTest <- stats::cor.test(x=x.var, y=y.var, method=method, exact=exact, conf.level=conf.level)
 
-  out <- list(n, corTest)
-  names(out) <- c("Number of pairwise complete cases", "Correlation test")
-  
+  out <- list(n, corTest, class = class(x.var))
+  names(out)[1:2] <- c("Number of pairwise complete cases", "Correlation test")
+
   # return the results
   return(out)
 

R/covDS.R

@@ -21,8 +21,10 @@
 #' of variables is not bigger than a percentage of the individual-level records (the allowed percentage is pre-specified
 #' by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous with a level having fewer
 #' counts than the pre-specified 'nfilter.tab' threshold. If any of the input variables do not pass the disclosure
-#' controls then all the output values are replaced with NAs.
+#' controls then all the output values are replaced with NAs. The list also includes \code{class}, the class
+#' of the input object for client-side consistency checking.
 #' @author Amadou Gaye, Paul Burton, and Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 covDS <- function(x=NULL, y=NULL, use=NULL){
@@ -36,14 +38,21 @@ covDS <- function(x=NULL, y=NULL, use=NULL){
   #nfilter.string <- as.numeric(thr$nfilter.string)
   #############################################################
 
-  x.val <- eval(parse(text=x), envir = parent.frame())
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
+
   if (!is.null(y)){
-    y.val <- eval(parse(text=y), envir = parent.frame())
+    y.val <- .loadServersideObject(y)
+    .checkClass(obj = y.val, obj_name = y, permitted_classes = c("numeric", "integer", "matrix", "data.frame"))
   }
   else{
     y.val <- NULL
   }
-
+
+  if (is.null(y.val) && any(class(x.val) %in% c("numeric", "integer"))) {
+    stop("If x is a numeric vector, y must also be a numeric vector.", call. = FALSE)
+  }
+
   # create a data frame for the variables
   if (is.null(y.val)){
     dataframe <- as.data.frame(x.val)
@@ -298,7 +307,7 @@ covDS <- function(x=NULL, y=NULL, use=NULL){
 
   }
 
-  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, errorMessage=errorMessage))
+  return(list(sums.of.products=sums.of.products, sums=sums, complete.counts=complete.counts, na.counts=na.counts, errorMessage=errorMessage, class=class(x.val)))
 
 }
 # AGGREGATE FUNCTION

R/dataFrameDS.R

@@ -35,6 +35,7 @@
 #' serverside and named according to the <newobj> argument of the clientside
 #' function ds.dataFrame()
 #' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #'
 dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE, clnames=NULL, strAsFactors=TRUE, completeCases=FALSE){
@@ -58,8 +59,12 @@ dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE
     r.names <- unlist(r.names)
   }
 
-  eval.code.vectors.names <- paste0("data.frame(", vectors, ")")
-  dtemp0 <- eval(parse(text=eval.code.vectors.names), envir = parent.frame())
+  vectors.names <- unlist(strsplit(vectors, split=","))
+  loaded.vectors <- vector("list", length(vectors.names))
+  for(i in seq_along(vectors.names)) {
+    loaded.vectors[[i]] <- .loadServersideObject(vectors.names[i])
+  }
+  dtemp0 <- do.call(data.frame, loaded.vectors)
 
   dtemp <- data.frame(dtemp0, row.names=r.names, check.rows=ch.rows, check.names=ch.names,
                     stringsAsFactors=strAsFactors)

R/dataFrameFillDS.R

@@ -17,11 +17,12 @@
 #' The classes supported are 'numeric', 'integer', 'character', 'factor' and 'logical'.
 #' @return Nothing is returned to the client. The generated object is written to the serverside.
 #' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
 #' @export
 #' 
 dataFrameFillDS <- function(df.name, allNames.transmit, class.vect.transmit, levels.vec.transmit){
 
-  data <- eval(parse(text=df.name), envir = parent.frame())
+  data <- .loadServersideObject(df.name)
 
   if(!is.null(allNames.transmit)){
     allNames <- unlist(strsplit(allNames.transmit, split=","))

R/dataFrameSortDS.R

@@ -30,6 +30,7 @@
 #' 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
 #' @export
 #'
@@ -65,9 +66,8 @@ dataFrameSortDS <- function(df.name=NULL,sort.key.name=NULL,sort.descending,sort
     stop(studysideMessage, call. = FALSE)
   }
 
-  df.name.2 <- paste0("data.frame(",df.name,")")
-  df2sort   <- eval(parse(text=df.name.2), envir = parent.frame())
-  sort.key  <- eval(parse(text=sort.key.name), envir = parent.frame())
+  df2sort   <- data.frame(.loadServersideObject(df.name))
+  sort.key  <- .loadServersideObject(sort.key.name)
 
   # TYPE CHECK
   if(any(class(sort.key) %in% 'factor')){