From acdd3fbda00de584ba017e09b4739659ab47a73f Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Fri, 1 Aug 2025 15:35:54 +0100 Subject: [PATCH 1/4] Added 'carrot' privacy level --- R/BooleDS.R | 2 +- R/cbindDS.R | 4 ++-- R/dataFrameDS.R | 2 +- R/dataFrameSortDS.R | 2 +- R/dataFrameSubsetDS1.R | 2 +- R/dataFrameSubsetDS2.R | 2 +- R/levelsDS.R | 2 +- R/reShapeDS.R | 2 +- R/recodeLevelsDS.R | 2 +- R/recodeValuesDS.R | 2 +- R/subsetByClassDS.R | 2 +- R/subsetDS.R | 2 +- R/vectorDS.R | 2 +- 13 files changed, 14 insertions(+), 14 deletions(-) diff --git a/R/BooleDS.R b/R/BooleDS.R index 1ad5e14f..0f54dfca 100644 --- a/R/BooleDS.R +++ b/R/BooleDS.R @@ -28,7 +28,7 @@ BooleDS <- function(V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL, na.assign.text, numeric.output=TRUE){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ######################################################################### # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # diff --git a/R/cbindDS.R b/R/cbindDS.R index 5d5464e7..fcde369b 100644 --- a/R/cbindDS.R +++ b/R/cbindDS.R @@ -1,5 +1,5 @@ #' @title cbindDS called by ds.cbind -#' @description serverside assign function that takes a +x#' @description serverside assign function that takes a #' sequence of vector, matrix or data-frame arguments #' and combines them by column to produce a data-frame. #' @details A sequence of vector, matrix or data-frame arguments @@ -24,7 +24,7 @@ cbindDS <- function(x.names.transmit=NULL, colnames.transmit=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) x.names.input <- x.names.transmit x.names.act1 <- unlist(strsplit(x.names.input, split=",")) diff --git a/R/dataFrameDS.R b/R/dataFrameDS.R index a3e06f4c..7a2b36be 100644 --- a/R/dataFrameDS.R +++ b/R/dataFrameDS.R @@ -40,7 +40,7 @@ dataFrameDS <- function(vectors=NULL, r.names=NULL, ch.rows=FALSE, ch.names=TRUE, clnames=NULL, strAsFactors=TRUE, completeCases=FALSE){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ######################################################################### # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS diff --git a/R/dataFrameSortDS.R b/R/dataFrameSortDS.R index 0ea3b3c1..a398a70b 100644 --- a/R/dataFrameSortDS.R +++ b/R/dataFrameSortDS.R @@ -36,7 +36,7 @@ dataFrameSortDS <- function(df.name=NULL,sort.key.name=NULL,sort.descending,sort.method){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ######################################################################### # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS diff --git a/R/dataFrameSubsetDS1.R b/R/dataFrameSubsetDS1.R index 232e405c..4b3c9476 100644 --- a/R/dataFrameSubsetDS1.R +++ b/R/dataFrameSubsetDS1.R @@ -50,7 +50,7 @@ dataFrameSubsetDS1 <- function(df.name=NULL,V1.name=NULL,V2.name=NULL,Boolean.operator.n=NULL,keep.cols=NULL,rm.cols=NULL,keep.NAs=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ######################################################################### # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS diff --git a/R/dataFrameSubsetDS2.R b/R/dataFrameSubsetDS2.R index 3a59602f..05938a60 100644 --- a/R/dataFrameSubsetDS2.R +++ b/R/dataFrameSubsetDS2.R @@ -59,7 +59,7 @@ dataFrameSubsetDS2<-function(df.name=NULL,V1.name=NULL, V2.name=NULL, Boolean.operator.n=NULL,keep.cols=NULL, rm.cols=NULL, keep.NAs=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ######################################################################### # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS # diff --git a/R/levelsDS.R b/R/levelsDS.R index 9bb54401..bdb374d5 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -10,7 +10,7 @@ levelsDS <- function(x){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ################################################################## #MODULE 1: CAPTURE THE nfilter SETTINGS # diff --git a/R/reShapeDS.R b/R/reShapeDS.R index 6dbf0654..2ec368a5 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -43,7 +43,7 @@ reShapeDS <- function(data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) datatext <- paste0("data.frame(",data.name,")") data <- eval(parse(text=datatext), envir = parent.frame()) diff --git a/R/recodeLevelsDS.R b/R/recodeLevelsDS.R index c773e774..6878faa6 100644 --- a/R/recodeLevelsDS.R +++ b/R/recodeLevelsDS.R @@ -11,7 +11,7 @@ recodeLevelsDS <- function (x=NULL, classes=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) # check if the input vector is valid (i.e. meets DataSHIELD criteria) check <- isValidDS(x) diff --git a/R/recodeValuesDS.R b/R/recodeValuesDS.R index f29dc0fa..d22a7862 100644 --- a/R/recodeValuesDS.R +++ b/R/recodeValuesDS.R @@ -31,7 +31,7 @@ recodeValuesDS <- function(var.name.text=NULL, values2replace.text=NULL, new.values.text=NULL, missing=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) ############################################################# #MODULE 1: CAPTURE THE used nfilter SETTINGS diff --git a/R/subsetByClassDS.R b/R/subsetByClassDS.R index f213bb4d..e4063482 100644 --- a/R/subsetByClassDS.R +++ b/R/subsetByClassDS.R @@ -18,7 +18,7 @@ subsetByClassDS <- function(data=NULL, variables=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) # this filter sets the minimum number of observations that are allowed diff --git a/R/subsetDS.R b/R/subsetDS.R index 7ba57ac2..2ab0a14c 100644 --- a/R/subsetDS.R +++ b/R/subsetDS.R @@ -30,7 +30,7 @@ subsetDS <- function(dt=NULL, complt=NULL, rs=NULL, cs=NULL, lg=NULL, th=NULL, varname=NULL){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) # this filter sets the minimum number of observations that are allowed diff --git a/R/vectorDS.R b/R/vectorDS.R index 8efacf97..e1bff36b 100644 --- a/R/vectorDS.R +++ b/R/vectorDS.R @@ -10,7 +10,7 @@ #' vectorDS <- function(...){ # Check Permissive Privacy Control Level. - dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana')) + dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) # compute the vector's value out <- c(...) From 4bc866b916016a6150a728a9eea4ebbda4c2d24b Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Wed, 6 Aug 2025 13:12:31 +0100 Subject: [PATCH 2/4] Fix typo in cbindDS.R Fixed typo --- R/cbindDS.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cbindDS.R b/R/cbindDS.R index fcde369b..b7864864 100644 --- a/R/cbindDS.R +++ b/R/cbindDS.R @@ -1,5 +1,5 @@ #' @title cbindDS called by ds.cbind -x#' @description serverside assign function that takes a +#' @description serverside assign function that takes a #' sequence of vector, matrix or data-frame arguments #' and combines them by column to produce a data-frame. #' @details A sequence of vector, matrix or data-frame arguments From 4706682489ba07ac12773370238880195230f230 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Wed, 6 Aug 2025 13:13:43 +0100 Subject: [PATCH 3/4] Update DATASHIELD --- inst/DATASHIELD | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/inst/DATASHIELD b/inst/DATASHIELD index cacfc42b..ab654bea 100644 --- a/inst/DATASHIELD +++ b/inst/DATASHIELD @@ -160,4 +160,6 @@ AssignMethods: acos=base::acos, atan=base::atan, sum=base::sum, - unlist=base::unlist \ No newline at end of file + unlist=base::unlist +Options: + testoption=100 From ee47a80b5fec8a47b558a17e08a08bfdbe04f5a7 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 12 Aug 2025 16:35:24 +0100 Subject: [PATCH 4/4] Rework restoring '.Random.seed' --- R/blackBoxDS.R | 7 +++++-- R/blackBoxRanksDS.R | 7 +++++-- R/heatmapPlotDS.R | 7 +++++-- R/histogramDS1.R | 7 +++++-- R/histogramDS2.R | 7 +++++-- R/minMaxRandDS.R | 7 +++++-- R/rangeDS.R | 7 +++++-- R/scatterPlotDS.R | 7 +++++-- 8 files changed, 40 insertions(+), 16 deletions(-) diff --git a/R/blackBoxDS.R b/R/blackBoxDS.R index 8e7e33f1..a2ac1efc 100644 --- a/R/blackBoxDS.R +++ b/R/blackBoxDS.R @@ -67,8 +67,11 @@ blackBoxDS <- function(input.var.name=NULL, ######################################################## # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) input.var <- eval(parse(text=input.var.name), envir = parent.frame()) diff --git a/R/blackBoxRanksDS.R b/R/blackBoxRanksDS.R index cb2fc21f..27a85778 100644 --- a/R/blackBoxRanksDS.R +++ b/R/blackBoxRanksDS.R @@ -62,8 +62,11 @@ blackBoxRanksDS <- function(input.var.name=NULL, shared.seedval){ #START FUNC ######################################################## # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) input.var <- eval(parse(text=input.var.name), envir = parent.frame()) input.global.ranks<-input.var diff --git a/R/heatmapPlotDS.R b/R/heatmapPlotDS.R index 6dccbd5b..68302392 100644 --- a/R/heatmapPlotDS.R +++ b/R/heatmapPlotDS.R @@ -39,8 +39,11 @@ heatmapPlotDS <- function(x, y, k, noise, method.indicator){ ################################################################### # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) # Cbind the columns of the two variables and remove any rows that include NAs data.table <- cbind.data.frame(x, y) diff --git a/R/histogramDS1.R b/R/histogramDS1.R index a79d2f52..c5f68d41 100644 --- a/R/histogramDS1.R +++ b/R/histogramDS1.R @@ -37,8 +37,11 @@ histogramDS1 <- function(xvect, method.indicator, k, noise){ ################################################################## # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) # print an error message if the input vector is not a numeric if(!(is.numeric(xvect))){ diff --git a/R/histogramDS2.R b/R/histogramDS2.R index 1f7a8acc..cffed190 100644 --- a/R/histogramDS2.R +++ b/R/histogramDS2.R @@ -39,8 +39,11 @@ histogramDS2 <- function (xvect, num.breaks, min, max, method.indicator, k, nois ################################################################## # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) if (method.indicator==1){ diff --git a/R/minMaxRandDS.R b/R/minMaxRandDS.R index 0346eb75..e6ccfc82 100644 --- a/R/minMaxRandDS.R +++ b/R/minMaxRandDS.R @@ -21,8 +21,11 @@ minMaxRandDS <- function(input.var.name){ #START FUNC # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) input.var <- eval(parse(text=input.var.name), envir = parent.frame()) diff --git a/R/rangeDS.R b/R/rangeDS.R index 6cf7689c..9c391b69 100644 --- a/R/rangeDS.R +++ b/R/rangeDS.R @@ -9,8 +9,11 @@ #' rangeDS <- function(xvect) { # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) # print an error message if the input vector is not a numeric if (!(is.numeric(xvect))) { diff --git a/R/scatterPlotDS.R b/R/scatterPlotDS.R index bf229041..62fbc6a6 100644 --- a/R/scatterPlotDS.R +++ b/R/scatterPlotDS.R @@ -44,8 +44,11 @@ scatterPlotDS <- function(x, y, method.indicator, k, noise){ ################################################################### # back-up current .Random.seed and revert on.exit - old_seed <- .Random.seed - on.exit(.Random.seed <- old_seed, add = TRUE) + if (exists(x = ".Random.seed", envir = globalenv())) { + assign(x = "old_seed", value = .Random.seed, envir = parent.frame()); + on.exit({ assign(x = ".Random.seed", value = old_seed, envir = globalenv()); remove("old_seed", envir = parent.frame()) }, add = TRUE) + } else + on.exit(if (exists(x = ".Random.seed", envir = globalenv())) remove(".Random.seed", envir = globalenv()), add = TRUE) # Cbind the columns of the two variables and remove any rows that include NAs data.table <- cbind.data.frame(x, y)