Merge pull request #78 from datashield/v6.0-dev

Merge v6.0 development into master for release

.gitignore

@@ -4,3 +4,4 @@
 *.dll
 *.Rproj
 .Rproj.user
+.DS_Store

DESCRIPTION

@@ -1,34 +1,43 @@
 Package: dsBase
 Title: DataSHIELD server site base functions
-Version: 5.1.0
+Version: 6.0.0
 Author: DataSHIELD Developers <datashield@newcastle.ac.uk>
 Maintainer: DataSHIELD Developers <datashield@newcastle.ac.uk>
 License: GPL-3
 Description: DataSHIELD server site base functions.
 Imports:
     RANN,
-    nlme
+    nlme,
+    stringr,
+    lme4
 AggregateMethods:
     alphaPhiDS,
     asFactorDS1,
     asListDS,
     checkNegValueDS,
+    classDS,
+    corTestDS,
+    corDS,
     covDS,
     dataFrameSubsetDS1,
     densityGridDS,
     dimDS,
     glmDS1,
     glmDS2,
+    glmerSLMADS2,
     glmSLMADS1,
     glmSLMADS2,
     heatmapPlotDS,
     histogramDS1,
     histogramDS2,
+    lsDS,
     isNaDS,
     isValidDS,
     lengthDS,
+    levelsDS,
     lexisDS1,
     listDisclosureSettingsDS,
+    lmerSLMADS2,
     matrixDetDS1,
     meanDS,
     meanSdGpDS,
@@ -44,23 +53,19 @@ AggregateMethods:
     setSeedDS,
     table1DDS,
     table2DDS,
+    tableDS,
+    tableDS2,
     tapplyDS,
     testObjExistsDS,
     tTestFDS2,
     varDS,
-    class=base::class,
-    colnames=base::colnames,
-    cor.test=stats::cor.test,
-    dim=base::dim,
+    colnamesDS,
     exists=base::exists,
     is.character=base::is.character,
     is.factor=base::is.factor,
     is.list=base::is.list,
     is.null=base::is.null,
     is.numeric=base::is.numeric,
-    length=base::length,
-    levels=base::levels,
-    ls=base::ls,
     NROW=base::NROW,
     t.test=stats::t.test
 AssignMethods:
@@ -77,6 +82,7 @@ AssignMethods:
     cbindDS,
     cDS,
     changeRefGroupDS,
+    completeCasesDS,
     dataFrameDS,
     dataFrameFillDS,
     dataFrameSortDS,
@@ -96,16 +102,19 @@ AssignMethods:
     rBinomDS,
     recodeLevelsDS,
     recodeValuesDS2,
+    repDS,
     replaceNaDS,
     reShapeDS,
     rNormDS,
     rowColCalcDS,
     rPoisDS,
     rUnifDS,
+    sampleDS,
     seedDS,
     seqDS,
     subsetByClassDS,
     subsetDS,
+    tableDS.assign,
     tapplyDS.assign,
     unListDS,
     as.character=base::as.character,
@@ -131,4 +140,4 @@ Options:
     default.nfilter.tab=3,
     default.nfilter.noise=0.25,
     default.nfilter.levels=0.33
-RoxygenNote: 7.0.2
+RoxygenNote: 7.1.0

NAMESPACE

@@ -14,7 +14,11 @@ export(cDS)
 export(cbindDS)
 export(changeRefGroupDS)
 export(checkNegValueDS)
+export(classDS)
+export(colnamesDS)
+export(completeCasesDS)
 export(corDS)
+export(corTestDS)
 export(covDS)
 export(dataFrameDS)
 export(dataFrameFillDS)
@@ -27,17 +31,21 @@ export(glmDS1)
 export(glmDS2)
 export(glmSLMADS1)
 export(glmSLMADS2)
+export(glmerSLMADS2)
 export(heatmapPlotDS)
 export(histogramDS1)
 export(histogramDS2)
 export(isNaDS)
 export(isValidDS)
 export(lengthDS)
+export(levelsDS)
 export(lexisDS1)
 export(lexisDS2)
 export(lexisDS3)
 export(listDS)
 export(listDisclosureSettingsDS)
+export(lmerSLMADS2)
+export(lsDS)
 export(matrixDS)
 export(matrixDetDS1)
 export(matrixDetDS2)
@@ -63,16 +71,21 @@ export(reShapeDS)
 export(recodeLevelsDS)
 export(recodeValuesDS1)
 export(recodeValuesDS2)
+export(repDS)
 export(replaceNaDS)
 export(rmDS)
 export(rowColCalcDS)
+export(sampleDS)
 export(scatterPlotDS)
 export(seqDS)
 export(setSeedDS)
 export(subsetByClassDS)
 export(subsetDS)
 export(table1DDS)
 export(table2DDS)
+export(tableDS)
+export(tableDS.assign)
+export(tableDS2)
 export(tapplyDS)
 export(tapplyDS.assign)
 export(testObjExistsDS)

R/BooleDS.R

@@ -45,8 +45,8 @@ thr <- listDisclosureSettingsDS()                                       #
 
 ##########CHECK NOT LONG SPECIFIED VECTOR##############
 
-V1<-eval(parse(text=V1.name))
-V2<-eval(parse(text=V2.name))
+V1<-eval(parse(text=V1.name), envir = parent.frame())
+V2<-eval(parse(text=V2.name), envir = parent.frame())
 
 
 if(is.character(V1)){
@@ -89,14 +89,14 @@ Boolean.indicator<-integer(length=V1.length)
 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))*1
+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))*1
+Boolean.indicator[j]<-eval(parse(text=command.text), envir = parent.frame())*1
 }
 }
 

R/asCharacterDS.R

@@ -13,7 +13,7 @@
 asCharacterDS <- function (x.name){
 
 if(is.character(x.name)){
-	x<-eval(parse(text=x.name))
+	x<-eval(parse(text=x.name), envir = parent.frame())
 
 	}else{
    studysideMessage<-"ERROR: x.name must be specified as a character string"

R/asDataMatrixDS.R

@@ -19,7 +19,7 @@
 asDataMatrixDS <- function (x.name){
 
 if(is.character(x.name)){
-	x<-eval(parse(text=x.name))
+	x<-eval(parse(text=x.name), envir = parent.frame())
 
 	}else{
    studysideMessage<-"ERROR: x.name must be specified as a character string"

R/asFactorDS1.R

@@ -11,8 +11,31 @@
 #'
 asFactorDS1 <- function(input.var.name=NULL){
 
-  input.var <- eval(parse(text=input.var.name))
+  #############################################################
+  #MODULE 1: CAPTURE THE nfilter SETTINGS                     #
+  thr <- 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)                 #
+  #nfilter.noise <- as.numeric(thr$nfilter.noise)             #
+  nfilter.levels <- as.numeric(thr$nfilter.levels)            #
+  #############################################################
+
+  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)
+  max.allowed.levels<-length(input.var)*nfilter.levels
+
+  if(num.levels>max.allowed.levels)
+  {
+	error.message<-
+	paste0("FAILED: this variable has too many levels and may be disclosive. The ds.asFactor function allows no more than ",
+			max.allowed.levels," levels in this particular study. This variable has ",num.levels)
+	return(list(error.message=error.message))
+  }
 
   return(factor.levels.present.in.source)
 

R/asFactorDS2.R

@@ -19,7 +19,7 @@
 #'
 asFactorDS2 <- function(input.var.name=NULL, all.unique.levels.transmit=NULL, fixed.dummy.vars=NULL, baseline.level=NULL){
 
-  input.var <- eval(parse(text=input.var.name))
+  input.var <- eval(parse(text=input.var.name), envir = parent.frame())
 
   code.input <- all.unique.levels.transmit
   code.c <- unlist(strsplit(code.input, split=","))

R/asIntegerDS.R

@@ -16,7 +16,7 @@
 asIntegerDS <- function(x.name){
 
   if(is.character(x.name)){
-    x <- eval(parse(text=x.name))
+    x <- eval(parse(text=x.name), envir = parent.frame())
   }else{
     studysideMessage <- "ERROR: x.name must be specified as a character string"
     return(list(studysideMessage=studysideMessage))

R/asListDS.R

@@ -2,7 +2,7 @@
 #' @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 {datashield.assign} function in opal deals specially with
+#' is because the {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 {as.list}
@@ -25,11 +25,11 @@ asListDS <- function (x.name,newobj){
 
     newobj.class <- NULL
     if(is.character(x.name)){
-        active.text<-paste0(newobj,"<<-as.list(",x.name,")")
-        eval(parse(text=active.text))
+        active.text<-paste0(newobj,"<-as.list(",x.name,")")
+        eval(parse(text=active.text), envir = parent.frame())
 
-        active.text2<-paste0("newobj.class<-class(",newobj,")")
-        eval(parse(text=active.text2))
+        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"

R/asLogicalDS.R

@@ -13,7 +13,7 @@
 asLogicalDS <- function (x.name){
 
 if(is.character(x.name)){
-	x<-eval(parse(text=x.name))
+	x<-eval(parse(text=x.name), envir = parent.frame())
 
 	}else{
    studysideMessage<-"ERROR: x.name must be specified as a character string"

R/asMatrixDS.R

@@ -13,7 +13,7 @@
 asMatrixDS <- function (x.name){
 
 if(is.character(x.name)){
-	x<-eval(parse(text=x.name))
+	x<-eval(parse(text=x.name), envir = parent.frame())
 
 	}else{
    studysideMessage<-"ERROR: x.name must be specified as a character string"

R/asNumericDS.R

@@ -16,7 +16,7 @@
 asNumericDS <- function(x.name){
 
   if(is.character(x.name)){
-    x <- eval(parse(text=x.name))
+    x <- eval(parse(text=x.name), envir = parent.frame())
   }else{
     studysideMessage <- "ERROR: x.name must be specified as a character string"
     return(list(studysideMessage=studysideMessage))