Merge branch 'v6.4.0-dev' into v6.4.0-dev-feat/as-data-frame

Author: StuartWheater

.Rbuildignore

@@ -7,3 +7,5 @@
 ^data$
 ^docs$
 ^pkgdown$
+^\.circleci$
+^\.circleci/config\.yml$

.circleci/config.yml

@@ -0,0 +1,50 @@
+# Copyright (c) 2024 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
+
+version: 2.1
+
+jobs:
+  dsbase:
+    docker:
+      - image: cimg/base:current
+    resource_class: small
+    steps:
+      - checkout
+      - setup_remote_docker:
+          docker_layout_caching: true
+      - run: |
+          echo "Building"
+          echo "  Repo Name: " $CIRCLE_PROJECT_REPONAME
+          echo "  Branch:    " $CIRCLE_BRANCH
+          echo "  Tag:       " $CIRCLE_TAG
+      - run:
+          command: |
+              sudo apt-get update -y
+              sudo apt-get install -y r-base-core cmake
+      - run:
+          command: |
+              sudo apt-get install -y libxml2-dev
+      - run:
+          command: |
+              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)"
+      - run:
+          command: |
+              sudo Rscript -e 'library(covr); covr::codecov(token = "'$CODECOV_TOKEN'")'
+workflows:
+  build:
+    jobs:
+      - dsbase

DESCRIPTION

@@ -1,12 +1,12 @@
 Package: dsBase
-Title: DataSHIELD server site base functions
-Description: DataSHIELD server site base functions.
+Title: DataSHIELD Server Site Base Functions
+Description: DataSHIELD Server Site Base Functions.
 Version: 6.4.0.9000
 Author: DataSHIELD Developers <datashield@liverpool.ac.uk>
 Maintainer: DataSHIELD Developers <datashield@liverpool.ac.uk>
 License: GPL-3
 Depends: 
-    R (>= 3.5.0)
+    R (>= 4.0.0)
 Imports:
     RANN,
     stringr,
@@ -18,7 +18,10 @@ Imports:
     gamlss,
     gamlss.dist,
     mice,
-    childsds
+    childsds, 
+    purrr, 
+    tibble,
+    tidyverse
 Suggests:
     testthat
 AggregateMethods:
@@ -158,8 +161,6 @@ AssignMethods:
     sampleDS,
     seqDS,
     sqrtDS,
-    subsetByClassDS,
-    subsetDS,
     tableDS.assign,
     tapplyDS.assign,
     uniqueDS,

NAMESPACE

@@ -42,7 +42,12 @@ export(dmtC2SDS)
 export(elsplineDS)
 export(extractQuantilesDS1)
 export(extractQuantilesDS2)
+export(fixClassDS)
+export(fixColsDS)
+export(fixLevelsDS)
 export(gamlssDS)
+export(getAllLevelsDS)
+export(getClassAllColsDS)
 export(getWGSRDS)
 export(glmDS1)
 export(glmDS2)
@@ -120,8 +125,6 @@ export(setSeedDS)
 export(skewnessDS1)
 export(skewnessDS2)
 export(sqrtDS)
-export(subsetByClassDS)
-export(subsetDS)
 export(table1DDS)
 export(table2DDS)
 export(tableDS)
@@ -139,5 +142,14 @@ 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(purrr,map)
+importFrom(purrr,set_names)
+importFrom(tibble,as_tibble)
+importFrom(tidyselect,all_of)
+importFrom(tidyselect,peek_vars)

R/asCharacterDS.R

@@ -14,7 +14,7 @@
 #' 
 asCharacterDS <- function (x.name){
 
-  x<-eval(parse(text=x.name), envir = parent.frame())
+  x <- eval(parse(text=x.name), envir = parent.frame())
 
   output <- as.character(x)
   return(output)

R/asDataMatrixDS.R

@@ -14,12 +14,12 @@
 asDataFrameDS <- function (x.name){
 
 if(is.character(x.name)){
-	x<-eval(parse(text=x.name), envir = parent.frame())
+	x <- eval(parse(text=x.name), envir = parent.frame())
 
 	}else{
    studysideMessage<-"ERROR: x.name must be specified as a character string"
    stop(studysideMessage, call. = FALSE)
-   }
+  }
 
   output <- data.frame(x)
 

R/asFactorDS1.R

@@ -10,6 +10,7 @@
 #' @export
 #'
 asFactorDS1 <- function(input.var.name=NULL){
+  
   ##################################################################
   #MODULE 1: CAPTURE THE nfilter SETTINGS                          #
   thr<-dsBase::listDisclosureSettingsDS()                          #
@@ -26,27 +27,29 @@ asFactorDS1 <- function(input.var.name=NULL){
 
   input.var <- eval(parse(text=input.var.name), envir = parent.frame())
   factor.levels.present.in.source <- levels(factor(input.var))
-  num.levels<-length(factor.levels.present.in.source)
+  num.levels <- length(factor.levels.present.in.source)
 
   max.levels.by.density<-nfilter.levels.density*length(input.var)
 
-  if(num.levels>nfilter.levels.max)
-  {
-    error.message<-
-      paste0("FAILED: this variable has too many levels and may be disclosive. It exceeds the max number of levels allowed by nfilter.levels.max: that is ",nfilter.levels.max,". In this study this variable has ",num.levels," factor levels")
+  if(num.levels > nfilter.levels.max){
+    error.message <- paste0("FAILED: this variable has too many levels and may be disclosive. 
+                            It exceeds the max number of levels allowed by nfilter.levels.max: 
+                            that is ", nfilter.levels.max, ". In this study this variable has ", 
+                            num.levels," factor levels")
     stop(error.message, call. = FALSE)
   }
 
-  if(num.levels>(length(input.var)*nfilter.levels.density))
-  {
-    error.message<-
-      paste0("FAILED: this variable has too many levels and may be disclosive. The number of factor levels must not exceed ", (nfilter.levels.density*100), "% of the length of the variable being converted to a factor. The max number of levels in this study is therefore ",max.levels.by.density," but this variable has ",num.levels," factor levels")
+  if(num.levels > (length(input.var)*nfilter.levels.density)){
+    error.message <- paste0("FAILED: this variable has too many levels and may be disclosive. 
+                            The number of factor levels must not exceed ", (nfilter.levels.density*100), 
+                            "% of the length of the variable being converted to a factor. The max number 
+                            of levels in this study is therefore ",max.levels.by.density," but this 
+                            variable has ", num.levels, " factor levels")
     stop(error.message, call. = FALSE)
   }
 
   return(factor.levels.present.in.source)
 
 }
-#AGGREGATE FUNCTION
+# AGGREGATE FUNCTION
 # asFactorDS1
-

R/asListDS.R

@@ -1,3 +1,4 @@
+#' 
 #' @title asListDS a serverside aggregate function called by ds.asList
 #' @description Coerces an R object into a list
 #' @details Unlike most other class coercing functions this is
@@ -21,25 +22,26 @@
 #' the class of the output object should usually be 'list'
 #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team
 #' @export
+#' 
 asListDS <- function (x.name, newobj){
 
     newobj.class <- NULL
     if(is.character(x.name)){
-        active.text<-paste0(newobj,"<-as.list(",x.name,")")
+        active.text <- paste0(newobj,"<-as.list(",x.name,")")
         eval(parse(text=active.text), envir = parent.frame())
 
-        active.text2<-paste0("class(",newobj,")")
+        active.text2 <- paste0("class(",newobj,")")
         assign("newobj.class", eval(parse(text=active.text2), envir = parent.frame()))
 
     }else{
-        studysideMessage<-"ERROR: x.name must be specified as a character string"
+        studysideMessage <- "ERROR: x.name must be specified as a character string"
         stop(studysideMessage, call. = FALSE)
     }
 
-    return.message<-paste0("New object <",newobj,"> created")
-    object.class.text<-paste0("Class of <",newobj,"> is '",newobj.class,"'")
+    return.message <- paste0("New object <", newobj, "> created")
+    object.class.text <- paste0("Class of <", newobj, "> is '", newobj.class, "'")
 
-    return(list(return.message=return.message,class.of.newobj=object.class.text))
+    return(list(return.message=return.message, class.of.newobj=object.class.text))
 }
 # AGGEGATE FUNCTION
 # asListDS

R/asLogicalDS.R

@@ -1,3 +1,4 @@
+#' 
 #' @title Coerces an R object into class numeric
 #' @description this function is based on the native R function \code{as.numeric}
 #' @details See help for function \code{as.logical} in native R
@@ -10,24 +11,25 @@
 #' details see help on the clientside function \code{ds.asLogical}
 #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team
 #' @export
+#' 
 asLogicalDS <- function (x.name){
 
-if(is.character(x.name)){
-	x<-eval(parse(text=x.name), envir = parent.frame())
+  if(is.character(x.name)){
+	  x <- eval(parse(text=x.name), envir = parent.frame())
 
 	}else{
-   studysideMessage<-"ERROR: x.name must be specified as a character string"
+   studysideMessage <- "ERROR: x.name must be specified as a character string"
    stop(studysideMessage, call. = FALSE)
-   }
+  }
 
-  if(!is.numeric(x)&&!is.integer(x)&&!is.character(x)&&!is.matrix(x)){
-  studysideMessage<-"ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix"
-  stop(studysideMessage, call. = FALSE)
+  if(!is.numeric(x) && !is.integer(x) && !is.character(x) && !is.matrix(x)){
+    studysideMessage <- "ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix"
+    stop(studysideMessage, call. = FALSE)
   }
 
   output <- as.logical(x)
 
   return(output)
 }
-#ASSIGN FUNCTION
+# ASSIGN FUNCTION
 # asLogicalDS

R/aucDS.R

@@ -31,6 +31,6 @@ aucDS <- function(pred=pred, y=y){
   q2 <- 2*AUC^2/(1+AUC)-AUC^2
   se <- sqrt((q0+(n0-1)*q1+(n1-1)*q2)/(n0*n1))
 
-  return(list(AUC=AUC,se=se))
+  return(list(AUC=AUC, se=se))
 
 }