V7.0 dev colnamesDS

.Rbuildignore

@@ -11,3 +11,4 @@
 ^\.circleci/config\.yml$
 ^\.github$
 ^cran-comments\.md$
+^pull_request_template$

DESCRIPTION

@@ -71,10 +71,12 @@ Imports:
     gamlss,
     gamlss.dist,
     mice,
-    childsds
+    childsds, 
+    glue
 Suggests:
     spelling,
-    testthat
+    testthat (>= 3.0.0)
 RoxygenNote: 7.3.3
 Encoding: UTF-8
 Language: en-GB
+Config/testthat/edition: 3

NAMESPACE

@@ -140,3 +140,5 @@ import(gamlss.dist)
 import(mice)
 importFrom(gamlss.dist,pST3)
 importFrom(gamlss.dist,qST3)
+importFrom(glue,glue)
+importFrom(glue,glue_collapse)

R/colnamesDS.R

@@ -8,15 +8,10 @@
 #' @export
 #'
 colnamesDS <- function(x){
-
-  x.val <- eval(parse(text=x), envir = parent.frame())
-
-  # find the dim of the input dataframe or matrix
+  x.val <- .loadServersideObject(x)
+  .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix"))
   out <- colnames(x.val)
-
-  # return the dimension
   return(out)
-
 }
 #AGGREGATE FUNCTION
 # colnamesDS

R/utils.R

@@ -0,0 +1,42 @@
+#' Load a Server-Side Object by Name
+#'
+#' Evaluates a character string referring to an object name and returns the corresponding
+#' object from the parent environment. If the object does not exist, an error is raised.
+#'
+#' @param x A character string naming the object to be retrieved.
+#' @return The evaluated R object referred to by `x`.
+#' @noRd
+.loadServersideObject <- function(x) {
+  tryCatch(
+    eval(parse(text = x), envir = parent.frame(2)), 
+    error = function(e) {
+      stop("The server-side object", " '", x, "' ", "does not exist")
+    }
+  )
+}
+
+#' Check Class of a Server-Side Object
+#'
+#' Verifies that a given object is of an allowed class. If not, raises an informative error
+#' message listing the permitted classes and the actual class of the object.
+#'
+#' @param obj The object whose class should be checked.
+#' @param obj_name A character string with the name of the object (used in error messages).
+#' @param permitted_classes A character vector of allowed class names.
+#' @importFrom glue glue glue_collapse
+#' @return Invisibly returns `TRUE` if the class check passes; otherwise throws an error.
+#' @noRd
+.checkClass <- function(obj, obj_name, permitted_classes) {
+  typ <- class(obj)
+
+  if (!any(permitted_classes %in% typ)) {
+    msg <- glue(
+      "The server-side object must be of type {glue_collapse(permitted_classes, sep = ' or ')}. ",
+      "'{obj_name}' is type {typ}."
+    )
+
+    stop(msg, call. = FALSE)
+  }
+
+  invisible(TRUE)
+}

pull_request_template

@@ -0,0 +1,15 @@
+## Description
+[Write a description of the changes you have made]
+
+## Checklist (all items may not apply)
+
+### Refactor
+- [ ] Replace `eval(parse(text = x), envir = parent.frame())` with  `.loadServersideObject()`
+- [ ] Where appropriate, check object class using `.checkClass()
+- [ ] Check whether additional checks are required on the server-side 
+
+### Testing
+- [ ] Writen server-side unit tests for unhappy flow
+- [ ] Run and passed `devtools::test(filter = "smk-|disc|arg")`
+- [ ] Run and passed `devtools::check(args = '--no-tests')` (we run tests separately to skip performance checks)
+- [ ] Run and passed `devtools::build`

tests/testthat/perf_files/default_perf_profile.csv

@@ -1,5 +1,5 @@
 "refer_name","rate","lower_tolerance","upper_tolerance"
-"meanDS::perf::numeric::0","2998.9844","0.5","2"
-"meanDS::perf::numberAndNA::0","3027.3963","0.5","2"
-"varDS::perf::numeric::0","3124.4088","0.5","2"
-"varDS::perf::numberAndNA::0","3146.532","0.5","2"
+"meanDS::perf::numeric::0","11557.1204746495","0.5","2"
+"meanDS::perf::numberAndNA::0","11718.8520447749","0.5","2"
+"varDS::perf::numeric::0","12758.5511531009","0.5","2"
+"varDS::perf::numberAndNA::0","12545.8819532662","0.5","2"

tests/testthat/perf_files/hp-laptop_quay.csv

@@ -1,5 +1,5 @@
 "refer_name","rate","lower_tolerance","upper_tolerance"
-"meanDS::perf::numeric::0","8874.24924669612","0.5","2"
-"meanDS::perf::numberAndNA::0","8946.22935183172","0.5","2"
-"varDS::perf::numeric::0","10029.1022487173","0.5","2"
-"varDS::perf::numberAndNA::0","10014.7789085673","0.5","2"
+"meanDS::perf::numeric::0","11557.1204746495","0.5","2"
+"meanDS::perf::numberAndNA::0","11718.8520447749","0.5","2"
+"varDS::perf::numeric::0","12758.5511531009","0.5","2"
+"varDS::perf::numberAndNA::0","12545.8819532662","0.5","2"

tests/testthat/setup.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -11,7 +12,7 @@
 # Datashield test suite set up
 #
 
-context("setup - start")
+# context("setup - start")
 
 library(RANN)
 library(stringr)
@@ -22,4 +23,4 @@ source("random/set_random_seed_settings.R")
 
 source("perf_tests/perf_rate.R")
 
-context("setup - done")
+# context("setup - done")

tests/testthat/teardown.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2018-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -8,6 +9,6 @@
 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
 #-------------------------------------------------------------------------------
 
-context("teardown - start")
+# context("teardown - start")
 
-context("teardown - done")
+# context("teardown - done")

tests/testthat/test-arg-asIntegerDS.R

@@ -1,5 +1,5 @@
 #-------------------------------------------------------------------------------
-# Copyright (c) 2024 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2024-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -12,13 +12,13 @@
 # Set up
 #
 
-context("asIntegerDS::arg::setup")
+# context("asIntegerDS::arg::setup")
 
 #
 # Tests
 #
 
-context("asIntegerDS::arg::direct input numeric")
+# context("asIntegerDS::arg::direct input numeric")
 test_that("simple asIntegerDS non-input", {
     expect_error(asIntegerDS(1.0), "ERROR: x.name must be specified as a character string", fixed = TRUE)
 })
@@ -27,6 +27,6 @@ test_that("simple asIntegerDS non-input", {
 # Done
 #
 
-context("asIntegerDS::arg::shutdown")
+# context("asIntegerDS::arg::shutdown")
 
-context("asIntegerDS::arg::done")
+# context("asIntegerDS::arg::done")

tests/testthat/test-arg-asLogicalDS.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -12,25 +13,25 @@
 # Set up
 #
 
-context("asLogicalDS::arg::setup")
+# context("asLogicalDS::arg::setup")
 
 #
 # Tests
 #
 
-context("asLogicalDS::arg::direct input numeric")
+# context("asLogicalDS::arg::direct input numeric")
 test_that("simple asLogicalDS non-input", {
     expect_error(asLogicalDS(1.0), "ERROR: x.name must be specified as a character string", fixed = TRUE)
 })
 
-context("asLogicalDS::arg::input NULL")
+# context("asLogicalDS::arg::input NULL")
 test_that("simple asLogicalDS NULL", {
     input <- NULL
 
     expect_error(asLogicalDS("input"), "ERROR: for ds.asLogical function, x.name must specify an input object of class numeric, integer, character or matrix", fixed = TRUE)
 })
 
-context("asLogicalDS::arg::input NA")
+# context("asLogicalDS::arg::input NA")
 test_that("simple asLogicalDS NA", {
     input <- NA
 
@@ -41,6 +42,6 @@ test_that("simple asLogicalDS NA", {
 # Done
 #
 
-context("asLogicalDS::arg::shutdown")
+# context("asLogicalDS::arg::shutdown")
 
-context("asLogicalDS::arg::done")
+# context("asLogicalDS::arg::done")

tests/testthat/test-arg-dataFrameFillDS.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -12,13 +13,13 @@
 # Set up
 #
 
-context("dataFrameFillDS::arg::setup")
+# context("dataFrameFillDS::arg::setup")
 
 #
 # Tests
 #
 
-context("dataFrameFillDS::arg")
+# context("dataFrameFillDS::arg")
 test_that("simple dataFrameFillDS, ascending, numeric", {
     df                  <- data.frame(v1 = c(-2.0, -3.0, 4.0, 2.0, 1.0, 0.0, -1.0, 3.0), v2 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0))
     allNames.transmit   <- "v1,v2,v3,v4,v5,v6,v7"
@@ -45,10 +46,10 @@ test_that("simple dataFrameFillDS, ascending, numeric", {
 # Shutdown
 #
 
-context("dataFrameFillDS::arg::shutdown")
+# context("dataFrameFillDS::arg::shutdown")
 
 #
 # Done
 #
 
-context("dataFrameFillDS::arg::done")
+# context("dataFrameFillDS::arg::done")

tests/testthat/test-arg-dataFrameSortDS.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -12,15 +13,15 @@
 # Set up
 #
 
-context("dataFrameSortDS::arg::setup")
+# context("dataFrameSortDS::arg::setup")
 
 set.standard.disclosure.settings()
 
 #
 # Tests
 #
 
-context("dataFrameSortDS::arg")
+# context("dataFrameSortDS::arg")
 test_that("simple dataFrameSortDS, factor error check", {
     df              <- data.frame(v1 = as.factor(c("a", "b", "c", "d", "b", "e", "f", "f")), v2 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0))
     sort.key.name   <- "df$v1"
@@ -34,10 +35,10 @@ test_that("simple dataFrameSortDS, factor error check", {
 # Shutdown
 #
 
-context("dataFrameSortDS::arg::shutdown")
+# context("dataFrameSortDS::arg::shutdown")
 
 #
 # Done
 #
 
-context("dataFrameSortDS::arg::done")
+# context("dataFrameSortDS::arg::done")

tests/testthat/test-arg-uniqueDS.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -12,29 +13,29 @@
 # Set up
 #
 
-context("uniqueDS::arg::setup")
+# context("uniqueDS::arg::setup")
 
 #
 # Tests
 #
 
-context("uniqueDS::arg::simple null argument")
+# context("uniqueDS::arg::simple null argument")
 test_that("simple uniqueDS for NULL", {
     expect_error(uniqueDS(NULL), "Variable's name can't be NULL", fixed = TRUE)
 })
 
-context("uniqueDS::arg::null value")
+# context("uniqueDS::arg::null value")
 test_that("simple uniqueDS for NULL", {
     input <- NULL
     expect_error(uniqueDS("input"), "Variable can't be NULL", fixed = TRUE)
 })
 
-context("uniqueDS::arg::not character value")
+# context("uniqueDS::arg::not character value")
 test_that("simple uniqueDS for NULL", {
   expect_error(uniqueDS(17), "Variable's name isn't a single character vector", fixed = TRUE)
 })
 
-context("uniqueDS::arg::missing value")
+# context("uniqueDS::arg::missing value")
 test_that("simple uniqueDS for NULL", {
     expect_error(uniqueDS("input"), "object 'input' not found", fixed = TRUE)
 })
@@ -43,6 +44,6 @@ test_that("simple uniqueDS for NULL", {
 # Done
 #
 
-context("uniqueDS::arg::shutdown")
+# context("uniqueDS::arg::shutdown")
 
-context("uniqueDS::arg::done")
+# context("uniqueDS::arg::done")

tests/testthat/test-disc-meanDS.R

@@ -1,5 +1,6 @@
 #-------------------------------------------------------------------------------
 # Copyright (c) 2019-2022 University of Newcastle upon Tyne. All rights reserved.
+# Copyright (c) 2022-2025 Arjuna Technologies, Newcastle upon Tyne. All rights reserved.
 #
 # This program and the accompanying materials
 # are made available under the terms of the GNU Public License v3.0.
@@ -12,15 +13,15 @@
 # Set up
 #
 
-context("meanDS::disc::setup")
+# context("meanDS::disc::setup")
 
 set.standard.disclosure.settings()
 
 #
 # Tests
 #
 
-context("meanDS::disc::numeric with below nfilter.tab values")
+# context("meanDS::disc::numeric with below nfilter.tab values")
 test_that("numeric meanDS, with below nfilter.tab values", {
     input <- c(NA, NA, 2.0, NA, 4.0)
 
@@ -31,6 +32,6 @@ test_that("numeric meanDS, with below nfilter.tab values", {
 # Done
 #
 
-context("meanDS::disc::shutdown")
+# context("meanDS::disc::shutdown")
 
-context("meanDS::disc::done")
+# context("meanDS::disc::done")