V6.4.0 dev zeyzul

DESCRIPTION

@@ -5,7 +5,7 @@ Description: Base 'DataSHIELD' functions for the server side. 'DataSHIELD' is a
     been designed to only share non disclosive summary statistics, with built in automated output
     checking based on statistical disclosure control. With data sites setting the threshold values for
     the automated output checks. For more details, see 'citation("dsBase")'.
-Version: 6.3.5.9000
+Version: 6.4.0.9000
 Authors@R: c(person(given = "Paul",
                     family = "Burton",
                     role = c("aut"),
@@ -71,10 +71,16 @@ Imports:
     gamlss,
     gamlss.dist,
     mice,
-    childsds
+    childsds, 
+    purrr, 
+    tibble,
+    tidyselect,
+    stats,
+    lubridate
 Suggests:
     spelling,
-    testthat
-RoxygenNote: 7.3.3
+    testthat,
+    tidytable
+RoxygenNote: 8.0.0
 Encoding: UTF-8
 Language: en-GB

NAMESPACE

@@ -3,6 +3,7 @@
 export(BooleDS)
 export(absDS)
 export(asCharacterDS)
+export(asDataFrameDS)
 export(asDataMatrixDS)
 export(asFactorDS1)
 export(asFactorDS2)
@@ -35,13 +36,19 @@ export(dataFrameFillDS)
 export(dataFrameSortDS)
 export(dataFrameSubsetDS1)
 export(dataFrameSubsetDS2)
+export(dateDS)
 export(densityGridDS)
 export(dimDS)
 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)
@@ -93,6 +100,7 @@ export(minMaxRandDS)
 export(namesDS)
 export(nsDS)
 export(numNaDS)
+export(predictDS)
 export(qlsplineDS)
 export(quantileMeanDS)
 export(rBinomDS)
@@ -112,8 +120,10 @@ export(recodeValuesDS)
 export(repDS)
 export(replaceNaDS)
 export(rmDS)
+export(roundDS)
 export(rowColCalcDS)
 export(sampleDS)
+export(scaleDS)
 export(scatterPlotDS)
 export(seqDS)
 export(setSeedDS)
@@ -139,5 +149,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/BooleDS.R

@@ -30,127 +30,77 @@ BooleDS <- function(V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL, na.assi
   # Check Permissive Privacy Control Level.
   dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot'))
 
-#########################################################################
-# DataSHIELD MODULE: 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)                         #
-#nfilter.stringShort<-as.numeric(thr$nfilter.stringShort)               #
-#nfilter.kNN<-as.numeric(thr$nfilter.kNN)                               #
-#datashield.privacyLevel<-as.numeric(thr$datashield.privacyLevel)       #
-#########################################################################
-
-
-#V1: numeric, factor or logical vector or scalar in .GlobalEnv
-#V2: numeric, factor or logical vector or scalar in .GlobalEnv or client specified scalar with which to compare V1
-
-#EVAL V1 and V2
-
-##########CHECK NOT LONG SPECIFIED VECTOR##############
-
-V1<-eval(parse(text=V1.name), envir = parent.frame())
-V2<-eval(parse(text=V2.name), envir = parent.frame())
-
-
-if(is.character(V1)){
-   studysideMessage<-"FAILED: V_i is character, please convert to numeric, factor or logical before running Boole"
-   stop(studysideMessage, call. = FALSE)
-   }
-
-if(is.character(V2)){
-   studysideMessage<-"FAILED: V_ii is character, please convert to numeric, factor or logical before running Boole"
-   stop(studysideMessage, call. = FALSE)
-   }
-
-V1.length<-length(V1)   
-V2.length<-length(V2)
-
-if(!((V1.length == V2.length) | (V2.length==1))){
-   studysideMessage<-"FAILED: V_ii must either be of length one or of length equal to V_i"
-   stop(studysideMessage, call. = FALSE)
-}
-
-if(!is.numeric(Boolean.operator.n) | Boolean.operator.n==0){
-   studysideMessage<-"FAILED: Boolean.operator specified incorrectly. Must be: '==', '!=', '<', '<=', '>' or '>='"
-   stop(studysideMessage, call. = FALSE)
-}
-
-Boolean.operator<-"  "
-if(Boolean.operator.n==1) Boolean.operator<-"=="
-if(Boolean.operator.n==2) Boolean.operator<-"!="
-if(Boolean.operator.n==3) Boolean.operator<-"<"
-if(Boolean.operator.n==4) Boolean.operator<-"<="
-if(Boolean.operator.n==5) Boolean.operator<-">"
-if(Boolean.operator.n==6) Boolean.operator<-">="
-
-
-#APPLY BOOLEAN OPERATOR SPECIFIED
-
-Boolean.indicator<-integer(length=V1.length)
-
-#EVALUATE DIFFERENTLY IF V2 IS SAME LENGTH AS V1 OR OF LENGTH 1
-if(V2.length==V1.length){
-for(j in 1:V1.length){
-command.text<-paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name,"[",j,"]")
-Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
-}
-}
-
-if(V2.length==1){
-for(j in 1:V1.length){
-command.text<-paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name)
-Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
-}
-}
-
-
-#BY DEFAULT NAs REMAIN AS NAs BUT IF YOU WANT TO YOU CAN FORCE THEM TO 1 OR 0 USING <na.assign.text> ARGUMENT
-
-if(na.assign.text=="1"){
-Boolean.indicator[is.na(Boolean.indicator)==1]<-1
-}
-
-if(na.assign.text=="0"){
-Boolean.indicator[is.na(Boolean.indicator)==1]<-0
-}
-
-
-outobj.b<-as.logical(Boolean.indicator)
-outobj<-Boolean.indicator
-
-
-
-#COMMENT OUT THIS CODE BLOCK BECAUSE TESTS OF MINIMUM CELL SIZE SHOULD ALL BE
-#ENACTED IN AGGREGATE FUNCTIONS. NO VECTOR IS DISCLOSIVE UNTIL IT RETURNS
-#SOMETHING TO THE CLIENTSIDE. I AM LEAVING THIS COMMENTED BUT UNDELETED
-#IN CASE WE LATER DECIDE TO CHANGE THIS STRATEGY
-#CHECK OUTPUT VECTOR VALIDITY
-#	outobj.invalid<-0
-#
-#	unique.values.outobj<-unique(outobj)
-#	unique.values.noNA.outobj<-unique.values.outobj[complete.cases(unique.values.outobj)]
-#
-#	#Boolean and can therefore only be binary so check this:
-#	if(length(unique.values.noNA.outobj)>2) outobj.invalid<-1
-#
-#	tabvar<-table(outobj,useNA="no")[table(outobj,useNA="no")>=1]
-#	min.category<-min(tabvar)
-#	if(min.category<nfilter.tab)outobj.invalid<-1
-#
-#TERMINATE CALCULATION IF outobj.invalid==1
-#if(outobj.invalid==1){
-#   studysideMessage<-"FAILED: outobj has at least one category below table filter limit"
-#   stop(studysideMessage, call. = FALSE)
-#}
-
-
-
-if(numeric.output==TRUE){
-   Boole.obj<-outobj
-   }else{Boole.obj<-outobj.b}
-return(Boole.obj)
+  V1 <- eval(parse(text=V1.name), envir = parent.frame())
+  V2 <- eval(parse(text=V2.name), envir = parent.frame())
+
+  if(is.character(V1)){
+    studysideMessage <- "FAILED: V1 is character, please convert to numeric, factor or logical before running Boole"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  if(is.character(V2)){
+    studysideMessage <- "FAILED: V2 is character, please convert to numeric, factor or logical before running Boole"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  V1.length <- length(V1)   
+  V2.length <- length(V2)
+
+  if(!((V1.length == V2.length) | (V2.length==1))){
+    studysideMessage <- "FAILED: V2 must either be of length one or of length equal to V1"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  if(!(Boolean.operator.n %in% c(1,2,3,4,5,6))){
+    studysideMessage <- "FAILED: Boolean.operator specified incorrectly. Must be: '==', '!=', '<', '<=', '>' or '>='"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  Boolean.operator <- " "
+  if(Boolean.operator.n==1) Boolean.operator <- "=="
+  if(Boolean.operator.n==2) Boolean.operator <- "!="
+  if(Boolean.operator.n==3) Boolean.operator <- "<"
+  if(Boolean.operator.n==4) Boolean.operator <- "<="
+  if(Boolean.operator.n==5) Boolean.operator <- ">"
+  if(Boolean.operator.n==6) Boolean.operator <- ">="
+
+  # APPLY BOOLEAN OPERATOR SPECIFIED
+  Boolean.indicator <- integer(length=V1.length)
+
+  # EVALUATE DIFFERENTLY IF V2 IS SAME LENGTH AS V1 OR OF LENGTH 1
+  if(V2.length==V1.length){
+    for(j in 1:V1.length){
+      command.text <- paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name,"[",j,"]")
+      Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
+    }
+  }
+
+  if(V2.length==1){
+    for(j in 1:V1.length){
+      command.text<-paste0(V1.name,"[",j,"] ",Boolean.operator," ",V2.name)
+      Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
+    }
+  }
+
+  # BY DEFAULT NAs REMAIN AS NAs BUT IF YOU WANT TO YOU CAN FORCE THEM TO 1 OR 0 USING <na.assign.text> ARGUMENT
+  if(na.assign.text=="1"){
+    Boolean.indicator[is.na(Boolean.indicator)==1]<-1
+  }
+
+  if(na.assign.text=="0"){
+    Boolean.indicator[is.na(Boolean.indicator)==1]<-0
+  }
+
+  outobj.b <- as.logical(Boolean.indicator)
+  outobj <- Boolean.indicator
+
+  if(numeric.output==TRUE){
+    Boole.obj <- outobj
+  }else{
+    Boole.obj <- outobj.b
+  }
+
+  return(Boole.obj)
 }
-#ASSIGN FUNCTION
+# ASSIGN FUNCTION
 # BooleDS

R/asDataFrameDS.R

@@ -0,0 +1,29 @@
+#' @title asDataFrameDS a serverside assign function called by ds.asDataFrame
+#' @description Coerces an R object into a matrix maintaining original
+#' class for all columns in data.frames.
+#' @details This assign function is based on the native R function \code{data.frame}
+#' @param x.name the name of the input object to be coerced to class
+#' data.frame. Must be specified in inverted commas. But this argument is
+#' usually specified directly by <x.name> argument of the clientside function
+#' \code{ds.asDataFrame}
+#' @return the object specified by the <newobj> argument (or its default name
+#' "asdataframe.newobj") which is written to the serverside. For further
+#' details see help on the clientside function \code{ds.asDataMatrix}
+#' @author Tim Cadman
+#' @export
+asDataFrameDS <- function (x.name){
+
+  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"
+    stop(studysideMessage, call. = FALSE)
+  }
+
+  output <- data.frame(x)
+
+  return(output)
+}
+# ASSIGN FUNCTION
+# asDataFrameDS

R/asDataMatrixDS.R

@@ -1,4 +1,4 @@
-#' @title asDataMatrixDS a serverside assign function called by ds.asDataMatrix
+#' @title asDataFrameDS a serverside assign function called by ds.asDataFrame
 #' @description Coerces an R object into a matrix maintaining original
 #' class for all columns in data.frames.
 #' @details This assign function is based on the native R function \code{data.matrix}
@@ -8,13 +8,13 @@
 #' the data.frame to a matrix but maintains all data columns in their
 #' original class
 #' @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
+#' data.frame. Must be specified in inverted commas. But this argument is
 #' usually specified directly by <x.name> argument of the clientside function
-#' \code{ds.asDataMatrix}
+#' \code{ds.asDataFrame}
 #' @return the object specified by the <newobj> argument (or its default name
-#' "asdatamatrix.newobj") which is written to the serverside. For further
+#' "asdataframe.newobj") which is written to the serverside. For further
 #' details see help on the clientside function \code{ds.asDataMatrix}
-#' @author Paul Burton for DataSHIELD Development Team
+#' @author Tim Cadman
 #' @export
 asDataMatrixDS <- function(x.name) {
   if (is.character(x.name)) {
@@ -24,9 +24,9 @@ asDataMatrixDS <- function(x.name) {
     stop(studysideMessage, call. = FALSE)
   }
 
-  output <- data.matrix(x)
+  output <- data.frame(x)
 
   return(output)
 }
 # ASSIGN FUNCTION
-# asDataMatrixDS
+# asDataFrameDS