From 56b1b45a1d3758403634b0490c7e3aa7687fbd4e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 12:35:19 +0200 Subject: [PATCH 01/65] Add serverside checks for class and object existence --- R/colnamesDS.R | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/R/colnamesDS.R b/R/colnamesDS.R index eb1bffb9..3ffe40a4 100644 --- a/R/colnamesDS.R +++ b/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 <- .load_serverside_object(x) + .check_class(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) out <- colnames(x.val) - - # return the dimension return(out) - } #AGGREGATE FUNCTION # colnamesDS From 4a9df9f3f88d37e48e9ac7c90931c92cce0eff25 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 12:36:18 +0200 Subject: [PATCH 02/65] add functions in helper file --- R/utils.R | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 R/utils.R diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 00000000..12304bfb --- /dev/null +++ b/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 +.load_serverside_object <- function(x) { + tryCatch( + eval(parse(text = x), envir = parent.frame()), + 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. +#' +#' @return Invisibly returns `TRUE` if the class check passes; otherwise throws an error. +#' @noRd +.check_class <- 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 {paste(permitted_classes, collapse = ' or ')}. ", + "'{obj_name}' is type {typ}." + ) + + stop(msg, call. = FALSE) + } + + invisible(TRUE) +} From 3280cd16dfc9c7001bd7424253820ad42263fb82 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 12:46:13 +0200 Subject: [PATCH 03/65] ran check, added dependencies --- DESCRIPTION | 3 ++- NAMESPACE | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d00d8a10..80344b1b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -71,7 +71,8 @@ Imports: gamlss, gamlss.dist, mice, - childsds + childsds, + glue Suggests: spelling, testthat diff --git a/NAMESPACE b/NAMESPACE index 897148d1..db4a5378 100644 --- a/NAMESPACE +++ b/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) From cee9a8126898099bf1993263d45fa0404955bc01 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 12:46:34 +0200 Subject: [PATCH 04/65] just use glue within messages for consistency --- R/utils.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils.R b/R/utils.R index 12304bfb..3103e010 100644 --- a/R/utils.R +++ b/R/utils.R @@ -23,7 +23,7 @@ #' @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 .check_class <- function(obj, obj_name, permitted_classes) { @@ -31,7 +31,7 @@ if (!any(permitted_classes %in% typ)) { msg <- glue( - "The server-side object must be of type {paste(permitted_classes, collapse = ' or ')}. ", + "The server-side object must be of type {glue_collapse(permitted_classes, sep = ' or ')}. ", "'{obj_name}' is type {typ}." ) From 29d73aadf2da34878f7b7409a167ddda695ef4ae Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 12:54:23 +0200 Subject: [PATCH 05/65] renamed snake case to camel case to match naming convention --- R/colnamesDS.R | 4 ++-- R/utils.R | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/colnamesDS.R b/R/colnamesDS.R index 3ffe40a4..6dc2e99e 100644 --- a/R/colnamesDS.R +++ b/R/colnamesDS.R @@ -8,8 +8,8 @@ #' @export #' colnamesDS <- function(x){ - x.val <- .load_serverside_object(x) - .check_class(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) out <- colnames(x.val) return(out) } diff --git a/R/utils.R b/R/utils.R index 3103e010..8910dbf9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -6,7 +6,7 @@ #' @param x A character string naming the object to be retrieved. #' @return The evaluated R object referred to by `x`. #' @noRd -.load_serverside_object <- function(x) { +.loadServersideObject <- function(x) { tryCatch( eval(parse(text = x), envir = parent.frame()), error = function(e) { @@ -26,7 +26,7 @@ #' @importFrom glue glue glue_collapse #' @return Invisibly returns `TRUE` if the class check passes; otherwise throws an error. #' @noRd -.check_class <- function(obj, obj_name, permitted_classes) { +.checkClass <- function(obj, obj_name, permitted_classes) { typ <- class(obj) if (!any(permitted_classes %in% typ)) { From 245bbbabf8d2058f69aef6539792770b9713d36c Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 13:05:00 +0200 Subject: [PATCH 06/65] require testthat version 3 --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 80344b1b..44b879c2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -75,7 +75,8 @@ Imports: glue Suggests: spelling, - testthat + testthat (>= 3.0.0) RoxygenNote: 7.3.3 Encoding: UTF-8 Language: en-GB +Config/testthat/edition: 3 From 01b0f0feb6fb2977cd85e570e4614be14906aa49 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 13:05:14 +0200 Subject: [PATCH 07/65] test: unit tests for helper files --- tests/testthat/test-smk-utils.R | 46 +++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 tests/testthat/test-smk-utils.R diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R new file mode 100644 index 00000000..de901962 --- /dev/null +++ b/tests/testthat/test-smk-utils.R @@ -0,0 +1,46 @@ + +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +context("utils::smk::setup") +test_that(".loadServersideObject() returns existing object", { + test_df <- data.frame(a = 1:3) + result <- .loadServersideObject("test_df") + expect_identical(result, test_df) +}) + +test_that(".loadServersideObject() throws error for missing object", { + expect_error( + .loadServersideObject("nonexistent_obj"), + regexp = "does not exist" + ) +}) + +test_that(".checkClass() passes for correct class", { + df <- data.frame(a = 1) + expect_invisible( + .checkClass(df, "df", c("data.frame", "matrix")) + ) +}) + +test_that(".checkClass() throws informative error for wrong class", { + x <- list(a = 1) + expect_error( + .checkClass(x, "x", c("data.frame", "matrix")), + regexp = "must be of type data.frame or matrix" + ) +}) + +context("utils::smk::shutdown") +context("utils::smk::done") From 4a1721264a70ca97c8b403452fddbda74fae5237 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 13:14:02 +0200 Subject: [PATCH 08/65] look in correct environment, ie 2 steps up --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 8910dbf9..6fd53936 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,7 +8,7 @@ #' @noRd .loadServersideObject <- function(x) { tryCatch( - eval(parse(text = x), envir = parent.frame()), + eval(parse(text = x), envir = parent.frame(2)), error = function(e) { stop("The server-side object", " '", x, "' ", "does not exist") } From 677173166dae22d4094d853e081d30c2f1b172c2 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 13:14:24 +0200 Subject: [PATCH 09/65] write unit tests for unhappy path --- tests/testthat/test-smk-colnamesDS.R | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-smk-colnamesDS.R b/tests/testthat/test-smk-colnamesDS.R index 2c4d3e3c..689cc2f3 100644 --- a/tests/testthat/test-smk-colnamesDS.R +++ b/tests/testthat/test-smk-colnamesDS.R @@ -42,10 +42,24 @@ test_that("simple colnamesDS, data.matrix", { expect_true("v2" %in% res) }) +test_that("colnamesDS throws error when object does not exist", { + expect_error( + colnamesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("colnamesDS throws error when object is not data.frame or matrix", { + bad_input <- list(a = 1:3, b = 4:6) + expect_error( + colnamesDS("bad_input"), + regexp = "must be of type data.frame or matrix" + ) +}) + # # Done # context("colnamesDS::smk::shutdown") - context("colnamesDS::smk::done") From c5e961ee0434f6bbe9865c9776aa2aa98b588271 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 9 Oct 2025 14:57:11 +0200 Subject: [PATCH 10/65] added template with checklist for PRs --- pull_request_template | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 pull_request_template diff --git a/pull_request_template b/pull_request_template new file mode 100644 index 00000000..561614a9 --- /dev/null +++ b/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` From cc8d8f8fbf0dc00dc46280c6076694f610b62de2 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 21 Oct 2025 11:21:36 +0100 Subject: [PATCH 11/65] Added 'pull_request_template' --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index 59863e10..26e4d4d4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,3 +11,4 @@ ^\.circleci/config\.yml$ ^\.github$ ^cran-comments\.md$ +^pull_request_template$ From aa9fb8f1005801b35e989bee3727762253e36b4d Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Sun, 26 Oct 2025 19:32:40 +0000 Subject: [PATCH 12/65] Updates for context() + copyright --- .../perf_files/default_perf_profile.csv | 8 ++--- tests/testthat/perf_files/hp-laptop_quay.csv | 8 ++--- tests/testthat/setup.R | 5 +-- tests/testthat/teardown.R | 5 +-- tests/testthat/test-arg-asIntegerDS.R | 10 +++--- tests/testthat/test-arg-asLogicalDS.R | 13 +++---- tests/testthat/test-arg-dataFrameFillDS.R | 9 ++--- tests/testthat/test-arg-dataFrameSortDS.R | 9 ++--- tests/testthat/test-arg-uniqueDS.R | 15 ++++---- tests/testthat/test-disc-meanDS.R | 9 ++--- tests/testthat/test-disc-varDS.R | 9 ++--- tests/testthat/test-perf-meanDS.R | 12 +++---- tests/testthat/test-perf-varDS.R | 12 +++---- tests/testthat/test-smk-BooleDS.R | 23 ++++++------ tests/testthat/test-smk-absDS.R | 19 +++++----- tests/testthat/test-smk-asCharacterDS.R | 15 ++++---- tests/testthat/test-smk-asDataMatrixDS.R | 9 ++--- tests/testthat/test-smk-asFactorDS1.R | 9 ++--- tests/testthat/test-smk-asFactorDS2.R | 8 ++--- tests/testthat/test-smk-asFactorSimpleDS.R | 9 ++--- tests/testthat/test-smk-asIntegerDS.R | 15 ++++---- tests/testthat/test-smk-asListDS.R | 9 ++--- tests/testthat/test-smk-asLogicalDS.R | 17 ++++----- tests/testthat/test-smk-asMatrixDS.R | 9 ++--- tests/testthat/test-smk-asNumericDS.R | 35 ++++++++++--------- tests/testthat/test-smk-aucDS.R | 7 ++-- tests/testthat/test-smk-bp_standardsDS.R | 11 +++--- tests/testthat/test-smk-cDS.R | 15 ++++---- tests/testthat/test-smk-cbindDS.R | 9 ++--- tests/testthat/test-smk-changeRefGroupDS.R | 9 ++--- tests/testthat/test-smk-checkNegValueDS.R | 11 +++--- tests/testthat/test-smk-classDS.R | 33 ++++++++--------- tests/testthat/test-smk-colnamesDS.R | 11 +++--- tests/testthat/test-smk-completeCasesDS.R | 15 ++++---- tests/testthat/test-smk-corDS.R | 15 ++++---- tests/testthat/test-smk-corTestDS.R | 19 +++++----- tests/testthat/test-smk-covDS.R | 11 +++--- tests/testthat/test-smk-dataFrameDS.R | 9 ++--- tests/testthat/test-smk-dataFrameFillDS.R | 10 +++--- tests/testthat/test-smk-dataFrameSortDS.R | 11 +++--- tests/testthat/test-smk-dataFrameSubsetDS1.R | 11 +++--- tests/testthat/test-smk-dataFrameSubsetDS2.R | 11 +++--- tests/testthat/test-smk-densityGridDS.R | 9 ++--- tests/testthat/test-smk-dimDS.R | 11 +++--- tests/testthat/test-smk-extract.R | 11 +++--- tests/testthat/test-smk-gamlssDS.R | 9 ++--- tests/testthat/test-smk-getWGSRDS.R | 9 ++--- tests/testthat/test-smk-hetcorDS.R | 9 ++--- tests/testthat/test-smk-igb_standardsDS.R | 9 ++--- tests/testthat/test-smk-isNaDS.R | 11 +++--- tests/testthat/test-smk-isValidDS.R | 33 ++++++++--------- tests/testthat/test-smk-kurtosisDS1.R | 13 +++---- tests/testthat/test-smk-kurtosisDS2.R | 9 ++--- tests/testthat/test-smk-lengthDS.R | 11 +++--- tests/testthat/test-smk-levelsDS.R | 9 ++--- tests/testthat/test-smk-listDS.R | 9 ++--- .../test-smk-listDisclosureSettingsDS.R | 9 ++--- tests/testthat/test-smk-lsDS.R | 11 +++--- tests/testthat/test-smk-meanDS.R | 13 +++---- tests/testthat/test-smk-messageDS.R | 9 ++--- tests/testthat/test-smk-metadataDS.R | 12 +++---- tests/testthat/test-smk-miceDS.R | 9 ++--- tests/testthat/test-smk-minMaxRandDS.R | 8 ++--- tests/testthat/test-smk-namesDS.R | 11 +++--- tests/testthat/test-smk-numNaDS.R | 9 ++--- tests/testthat/test-smk-quantileMeanDS.R | 11 +++--- tests/testthat/test-smk-rBinomDS.R | 9 ++--- tests/testthat/test-smk-rNormDS.R | 9 ++--- tests/testthat/test-smk-rPoisDS.R | 9 ++--- tests/testthat/test-smk-rUnifDS.R | 9 ++--- tests/testthat/test-smk-rangeDS.R | 11 +++--- tests/testthat/test-smk-rbindDS.R | 9 ++--- tests/testthat/test-smk-recodeLevelsDS.R | 7 ++-- tests/testthat/test-smk-recodeValuesDS.R | 7 ++-- tests/testthat/test-smk-replaceNaDS.R | 9 ++--- tests/testthat/test-smk-rmDS.R | 17 ++++----- tests/testthat/test-smk-rowColCalcDS.R | 9 ++--- tests/testthat/test-smk-sampleDS.R | 9 ++--- tests/testthat/test-smk-seqDS.R | 9 ++--- tests/testthat/test-smk-setFilterDS.R | 9 ++--- tests/testthat/test-smk-setSeedDS.R | 9 ++--- tests/testthat/test-smk-skewnessDS1.R | 13 +++---- tests/testthat/test-smk-skewnessDS2.R | 9 ++--- tests/testthat/test-smk-sqrtDS.R | 19 +++++----- tests/testthat/test-smk-subsetByClassDS.R | 9 ++--- tests/testthat/test-smk-subsetDS.R | 9 ++--- tests/testthat/test-smk-tapplyDS.R | 7 ++-- tests/testthat/test-smk-tapplyDS.assign.R | 9 ++--- tests/testthat/test-smk-testObjExistsDS.R | 35 ++++++++++--------- tests/testthat/test-smk-unListDS.R | 9 ++--- tests/testthat/test-smk-uniqueDS.R | 11 +++--- tests/testthat/test-smk-varDS.R | 13 +++---- tests/testthat/test-smk-vectorDS.R | 16 ++++----- 93 files changed, 583 insertions(+), 500 deletions(-) diff --git a/tests/testthat/perf_files/default_perf_profile.csv b/tests/testthat/perf_files/default_perf_profile.csv index 77f556bc..7ab03037 100644 --- a/tests/testthat/perf_files/default_perf_profile.csv +++ b/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" diff --git a/tests/testthat/perf_files/hp-laptop_quay.csv b/tests/testthat/perf_files/hp-laptop_quay.csv index 487b248f..7ab03037 100644 --- a/tests/testthat/perf_files/hp-laptop_quay.csv +++ b/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" diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index e7a0549e..c3e6b288 100644 --- a/tests/testthat/setup.R +++ b/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") diff --git a/tests/testthat/teardown.R b/tests/testthat/teardown.R index 2a5a788c..1088bcbe 100644 --- a/tests/testthat/teardown.R +++ b/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 . #------------------------------------------------------------------------------- -context("teardown - start") +# context("teardown - start") -context("teardown - done") +# context("teardown - done") diff --git a/tests/testthat/test-arg-asIntegerDS.R b/tests/testthat/test-arg-asIntegerDS.R index 5bd6ed58..c2ebd028 100644 --- a/tests/testthat/test-arg-asIntegerDS.R +++ b/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") diff --git a/tests/testthat/test-arg-asLogicalDS.R b/tests/testthat/test-arg-asLogicalDS.R index 7887ca74..33159504 100644 --- a/tests/testthat/test-arg-asLogicalDS.R +++ b/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") diff --git a/tests/testthat/test-arg-dataFrameFillDS.R b/tests/testthat/test-arg-dataFrameFillDS.R index d11cacd8..19c710aa 100644 --- a/tests/testthat/test-arg-dataFrameFillDS.R +++ b/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") diff --git a/tests/testthat/test-arg-dataFrameSortDS.R b/tests/testthat/test-arg-dataFrameSortDS.R index 6f193172..a720588d 100644 --- a/tests/testthat/test-arg-dataFrameSortDS.R +++ b/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,7 +13,7 @@ # Set up # -context("dataFrameSortDS::arg::setup") +# context("dataFrameSortDS::arg::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ 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") diff --git a/tests/testthat/test-arg-uniqueDS.R b/tests/testthat/test-arg-uniqueDS.R index 1c1a1133..48d6bd48 100644 --- a/tests/testthat/test-arg-uniqueDS.R +++ b/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") diff --git a/tests/testthat/test-disc-meanDS.R b/tests/testthat/test-disc-meanDS.R index 0d5b0ddc..22864733 100644 --- a/tests/testthat/test-disc-meanDS.R +++ b/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,7 +13,7 @@ # Set up # -context("meanDS::disc::setup") +# context("meanDS::disc::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ 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") diff --git a/tests/testthat/test-disc-varDS.R b/tests/testthat/test-disc-varDS.R index ed7d0384..3b60a771 100644 --- a/tests/testthat/test-disc-varDS.R +++ b/tests/testthat/test-disc-varDS.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,7 +13,7 @@ # Set up # -context("varDS::disc::setup") +# context("varDS::disc::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("varDS::disc::numeric with below nfilter.tab values") +# context("varDS::disc::numeric with below nfilter.tab values") test_that("numeric varDS, with below nfilter.tab values", { input <- c(NA, NA, 2.0, NA, 4.0) @@ -31,6 +32,6 @@ test_that("numeric varDS, with below nfilter.tab values", { # Done # -context("varDS::disc::shutdown") +# context("varDS::disc::shutdown") -context("varDS::disc::done") +# context("varDS::disc::done") diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 794e61b2..4cee2473 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.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. @@ -16,7 +16,7 @@ testthat::skip_on_cran() testthat::skip_on_ci() -context("meanDS::perf::setup") +# context("meanDS::perf::setup") set.standard.disclosure.settings() @@ -24,7 +24,7 @@ set.standard.disclosure.settings() # Tests # -context("meanDS::perf::numeric") +# context("meanDS::perf::numeric") test_that("numeric meanDS - performance", { skip_on_cran() @@ -59,7 +59,7 @@ test_that("numeric meanDS - performance", { expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") }) -context("meanDS::perf::numeric with NA") +# context("meanDS::perf::numeric with NA") test_that("numeric meanDS, with NA - performance", { skip_on_cran() @@ -98,6 +98,6 @@ test_that("numeric meanDS, with NA - performance", { # Done # -context("meanDS::perf::shutdown") +# context("meanDS::perf::shutdown") -context("meanDS::perf::done") +# context("meanDS::perf::done") diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index d468c5da..459e6f03 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.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. @@ -16,7 +16,7 @@ testthat::skip_on_cran() testthat::skip_on_ci() -context("varDS::perf::setup") +# context("varDS::perf::setup") set.standard.disclosure.settings() @@ -24,7 +24,7 @@ set.standard.disclosure.settings() # Tests # -context("varDS::perf::numeric") +# context("varDS::perf::numeric") test_that("numeric varDS - performance", { skip_on_cran() @@ -59,7 +59,7 @@ test_that("numeric varDS - performance", { expect_lt(.current.rate, .reference.rate * .reference.tolerance.upper, label = "Observed rate", expected.label = "upper threshold on rate") }) -context("varDS::perf::numeric with NA") +# context("varDS::perf::numeric with NA") test_that("numeric varDS, with NA - performance", { skip_on_cran() @@ -98,6 +98,6 @@ test_that("numeric varDS, with NA - performance", { # Done # -context("varDS::perf::shutdown") +# context("varDS::perf::shutdown") -context("varDS::perf::done") +# context("varDS::perf::done") diff --git a/tests/testthat/test-smk-BooleDS.R b/tests/testthat/test-smk-BooleDS.R index dd10c782..5fcfa4ee 100644 --- a/tests/testthat/test-smk-BooleDS.R +++ b/tests/testthat/test-smk-BooleDS.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("BooleDS::smk::setup") +# context("BooleDS::smk::setup") # # Tests # -context("BooleDS::smk::simple equal") +# context("BooleDS::smk::simple equal") test_that("simple BooleDS, equal numeric", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -47,7 +48,7 @@ test_that("simple BooleDS, equal logical", { expect_equal(res[5], FALSE) }) -context("BooleDS::smk::simple not-equal") +# context("BooleDS::smk::simple not-equal") test_that("simple BooleDS, not-equal numeric", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -76,7 +77,7 @@ test_that("simple BooleDS, not-equal logical", { expect_equal(res[5], TRUE) }) -context("BooleDS::smk::simple less-than") +# context("BooleDS::smk::simple less-than") test_that("simple BooleDS, less-than numeric", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -105,7 +106,7 @@ test_that("simple BooleDS, less-than logical", { expect_equal(res[5], FALSE) }) -context("BooleDS::smk::simple less-than-equal") +# context("BooleDS::smk::simple less-than-equal") test_that("simple BooleDS, less-than-equal numeric", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -134,7 +135,7 @@ test_that("simple BooleDS, less-than-equal logical", { expect_equal(res[5], FALSE) }) -context("BooleDS::smk::simple greater-than") +# context("BooleDS::smk::simple greater-than") test_that("simple BooleDS, greater-than numeric", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -163,7 +164,7 @@ test_that("simple BooleDS, greater-than logical", { expect_equal(res[5], TRUE) }) -context("BooleDS::smk::simple greater-than-equal") +# context("BooleDS::smk::simple greater-than-equal") test_that("simple BooleDS, greater-than-equal numeric", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -192,7 +193,7 @@ test_that("simple BooleDS, greater-than-equal logical", { expect_equal(res[5], TRUE) }) -context("BooleDS::smk::na-check numeric") +# context("BooleDS::smk::na-check numeric") test_that("na-check BooleDS, numeric, NA=NA", { input <- data.frame(v1 = c(0.0, NA, 2.0, 3.0, NA), v2 = c(NA, 3.0, 2.0, 1.0, NA)) @@ -235,7 +236,7 @@ test_that("na-check BooleDS, numeric, NA=1", { expect_equal(res[5], 1) }) -context("BooleDS::smk::na-check logical") +# context("BooleDS::smk::na-check logical") test_that("na-check BooleDS, logical, NA=NA", { input <- data.frame(v1 = c(0.0, NA, 2.0, 3.0, NA), v2 = c(NA, 3.0, 2.0, 1.0, NA)) @@ -282,6 +283,6 @@ test_that("na-check BooleDS, logical, NA=1", { # Done # -context("BooleDS::smk::shutdown") +# context("BooleDS::smk::shutdown") -context("BooleDS::smk::done") +# context("BooleDS::smk::done") diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index c9c1cca9..54655c99 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.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("absDS::smk::setup") +# context("absDS::smk::setup") # # Tests # -context("absDS::smk::special") +# context("absDS::smk::special") test_that("simple absDS, NA", { input <- NA @@ -59,7 +60,7 @@ test_that("simple absDS, -Inf", { expect_true(is.infinite(res)) }) -context("absDS::smk::numeric") +# context("absDS::smk::numeric") test_that("simple absDS, numeric 0.0", { input <- 0.0 @@ -90,7 +91,7 @@ test_that("simple absDS, numeric -10.0", { expect_equal(res, 10.0) }) -context("absDS::smk::integer") +# context("absDS::smk::integer") test_that("simple absDS, integer 0L", { input <- 0L @@ -121,7 +122,7 @@ test_that("simple absDS, integer -10L", { expect_equal(res, 10L) }) -context("absDS::smk::special vector") +# context("absDS::smk::special vector") test_that("simple absDS", { input <- c(NA, NaN, Inf, -Inf) @@ -135,7 +136,7 @@ test_that("simple absDS", { expect_true(is.infinite(res[4])) }) -context("absDS::smk::numeric vector") +# context("absDS::smk::numeric vector") test_that("simple absDS", { input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) @@ -151,7 +152,7 @@ test_that("simple absDS", { expect_equal(res[6], 20.0) }) -context("absDS::smk::integer vector") +# context("absDS::smk::integer vector") test_that("simple absDS", { input <- c(0L, 4L, 9L, -10L, -50L, -20L) @@ -171,6 +172,6 @@ test_that("simple absDS", { # Done # -context("absDS::smk::shutdown") +# context("absDS::smk::shutdown") -context("absDS::smk::done") +# context("absDS::smk::done") diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index a37c7a82..40cdaf73 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.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("asCharacterDS::smk::setup") +# context("asCharacterDS::smk::setup") # # Tests # -context("asCharacterDS::smk::numeric") +# context("asCharacterDS::smk::numeric") test_that("numeric asCharacterDS", { input <- 3.141 @@ -29,7 +30,7 @@ test_that("numeric asCharacterDS", { expect_equal(res, "3.141") }) -context("asCharacterDS::smk::numeric vector") +# context("asCharacterDS::smk::numeric vector") test_that("numeric vector asCharacterDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -44,7 +45,7 @@ test_that("numeric vector asCharacterDS", { expect_equal(res[5], "4") }) -context("asCharacterDS::smk::logical") +# context("asCharacterDS::smk::logical") test_that("logical asCharacterDS - FALSE", { input <- FALSE @@ -65,7 +66,7 @@ test_that("logical asCharacterDS - TRUE", { expect_equal(res, "TRUE") }) -context("asCharacterDS::smk::logical vector") +# context("asCharacterDS::smk::logical vector") test_that("logical vector asCharacterDS", { input <- c(TRUE, FALSE, TRUE, FALSE, TRUE) @@ -84,6 +85,6 @@ test_that("logical vector asCharacterDS", { # Done # -context("asCharacterDS::smk::shutdown") +# context("asCharacterDS::smk::shutdown") -context("asCharacterDS::smk::done") +# context("asCharacterDS::smk::done") diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index 6c4f567c..eaed9318 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.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("asDataMatrixDS::smk::setup") +# context("asDataMatrixDS::smk::setup") # # Tests # -context("asDataMatrixDS::smk::simple") +# context("asDataMatrixDS::smk::simple") test_that("simple asDataMatrixDS", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -59,6 +60,6 @@ test_that("simple asDataMatrixDS", { # Done # -context("asDataMatrixDS::smk::shutdown") +# context("asDataMatrixDS::smk::shutdown") -context("asDataMatrixDS::smk::done") +# context("asDataMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asFactorDS1.R b/tests/testthat/test-smk-asFactorDS1.R index fd59cefc..a990d4ff 100644 --- a/tests/testthat/test-smk-asFactorDS1.R +++ b/tests/testthat/test-smk-asFactorDS1.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,7 +13,7 @@ # Set up # -context("asFactorDS1::smk::setup") +# context("asFactorDS1::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorDS1::smk::simple") +# context("asFactorDS1::smk::simple") test_that("simple asFactorDS1", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -37,6 +38,6 @@ test_that("simple asFactorDS1", { # Done # -context("asFactorDS1::smk::shutdown") +# context("asFactorDS1::smk::shutdown") -context("asFactorDS1::smk::done") +# context("asFactorDS1::smk::done") diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index db4a3876..1c761d4d 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.R @@ -12,7 +12,7 @@ # Set up # -context("asFactorDS2::smk::setup") +# context("asFactorDS2::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorDS2::smk::simple") +# context("asFactorDS2::smk::simple") test_that("simple asFactorDS2, fixed.dummy.vars is FALSE", { input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) all.unique.levels.transmit <- "1,2,3,4" @@ -113,6 +113,6 @@ test_that("simple asFactorDS2, fixed.dummy.vars is TRUE", { # Done # -context("asFactorDS2::smk::shutdown") +# context("asFactorDS2::smk::shutdown") -context("asFactorDS2::smk::done") +# context("asFactorDS2::smk::done") diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index bafe51b3..dd5a17dc 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.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,7 +13,7 @@ # Set up # -context("asFactorSimpleDS::smk::setup") +# context("asFactorSimpleDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorSimpleDS::smk::simple") +# context("asFactorSimpleDS::smk::simple") test_that("simple asFactorSimpleDS", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -52,6 +53,6 @@ test_that("simple asFactorSimpleDS", { # Done # -context("asFactorSimpleDS::smk::shutdown") +# context("asFactorSimpleDS::smk::shutdown") -context("asFactorSimpleDS::smk::done") +# context("asFactorSimpleDS::smk::done") diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 902bc198..2ed33a33 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.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("asIntegerDS::smk::setup") +# context("asIntegerDS::smk::setup") # # Tests # -context("asIntegerDS::smk::numeric") +# context("asIntegerDS::smk::numeric") test_that("numeric asIntegerDS", { input <- 3.141 @@ -29,7 +30,7 @@ test_that("numeric asIntegerDS", { expect_equal(res, 3) }) -context("asIntegerDS::smk::numeric vector") +# context("asIntegerDS::smk::numeric vector") test_that("numeric vector asIntegerDS", { input <- c(0.1, 1.1, 2.1, 3.1, 4.1) @@ -44,7 +45,7 @@ test_that("numeric vector asIntegerDS", { expect_equal(res[5], 4) }) -context("asIntegerDS::smk::character") +# context("asIntegerDS::smk::character") test_that("character asIntegerDS - FALSE", { input <- "101" @@ -55,7 +56,7 @@ test_that("character asIntegerDS - FALSE", { expect_equal(res, 101) }) -context("asIntegerDS::smk::character vector") +# context("asIntegerDS::smk::character vector") test_that("character vector asIntegerDS", { input <- c("101", "202", "303", "404", "505") @@ -74,6 +75,6 @@ test_that("character vector asIntegerDS", { # Done # -context("asIntegerDS::smk::shutdown") +# context("asIntegerDS::smk::shutdown") -context("asIntegerDS::smk::done") +# context("asIntegerDS::smk::done") diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 7caa9368..5d448109 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.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("asListDS::smk::setup") +# context("asListDS::smk::setup") # # Tests # -context("asListDS::smk::simple") +# context("asListDS::smk::simple") test_that("simple asListDS", { input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) newobj.name <- 'newobj' @@ -41,6 +42,6 @@ test_that("simple asListDS", { # Done # -context("asListDS::smk::shutdown") +# context("asListDS::smk::shutdown") -context("asListDS::smk::done") +# context("asListDS::smk::done") diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index d931ad2b..3ea78d6e 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-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,13 +13,13 @@ # Set up # -context("asLogicalDS::smk::setup") +# context("asLogicalDS::smk::setup") # # Tests # -context("asLogicalDS::smk::integer") +# context("asLogicalDS::smk::integer") test_that("simple asLogicalDS integer - FALSE", { input <- 0L @@ -39,7 +40,7 @@ test_that("simple asLogicalDS integer - TRUE", { expect_equal(res, TRUE) }) -context("asLogicalDS::smk::integer vector") +# context("asLogicalDS::smk::integer vector") test_that("simple asLogicalDS integer vector", { input <- c(1L, 0L, 1L, 0L, 1L) @@ -54,7 +55,7 @@ test_that("simple asLogicalDS integer vector", { expect_equal(res[5], TRUE) }) -context("asLogicalDS::smk::numeric") +# context("asLogicalDS::smk::numeric") test_that("simple asLogicalDS numeric - FALSE", { input <- 0.0 @@ -75,7 +76,7 @@ test_that("simple asLogicalDS numeric - TRUE", { expect_equal(res, TRUE) }) -context("asLogicalDS::smk::numeric vector") +# context("asLogicalDS::smk::numeric vector") test_that("simple asLogicalDS numeric vector", { input <- c(1.0, 0.0, 1.0, 0.0, 1.0) @@ -90,7 +91,7 @@ test_that("simple asLogicalDS numeric vector", { expect_equal(res[5], TRUE) }) -context("asLogicalDS::smk::character") +# context("asLogicalDS::smk::character") test_that("simple asLogicalDS, character - FALSE", { input <- "F" @@ -170,6 +171,6 @@ test_that("simple asLogicalDS, character vector", { # Done # -context("asLogicalDS::smk::shutdown") +# context("asLogicalDS::smk::shutdown") -context("asLogicalDS::smk::done") +# context("asLogicalDS::smk::done") diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 6d873a5f..71222625 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.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("asMatrixDS::smk::setup") +# context("asMatrixDS::smk::setup") # # Tests # -context("asMatrixDS::smk::simple") +# context("asMatrixDS::smk::simple") test_that("simple asMatrixDS", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -59,6 +60,6 @@ test_that("simple asMatrixDS", { # Done # -context("asMatrixDS::smk::shutdown") +# context("asMatrixDS::smk::shutdown") -context("asMatrixDS::smk::done") +# context("asMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index d1e8d57c..c18782b8 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.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("asNumericDS::smk::setup") +# context("asNumericDS::smk::setup") # # Tests # -context("asNumericDS::smk::character") +# context("asNumericDS::smk::character") test_that("character asNumericDS - FALSE", { input <- "101" @@ -29,7 +30,7 @@ test_that("character asNumericDS - FALSE", { expect_equal(res, 101) }) -context("asNumericDS::smk::character vector") +# context("asNumericDS::smk::character vector") test_that("character vector asNumericDS", { input <- c("101", "202", "303", "404", "505") @@ -44,7 +45,7 @@ test_that("character vector asNumericDS", { expect_equal(res[5], 505) }) -context("asNumericDS::smk::character 'non numeric' vector") +# context("asNumericDS::smk::character 'non numeric' vector") test_that("character 'non numeric' vector asNumericDS", { input <- c("aa", "bb", "cc", "dd", "ee") @@ -59,7 +60,7 @@ test_that("character 'non numeric' vector asNumericDS", { expect_equal(res[5], 5) }) -context("asNumericDS::smk::factor vector") +# context("asNumericDS::smk::factor vector") test_that("factor vector asNumericDS", { vec <- c("101", "202", "303", "404", "505") input <- as.factor(vec) @@ -75,7 +76,7 @@ test_that("factor vector asNumericDS", { expect_equal(res[5], 505) }) -context("asNumericDS::smk::factor rev vector") +# context("asNumericDS::smk::factor rev vector") test_that("factor vector asNumericDS", { vec <- c("505", "404", "303", "202", "101") input <- as.factor(vec) @@ -91,7 +92,7 @@ test_that("factor vector asNumericDS", { expect_equal(res[5], 101) }) -context("asNumericDS::smk::factor numeric levels vector") +# context("asNumericDS::smk::factor numeric levels vector") test_that("factor numeric levels vector asNumericDS", { vec <- c("aa", "bb", "cc", "dd", "ee") input <- as.factor(vec) @@ -108,7 +109,7 @@ test_that("factor numeric levels vector asNumericDS", { expect_equal(res[5], 55) }) -context("asNumericDS::smk::factor vector with only numbers in its values") +# context("asNumericDS::smk::factor vector with only numbers in its values") test_that("factor vector with only numbers in its values asNumericDS", { input <- as.factor(c('1','1','2','2','1')) @@ -123,7 +124,7 @@ test_that("factor vector with only numbers in its values asNumericDS", { expect_equal(res[5], 1) }) -context("asNumericDS::smk::factor vector with only characters in its values") +# context("asNumericDS::smk::factor vector with only characters in its values") test_that("factor vector with only characters in its values asNumericDS", { input <- as.factor(c('b','b','a','a','b')) @@ -138,7 +139,7 @@ test_that("factor vector with only characters in its values asNumericDS", { expect_equal(res[5], 2) }) -context("asNumericDS::smk::character vector with only numbers in its values") +# context("asNumericDS::smk::character vector with only numbers in its values") test_that("factor vector with only numbers in its values asNumericDS", { input <- c('1','1','2','2','1') @@ -153,7 +154,7 @@ test_that("factor vector with only numbers in its values asNumericDS", { expect_equal(res[5], 1) }) -context("asNumericDS::smk::character vector with only characters in its values") +# context("asNumericDS::smk::character vector with only characters in its values") test_that("character vector with only characters in its values asNumericDS", { input <- c('b','b','a','a','b') @@ -168,7 +169,7 @@ test_that("character vector with only characters in its values asNumericDS", { expect_equal(res[5], 2) }) -context("asNumericDS::smk::character vector with strings having characters and numbers") +# context("asNumericDS::smk::character vector with strings having characters and numbers") test_that("character vector with strings having characters and numbers asNumericDS", { input <- c('b1','b2','1a','a','b') @@ -183,7 +184,7 @@ test_that("character vector with strings having characters and numbers asNumeric expect_equal(res[5], 3) }) -context("asNumericDS::smk::logical vector") +# context("asNumericDS::smk::logical vector") test_that("logical vector asNumericDS", { input <- c(TRUE, TRUE, FALSE, TRUE) @@ -197,7 +198,7 @@ test_that("logical vector asNumericDS", { expect_equal(res[4], 1) }) -context("asNumericDS::smk::logical character vector") +# context("asNumericDS::smk::logical character vector") test_that("logical vector character asNumericDS", { input <- c("TRUE", "TRUE", "FALSE", "TRUE") @@ -211,7 +212,7 @@ test_that("logical vector character asNumericDS", { expect_equal(res[4], 2) }) -context("asNumericDS::smk::integer vector") +# context("asNumericDS::smk::integer vector") test_that("integer vector asNumericDS", { input <- as.integer(c('1','1','2','2','1')) @@ -230,6 +231,6 @@ test_that("integer vector asNumericDS", { # Done # -context("asNumericDS::smk::shutdown") +# context("asNumericDS::smk::shutdown") -context("asNumericDS::smk::done") +# context("asNumericDS::smk::done") diff --git a/tests/testthat/test-smk-aucDS.R b/tests/testthat/test-smk-aucDS.R index 800bbcf4..2e03ccdb 100644 --- a/tests/testthat/test-smk-aucDS.R +++ b/tests/testthat/test-smk-aucDS.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,7 +13,7 @@ # Set up # -context("aucDS::smk::setup") +# context("aucDS::smk::setup") # # Tests @@ -39,6 +40,6 @@ test_that("aucDS", { # Done # -context("aucDS::smk::shutdown") +# context("aucDS::smk::shutdown") -context("aucDS::smk::done") +# context("aucDS::smk::done") diff --git a/tests/testthat/test-smk-bp_standardsDS.R b/tests/testthat/test-smk-bp_standardsDS.R index 906dd34f..fe8b9bc1 100644 --- a/tests/testthat/test-smk-bp_standardsDS.R +++ b/tests/testthat/test-smk-bp_standardsDS.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("bp_standardsDS::smk::setup") +# context("bp_standardsDS::smk::setup") # # Tests # -context("bp_standardsDS::smk::systolic") +# context("bp_standardsDS::smk::systolic") test_that("systolic bp_standardsDS", { sex <- c(2, 2, 2, 2, 2, 1, 2, 1, 2, 1) @@ -46,7 +47,7 @@ test_that("systolic bp_standardsDS", { }) -context("bp_standardsDS::smk::diastolic") +# context("bp_standardsDS::smk::diastolic") test_that("diastolic bp_standardsDS", { sex <- c(2, 2, 2, 2, 2, 1, 2, 1, 2, 1) @@ -79,6 +80,6 @@ test_that("diastolic bp_standardsDS", { # Done # -context("bp_standardsDS::smk::shutdown") +# context("bp_standardsDS::smk::shutdown") -context("bp_standardsDS::smk::done") +# context("bp_standardsDS::smk::done") diff --git a/tests/testthat/test-smk-cDS.R b/tests/testthat/test-smk-cDS.R index b3df1a65..0f9842fc 100644 --- a/tests/testthat/test-smk-cDS.R +++ b/tests/testthat/test-smk-cDS.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,7 +13,7 @@ # Set up # -context("cDS::smk::setup") +# context("cDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("cDS::smk::numeric list") +# context("cDS::smk::numeric list") test_that("numeric list cDS", { input <- list(a=0.0, b=1.0, c=2.0, d=3.0) @@ -34,7 +35,7 @@ test_that("numeric list cDS", { expect_equal(res[[4]], 3.0) }) -context("cDS::smk::character list") +# context("cDS::smk::character list") test_that("character list cDS", { input <- list(a="0.0", b="1.0", c="2.0", d="3.0") @@ -48,7 +49,7 @@ test_that("character list cDS", { expect_equal(res[[4]], "3.0") }) -context("cDS::smk::numeric list small") +# context("cDS::smk::numeric list small") test_that("single numeric list small cDS", { input <- list(a=0, b=1) @@ -60,7 +61,7 @@ test_that("single numeric list small cDS", { expect_equal(res[[2]], NA) }) -context("cDS::smk::empty list") +# context("cDS::smk::empty list") test_that("empty list cDS", { input <- list() @@ -74,6 +75,6 @@ test_that("empty list cDS", { # Done # -context("cDS::smk::shutdown") +# context("cDS::smk::shutdown") -context("cDS::smk::done") +# context("cDS::smk::done") diff --git a/tests/testthat/test-smk-cbindDS.R b/tests/testthat/test-smk-cbindDS.R index c1ed0a2f..11fe1ef3 100644 --- a/tests/testthat/test-smk-cbindDS.R +++ b/tests/testthat/test-smk-cbindDS.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("cbindDS::smk::setup") +# context("cbindDS::smk::setup") # # Tests # -context("cbindDS::smk::simple") +# context("cbindDS::smk::simple") test_that("simple cbindDS", { inputs <- 'input1,input2' input1 <- c(0.0, 1.0, 2.0, 3.0) @@ -44,6 +45,6 @@ test_that("simple cbindDS", { # Done # -context("cbindDS::smk::shutdown") +# context("cbindDS::smk::shutdown") -context("cbindDS::smk::done") +# context("cbindDS::smk::done") diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index 0bdd87ae..3d94fde7 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.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("changeRefGroupDS::smk::setup") +# context("changeRefGroupDS::smk::setup") # # Tests # -context("changeRefGroupDS::smk") +# context("changeRefGroupDS::smk") test_that("simple changeRefGroupDS, reorderByRef is FALSE", { x <- c(8, 1, 6, 1, 4, 1, 2, 1) xf <- as.factor(x) @@ -107,6 +108,6 @@ test_that("simple changeRefGroupDS, reorderByRef is TRUE", { # Done # -context("changeRefGroupDS::smk::shutdown") +# context("changeRefGroupDS::smk::shutdown") -context("changeRefGroupDS::smk::done") +# context("changeRefGroupDS::smk::done") diff --git a/tests/testthat/test-smk-checkNegValueDS.R b/tests/testthat/test-smk-checkNegValueDS.R index 52b64cce..487a9709 100644 --- a/tests/testthat/test-smk-checkNegValueDS.R +++ b/tests/testthat/test-smk-checkNegValueDS.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("checkNegValueDS::smk::setup") +# context("checkNegValueDS::smk::setup") # # Tests # -context("checkNegValueDS::smk::with no neg") +# context("checkNegValueDS::smk::with no neg") test_that("simple checkNegValueDS, with no neg and no NA", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -39,7 +40,7 @@ test_that("simple checkNegValueDS, with no neg and NA", { expect_equal(res, FALSE) }) -context("checkNegValueDS::smk::with neg") +# context("checkNegValueDS::smk::with neg") test_that("simple checkNegValueDS, with neg and no NA", { input <- c(0.0, -1.0, -2.0, 3.0, -4.0, 5.0, -6.0, 7.0) @@ -64,6 +65,6 @@ test_that("simple checkNegValueDS, with neg and NA", { # Done # -context("checkNegValueDS::smk::shutdown") +# context("checkNegValueDS::smk::shutdown") -context("checkNegValueDS::smk::done") +# context("checkNegValueDS::smk::done") diff --git a/tests/testthat/test-smk-classDS.R b/tests/testthat/test-smk-classDS.R index 4b3d71b3..d2efcf40 100644 --- a/tests/testthat/test-smk-classDS.R +++ b/tests/testthat/test-smk-classDS.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("classDS::smk::setup") +# context("classDS::smk::setup") # # Tests # -context("classDS::smk::character") +# context("classDS::smk::character") test_that("simple classDS, character", { input <- "value" @@ -39,7 +40,7 @@ test_that("simple classDS, character vector", { expect_equal(res, "character") }) -context("classDS::smk::integer") +# context("classDS::smk::integer") test_that("simple classDS, integer", { input <- 1L @@ -60,7 +61,7 @@ test_that("simple classDS, integer vector", { expect_equal(res, "integer") }) -context("classDS::smk::numeric") +# context("classDS::smk::numeric") test_that("simple classDS, numeric", { input <- 1.1 @@ -81,7 +82,7 @@ test_that("simple classDS, numeric vector", { expect_equal(res, "numeric") }) -context("classDS::smk::logical") +# context("classDS::smk::logical") test_that("simple classDS, logical, FALSE", { input <- FALSE @@ -112,7 +113,7 @@ test_that("simple classDS, logical vector", { expect_equal(res, "logical") }) -context("classDS::smk::data.frame") +# context("classDS::smk::data.frame") test_that("simple classDS, data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -123,7 +124,7 @@ test_that("simple classDS, data.frame", { expect_equal(res, "data.frame") }) -context("classDS::smk::array") +# context("classDS::smk::array") test_that("simple classDS, array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -134,7 +135,7 @@ test_that("simple classDS, array", { expect_equal(res, "array") }) -context("classDS::smk::matrix") +# context("classDS::smk::matrix") test_that("simple classDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -154,7 +155,7 @@ test_that("simple classDS, matrix", { } }) -context("classDS::smk::data.matrix") +# context("classDS::smk::data.matrix") test_that("simple classDS, data.matrix", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) @@ -174,7 +175,7 @@ test_that("simple classDS, data.matrix", { } }) -context("classDS::smk::date") +# context("classDS::smk::date") test_that("simple classDS, date", { input <- Sys.Date() @@ -185,7 +186,7 @@ test_that("simple classDS, date", { expect_equal(res, "Date") }) -context("classDS::smk::formula") +# context("classDS::smk::formula") test_that("simple classDS, formula", { input <- X ~ A + B @@ -196,7 +197,7 @@ test_that("simple classDS, formula", { expect_equal(res, "formula") }) -context("classDS::smk::environment") +# context("classDS::smk::environment") test_that("simple classDS, environment", { input <- environment() @@ -207,7 +208,7 @@ test_that("simple classDS, environment", { expect_equal(res, "environment") }) -context("classDS::smk::NA") +# context("classDS::smk::NA") test_that("special classDS, NA", { input <- NA @@ -218,7 +219,7 @@ test_that("special classDS, NA", { expect_equal(res, "logical") }) -context("classDS::smk::NULL") +# context("classDS::smk::NULL") test_that("special classDS, NULL", { input <- NULL @@ -233,6 +234,6 @@ test_that("special classDS, NULL", { # Done # -context("classDS::smk::shutdown") +# context("classDS::smk::shutdown") -context("classDS::smk::done") +# context("classDS::smk::done") diff --git a/tests/testthat/test-smk-colnamesDS.R b/tests/testthat/test-smk-colnamesDS.R index 2c4d3e3c..af29ac42 100644 --- a/tests/testthat/test-smk-colnamesDS.R +++ b/tests/testthat/test-smk-colnamesDS.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("colnamesDS::smk::setup") +# context("colnamesDS::smk::setup") # # Tests # -context("colnamesDS::smk::data.frame") +# context("colnamesDS::smk::data.frame") test_that("simple colnamesDS, data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -30,7 +31,7 @@ test_that("simple colnamesDS, data.frame", { expect_true("v2" %in% res) }) -context("colnamesDS::smk::data.matrix") +# context("colnamesDS::smk::data.matrix") test_that("simple colnamesDS, data.matrix", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) @@ -46,6 +47,6 @@ test_that("simple colnamesDS, data.matrix", { # Done # -context("colnamesDS::smk::shutdown") +# context("colnamesDS::smk::shutdown") -context("colnamesDS::smk::done") +# context("colnamesDS::smk::done") diff --git a/tests/testthat/test-smk-completeCasesDS.R b/tests/testthat/test-smk-completeCasesDS.R index 68bedebf..2ba7b913 100644 --- a/tests/testthat/test-smk-completeCasesDS.R +++ b/tests/testthat/test-smk-completeCasesDS.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("completeCasesDS::smk::setup") +# context("completeCasesDS::smk::setup") # # Tests # -context("completeCasesDS::smk::vector") +# context("completeCasesDS::smk::vector") test_that("simple completeCasesDS, vector, with no NAs", { input <- c(1.1, 2.1, 3.1, 4.1) @@ -44,7 +45,7 @@ test_that("simple completeCasesDS, vector, with NAs", { expect_equal(res[3], 4.1) }) -context("completeCasesDS::smk::data.frame") +# context("completeCasesDS::smk::data.frame") test_that("simple completeCasesDS, data.frame, with no NAs", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -93,7 +94,7 @@ test_that("simple completeCasesDS, data.frame, with NAs", { expect_equal(res.colnames[2], "v2") }) -context("completeCasesDS::smk::matrix") +# context("completeCasesDS::smk::matrix") test_that("simple completeCasesDS, matrix, with no NAs", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -120,7 +121,7 @@ test_that("simple completeCasesDS, matrix, with NAs", { expect_equal(res[3], 4.0) }) -context("completeCasesDS::smk::data.matrix") +# context("completeCasesDS::smk::data.matrix") test_that("simple completeCasesDS, data.matrix, with no NAs", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) @@ -193,6 +194,6 @@ test_that("simple completeCasesDS, data.matrix, with NAs", { # Done # -context("completeCasesDS::smk::shutdown") +# context("completeCasesDS::smk::shutdown") -context("completeCasesDS::smk::done") +# context("completeCasesDS::smk::done") diff --git a/tests/testthat/test-smk-corDS.R b/tests/testthat/test-smk-corDS.R index c0c4c06e..bdc3607c 100644 --- a/tests/testthat/test-smk-corDS.R +++ b/tests/testthat/test-smk-corDS.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,7 +13,7 @@ # Set up # -context("corDS::smk::setup") +# context("corDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -#context("corDS::smk::pairwise without na") +# context("corDS::smk::pairwise without na") #test_that("simple corDS, pairwise, full", { # x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) # y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -280,7 +281,7 @@ set.standard.disclosure.settings() # expect_equal(res$sums.of.squares[4], 141.06) #}) -#context("corDS::smk::pairwise with na") +# context("corDS::smk::pairwise with na") #test_that("simple corDS, pairwise, some", { # x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) # y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -367,7 +368,7 @@ set.standard.disclosure.settings() # expect_equal(res$sums.of.squares[4], 75.0) #}) -context("corDS::smk::casewise without na") +# context("corDS::smk::casewise without na") test_that("simple corDS, casewise, full", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -629,7 +630,7 @@ test_that("simple corDS, casewise, some", { expect_equal(res$sums.of.squares[4], 141.06) }) -context("corDS::smk::casewise with na") +# context("corDS::smk::casewise with na") test_that("simple corDS, casewise, some", { x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -721,6 +722,6 @@ test_that("simple corDS, casewise, some", { # Done # -context("corDS::smk::shutdown") +# context("corDS::smk::shutdown") -context("corDS::smk::done") +# context("corDS::smk::done") diff --git a/tests/testthat/test-smk-corTestDS.R b/tests/testthat/test-smk-corTestDS.R index a36e2082..1314b933 100644 --- a/tests/testthat/test-smk-corTestDS.R +++ b/tests/testthat/test-smk-corTestDS.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,7 +13,7 @@ # Set up # -context("corTestDS::smk::setup") +# context("corTestDS::smk::setup") # # Tests @@ -20,7 +21,7 @@ context("corTestDS::smk::setup") ########### -context("corTestDS::smk::without na, pearson") +# context("corTestDS::smk::without na, pearson") test_that("simple corTestDS, full, without na, pearson", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -180,7 +181,7 @@ test_that("simple corTestDS, some, pearson, without na, pearson", { expect_equal(res$`Correlation test`$conf.int[[2]], 0.9998169, tolerance = 1e-6) }) -context("corTestDS::smk::with na, pearson") +# context("corTestDS::smk::with na, pearson") test_that("simple corTestDS, some, with na, pearson", { x <- c(NA, 1.0, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -229,7 +230,7 @@ test_that("simple corTestDS, some, with na, pearson", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::without na, kendall") +# context("corTestDS::smk::without na, kendall") test_that("simple corTestDS, full, without na, kendall", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -368,7 +369,7 @@ test_that("simple corTestDS, some, kendall, without na, kendall", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::with na, kendall") +# context("corTestDS::smk::with na, kendall") test_that("simple corTestDS, some, with na, kendall", { x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -415,7 +416,7 @@ test_that("simple corTestDS, some, with na, kendall", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::without na, spearman") +# context("corTestDS::smk::without na, spearman") test_that("simple corTestDS, full, without na, spearman", { x <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) y <- c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0) @@ -554,7 +555,7 @@ test_that("simple corTestDS, some, spearman, without na, spearman", { expect_equal(res$`Correlation test`$data.name[[1]], "x.var and y.var") }) -context("corTestDS::smk::with na, spearman") +# context("corTestDS::smk::with na, spearman") test_that("simple corTestDS, some, with na, spearman", { x <- c(0.0, NA, 2.0, 3.0, NA, 5.0, NA, 7.0) y <- c(0.0, 1.0, NA, 3.0, 4.0, NA, NA, 7.0) @@ -605,7 +606,7 @@ test_that("simple corTestDS, some, with na, spearman", { # Done # -context("corTestDS::smk::shutdown") +# context("corTestDS::smk::shutdown") -context("corTestDS::smk::done") +# context("corTestDS::smk::done") diff --git a/tests/testthat/test-smk-covDS.R b/tests/testthat/test-smk-covDS.R index da05102c..ce731938 100644 --- a/tests/testthat/test-smk-covDS.R +++ b/tests/testthat/test-smk-covDS.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,7 +13,7 @@ # Set up # -context("covDS::smk::setup") +# context("covDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("covDS::smk::casewise.complete") +# context("covDS::smk::casewise.complete") test_that("numeric covDS, casewise.complete", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), v2 = c(7.0, 6.0, 5.0, 4.0, 3.0, 2.0, 1.0, 0.0)) @@ -123,7 +124,7 @@ test_that("numeric covDS, casewise.complete", { expect_true(is.na(res$errorMessage)) }) -context("covDS::smk::pairwise.complete") +# context("covDS::smk::pairwise.complete") test_that("numeric covDS, pairwise.complete", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), v2 = c(7.0, 6.0, 5.0, 4.0, 3.0, 2.0, 1.0, 0.0)) @@ -235,6 +236,6 @@ test_that("numeric covDS, pairwise.complete", { # Done # -context("covDS::smk::shutdown") +# context("covDS::smk::shutdown") -context("covDS::smk::done") +# context("covDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameDS.R b/tests/testthat/test-smk-dataFrameDS.R index af6ff6d5..18fc3b4b 100644 --- a/tests/testthat/test-smk-dataFrameDS.R +++ b/tests/testthat/test-smk-dataFrameDS.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,7 +13,7 @@ # Set up # -context("dataFrameDS::smk::setup") +# context("dataFrameDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameDS::smk") +# context("dataFrameDS::smk") test_that("simple dataFrameDS", { v1 <- c(0.0, 1.0, 2.0, 3.0, 4.0) v2 <- c(4.0, 3.0, 2.0, 1.0, 0.0) @@ -81,10 +82,10 @@ test_that("simple dataFrameDS, strAsFactors is TRUE", { # Stutdown # -context("dataFrameDS::smk::shutdown") +# context("dataFrameDS::smk::shutdown") # # Done # -context("dataFrameDS::smk::done") +# context("dataFrameDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameFillDS.R b/tests/testthat/test-smk-dataFrameFillDS.R index 5cc880f7..8da7a882 100644 --- a/tests/testthat/test-smk-dataFrameFillDS.R +++ b/tests/testthat/test-smk-dataFrameFillDS.R @@ -1,6 +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. @@ -13,13 +13,13 @@ # Set up # -context("dataFrameFillDS::smk::setup") +# context("dataFrameFillDS::smk::setup") # # Tests # -context("dataFrameFillDS::smk") +# context("dataFrameFillDS::smk") 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" @@ -94,10 +94,10 @@ test_that("simple dataFrameFillDS, ascending, numeric", { # Shutdown # -context("dataFrameFillDS::smk::shutdown") +# context("dataFrameFillDS::smk::shutdown") # # Done # -context("dataFrameFillDS::smk::done") +# context("dataFrameFillDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameSortDS.R b/tests/testthat/test-smk-dataFrameSortDS.R index b81965e0..39a7378b 100644 --- a/tests/testthat/test-smk-dataFrameSortDS.R +++ b/tests/testthat/test-smk-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,7 +13,7 @@ # Set up # -context("dataFrameSortDS::smk::setup") +# context("dataFrameSortDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSortDS::smk::numeric input") +# context("dataFrameSortDS::smk::numeric input") test_that("simple dataFrameSortDS, ascending, default", { 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)) sort.key.name <- "df$v1" @@ -243,7 +244,7 @@ test_that("simple dataFrameSortDS, descending, alphabetic", { expect_equal(res$v2[8], 6.0) }) -context("dataFrameSortDS::smk::string input") +# context("dataFrameSortDS::smk::string input") test_that("simple dataFrameSortDS, ascending, default", { 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"), stringsAsFactors = FALSE) sort.key.name <- "df$v1" @@ -471,6 +472,6 @@ test_that("simple dataFrameSortDS, descending, alphabetic", { # Done # -context("dataFrameSortDS::smk::shutdown") +# context("dataFrameSortDS::smk::shutdown") -context("dataFrameSortDS::smk::done") +# context("dataFrameSortDS::smk::done") diff --git a/tests/testthat/test-smk-dataFrameSubsetDS1.R b/tests/testthat/test-smk-dataFrameSubsetDS1.R index 93dbca26..c519cefa 100644 --- a/tests/testthat/test-smk-dataFrameSubsetDS1.R +++ b/tests/testthat/test-smk-dataFrameSubsetDS1.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,7 +13,7 @@ # Set up # -context("gamlssDS::smk::setup") +# context("gamlssDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSubsetDS1::smk::test1") +# context("dataFrameSubsetDS1::smk::test1") test_that("test1 dataFrameSubsetDS1", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -42,7 +43,7 @@ test_that("test1 dataFrameSubsetDS1", { }) -context("dataFrameSubsetDS1::smk::test2") +# context("dataFrameSubsetDS1::smk::test2") test_that("test2 dataFrameSubsetDS1", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -77,6 +78,6 @@ test_that("test2 dataFrameSubsetDS1", { # Done # -context("dataFrameSubsetDS1::smk::shutdown") +# context("dataFrameSubsetDS1::smk::shutdown") -context("dataFrameSubsetDS1::smk::done") +# context("dataFrameSubsetDS1::smk::done") diff --git a/tests/testthat/test-smk-dataFrameSubsetDS2.R b/tests/testthat/test-smk-dataFrameSubsetDS2.R index 619da16c..c93dc595 100644 --- a/tests/testthat/test-smk-dataFrameSubsetDS2.R +++ b/tests/testthat/test-smk-dataFrameSubsetDS2.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,7 +13,7 @@ # Set up # -context("gamlssDS::smk::setup") +# contect("gamlssDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("dataFrameSubsetDS2::smk::test1") +# contect("dataFrameSubsetDS2::smk::test1") test_that("test1 dataFrameSubsetDS2", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -47,7 +48,7 @@ test_that("test1 dataFrameSubsetDS2", { }) -context("dataFrameSubsetDS2::smk::test2") +# contect("dataFrameSubsetDS2::smk::test2") test_that("test2 dataFrameSubsetDS2", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -74,6 +75,6 @@ test_that("test2 dataFrameSubsetDS2", { # Done # -context("dataFrameSubsetDS2::smk::shutdown") +# contect("dataFrameSubsetDS2::smk::shutdown") -context("dataFrameSubsetDS2::smk::done") +# contect("dataFrameSubsetDS2::smk::done") diff --git a/tests/testthat/test-smk-densityGridDS.R b/tests/testthat/test-smk-densityGridDS.R index 612386bb..2c075a4b 100644 --- a/tests/testthat/test-smk-densityGridDS.R +++ b/tests/testthat/test-smk-densityGridDS.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,7 +13,7 @@ # Set up # -context("densityGridDS::smk::setup") +# context("densityGridDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("densityGridDS::smk") +# context("densityGridDS::smk") test_that("densityGridDS", { xvect <- c(11.95, 10.06, 9.98, 9.50, 12.26, 9.66, 11.08, 12.29, 11.00, 9.91, @@ -53,6 +54,6 @@ test_that("densityGridDS", { # Done # -context("densityGridDS::smk::shutdown") +# context("densityGridDS::smk::shutdown") -context("densityGridDS::smk::done") +# context("densityGridDS::smk::done") diff --git a/tests/testthat/test-smk-dimDS.R b/tests/testthat/test-smk-dimDS.R index 5dbdb6de..7915e9a1 100644 --- a/tests/testthat/test-smk-dimDS.R +++ b/tests/testthat/test-smk-dimDS.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("dimDS::smk::setup") +# context("dimDS::smk::setup") # # Tests # -context("dimDS::smk::numeric") +# context("dimDS::smk::numeric") test_that("numeric dimDS", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -30,7 +31,7 @@ test_that("numeric dimDS", { expect_equal(res[2], 2) }) -context("dimDS::smk::character") +# context("dimDS::smk::character") test_that("character dimDS", { input <- data.frame(v1 = c("0.0", "1.0", "2.0", "3.0", "4.0"), v2 = c("4.0", "3.0", "2.0", "1.0", "0.0"), stringsAsFactors = FALSE) @@ -46,6 +47,6 @@ test_that("character dimDS", { # Done # -context("dimDS::smk::shutdown") +# context("dimDS::smk::shutdown") -context("dimDS::smk::done") +# context("dimDS::smk::done") diff --git a/tests/testthat/test-smk-extract.R b/tests/testthat/test-smk-extract.R index bd471a67..9b1af851 100644 --- a/tests/testthat/test-smk-extract.R +++ b/tests/testthat/test-smk-extract.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("extract::smk::setup") +# context("extract::smk::setup") # # Tests # -context("extract::smk::simple") +# context("extract::smk::simple") test_that("simple extract no holder", { input <- "variable" @@ -45,7 +46,7 @@ test_that("simple extract", { expect_equal(res$elements, "variable") }) -context("extract::smk::simple vector") +# context("extract::smk::simple vector") test_that("simple extract no holder, vector", { input <- c("v1", "v2", "v3", "v4") @@ -107,6 +108,6 @@ test_that("simple extract, mixed, vector", { # Done # -context("extract::smk::shutdown") +# context("extract::smk::shutdown") -context("extract::smk::done") +# context("extract::smk::done") diff --git a/tests/testthat/test-smk-gamlssDS.R b/tests/testthat/test-smk-gamlssDS.R index 636e0f26..de284148 100644 --- a/tests/testthat/test-smk-gamlssDS.R +++ b/tests/testthat/test-smk-gamlssDS.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,7 +13,7 @@ # Set up # -context("gamlssDS::smk::setup") +# context("gamlssDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("gamlssDS::smk::birthweight") +# context("gamlssDS::smk::birthweight") test_that("birthweight gamlssDS", { D <- as.data.frame(matrix(NA, nrow=20, ncol=2)) @@ -88,6 +89,6 @@ test_that("birthweight gamlssDS", { # Done # -context("gamlssDS::smk::shutdown") +# context("gamlssDS::smk::shutdown") -context("gamlssDS::smk::done") +# context("gamlssDS::smk::done") diff --git a/tests/testthat/test-smk-getWGSRDS.R b/tests/testthat/test-smk-getWGSRDS.R index 0036fcdf..73d0eda1 100644 --- a/tests/testthat/test-smk-getWGSRDS.R +++ b/tests/testthat/test-smk-getWGSRDS.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("getWGSRDS::smk::setup") +# context("getWGSRDS::smk::setup") # # Tests # -context("getWGSRDS::smk::simple") +# context("getWGSRDS::smk::simple") data <- data.frame( age = c(6.0, 42.0, 23.0, 18.0, 52.0, 36.0, 30.0, NA, 29.0, 54.0), @@ -152,6 +153,6 @@ test_that("simple getWGSRDS - mfa", { # Done # -context("getWGSRDS::smk::shutdown") +# context("getWGSRDS::smk::shutdown") -context("getWGSRDS::smk::done") +# context("getWGSRDS::smk::done") diff --git a/tests/testthat/test-smk-hetcorDS.R b/tests/testthat/test-smk-hetcorDS.R index f78d14cc..fd5ca14e 100644 --- a/tests/testthat/test-smk-hetcorDS.R +++ b/tests/testthat/test-smk-hetcorDS.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,7 +13,7 @@ # Set up # -context("hetcorDS::smk::setup") +# context("hetcorDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +22,7 @@ set.standard.disclosure.settings() # Tests # -context("hetcorDS::smk") +# context("hetcorDS::smk") test_that("hetcorDS", { D <- as.data.frame(matrix(NA, nrow=20, ncol=3)) @@ -86,6 +87,6 @@ test_that("hetcorDS", { # Done # -context("hetcorDS::smk::shutdown") +# context("hetcorDS::smk::shutdown") -context("hetcorDS::smk::done") \ No newline at end of file +# context("hetcorDS::smk::done") diff --git a/tests/testthat/test-smk-igb_standardsDS.R b/tests/testthat/test-smk-igb_standardsDS.R index 114c88d9..bd3a8f79 100644 --- a/tests/testthat/test-smk-igb_standardsDS.R +++ b/tests/testthat/test-smk-igb_standardsDS.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("igb_standardsDS::smk::setup") +# context("igb_standardsDS::smk::setup") # # Tests # -context("igb_standardsDS::smk::simple") +# context("igb_standardsDS::smk::simple") data <- data.frame( gagebrth = c(287, 287, 287, 280, 280, 280, 280, 266, 266, 259, @@ -157,6 +158,6 @@ test_that("igb_standardsDS - igb_centile2value", { # Done # -context("igb_standardsDS::smk::shutdown") +# context("igb_standardsDS::smk::shutdown") -context("igb_standardsDS::smk::done") +# context("igb_standardsDS::smk::done") diff --git a/tests/testthat/test-smk-isNaDS.R b/tests/testthat/test-smk-isNaDS.R index e5922d27..766d513c 100644 --- a/tests/testthat/test-smk-isNaDS.R +++ b/tests/testthat/test-smk-isNaDS.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("isNaDS::smk::setup") +# context("isNaDS::smk::setup") # # Tests # -context("isNaDS::smk::numeric vector") +# context("isNaDS::smk::numeric vector") test_that("numeric vector isNaDS", { input <- c(0.1, 1.1, 2.1, 3.1, 4.1) @@ -49,7 +50,7 @@ test_that("numeric vector isNaDS - with NA all", { expect_equal(res, TRUE) }) -context("isNaDS::smk::character vector") +# context("isNaDS::smk::character vector") test_that("character vector isNaDS", { input <- c("101", "202", "303", "404", "505") @@ -84,6 +85,6 @@ test_that("character vector isNaDS - with NA all", { # Done # -context("isNaDS::smk::shutdown") +# context("isNaDS::smk::shutdown") -context("isNaDS::smk::done") +# context("isNaDS::smk::done") diff --git a/tests/testthat/test-smk-isValidDS.R b/tests/testthat/test-smk-isValidDS.R index c2d3af51..81fc5ade 100644 --- a/tests/testthat/test-smk-isValidDS.R +++ b/tests/testthat/test-smk-isValidDS.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("isValidDS::smk::setup") +# context("isValidDS::smk::setup") # # Tests # -context("isValidDS::smk::character") +# context("isValidDS::smk::character") test_that("simple isValidDS, character", { input <- "value" @@ -39,7 +40,7 @@ test_that("simple isValidDS, character vector", { expect_equal(res, TRUE) }) -context("isValidDS::smk::integer") +# context("isValidDS::smk::integer") test_that("simple isValidDS, integer", { input <- 1L @@ -60,7 +61,7 @@ test_that("simple isValidDS, integer vector", { expect_equal(res, TRUE) }) -context("isValidDS::smk::numeric") +# context("isValidDS::smk::numeric") test_that("simple isValidDS, numeric", { input <- 1.1 @@ -81,7 +82,7 @@ test_that("simple isValidDS, numeric vector", { expect_equal(res, TRUE) }) -context("isValidDS::smk::logical") +# context("isValidDS::smk::logical") test_that("simple isValidDS, logical, FALSE", { input <- FALSE @@ -142,7 +143,7 @@ test_that("simple isValidDS, factor vector", { expect_equal(res, FALSE) }) -context("isValidDS::smk::data.frame") +# context("isValidDS::smk::data.frame") test_that("simple isValidDS, data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -153,7 +154,7 @@ test_that("simple isValidDS, data.frame", { expect_equal(res, TRUE) }) -context("isValidDS::smk::array") +# context("isValidDS::smk::array") test_that("simple isValidDS, array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -164,7 +165,7 @@ test_that("simple isValidDS, array", { expect_equal(res, FALSE) }) -context("isValidDS::smk::matrix") +# context("isValidDS::smk::matrix") test_that("simple isValidDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -175,7 +176,7 @@ test_that("simple isValidDS, matrix", { expect_equal(res, TRUE) }) -context("isValidDS::smk::data.matrix") +# context("isValidDS::smk::data.matrix") test_that("simple isValidDS, data.matrix", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) @@ -186,7 +187,7 @@ test_that("simple isValidDS, data.matrix", { expect_equal(res, TRUE) }) -context("isValidDS::smk::date") +# context("isValidDS::smk::date") test_that("simple isValidDS, date", { input <- Sys.Date() @@ -197,7 +198,7 @@ test_that("simple isValidDS, date", { expect_equal(res, FALSE) }) -context("isValidDS::smk::formula") +# context("isValidDS::smk::formula") test_that("simple isValidDS, formula", { input <- X ~ A + B @@ -208,7 +209,7 @@ test_that("simple isValidDS, formula", { expect_equal(res, FALSE) }) -context("isValidDS::smk::environment") +# context("isValidDS::smk::environment") test_that("simple isValidDS, environment", { input <- environment() @@ -219,7 +220,7 @@ test_that("simple isValidDS, environment", { expect_equal(res, FALSE) }) -context("isValidDS::smk::NA") +# context("isValidDS::smk::NA") test_that("special isValidDS, NA", { input <- NA @@ -230,7 +231,7 @@ test_that("special isValidDS, NA", { expect_equal(res, FALSE) }) -context("isValidDS::smk::NULL") +# context("isValidDS::smk::NULL") test_that("special isValidDS, NULL", { input <- NULL @@ -245,6 +246,6 @@ test_that("special isValidDS, NULL", { # Done # -context("isValidDS::smk::shutdown") +# context("isValidDS::smk::shutdown") -context("isValidDS::smk::done") +# context("isValidDS::smk::done") diff --git a/tests/testthat/test-smk-kurtosisDS1.R b/tests/testthat/test-smk-kurtosisDS1.R index 62f10307..fe939107 100644 --- a/tests/testthat/test-smk-kurtosisDS1.R +++ b/tests/testthat/test-smk-kurtosisDS1.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,7 +13,7 @@ # Set up # -context("kurtosisDS1::smk::setup") +# context("kurtosisDS1::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("kurtosisDS1::smk::method 1") +# context("kurtosisDS1::smk::method 1") test_that("simple kurtosisDS1, method 1", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -36,7 +37,7 @@ test_that("simple kurtosisDS1, method 1", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("kurtosisDS1::smk::method 2") +# context("kurtosisDS1::smk::method 2") test_that("simple kurtosisDS1, method 2", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -52,7 +53,7 @@ test_that("simple kurtosisDS1, method 2", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("kurtosisDS1::smk::method 3") +# context("kurtosisDS1::smk::method 3") test_that("simple kurtosisDS1, method 3", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -72,6 +73,6 @@ test_that("simple kurtosisDS1, method 3", { # Done # -context("kurtosisDS1::smk::shutdown") +# context("kurtosisDS1::smk::shutdown") -context("kurtosisDS1::smk::done") +# context("kurtosisDS1::smk::done") diff --git a/tests/testthat/test-smk-kurtosisDS2.R b/tests/testthat/test-smk-kurtosisDS2.R index 24833388..8f122a6e 100644 --- a/tests/testthat/test-smk-kurtosisDS2.R +++ b/tests/testthat/test-smk-kurtosisDS2.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,7 +13,7 @@ # Set up # -context("kurtosisDS2::smk::setup") +# context("kurtosisDS2::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("kurtosisDS2::smk") +# context("kurtosisDS2::smk") test_that("simple kurtosisDS2", { input <- c(1.0, 2.0, 2.0, 3.0, 3.0) global.mean <- 2.5 @@ -43,6 +44,6 @@ test_that("simple kurtosisDS2", { # Done # -context("kurtosisDS2::smk::shutdown") +# context("kurtosisDS2::smk::shutdown") -context("kurtosisDS2::smk::done") +# context("kurtosisDS2::smk::done") diff --git a/tests/testthat/test-smk-lengthDS.R b/tests/testthat/test-smk-lengthDS.R index d7cd2bda..b5fad0e7 100644 --- a/tests/testthat/test-smk-lengthDS.R +++ b/tests/testthat/test-smk-lengthDS.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("lengthDS::smk::setup") +# context("lengthDS::smk::setup") # # Tests # -context("lengthDS::smk::data.frame") +# context("lengthDS::smk::data.frame") test_that("simple lengthDS, numeric data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -37,7 +38,7 @@ test_that("simple lengthDS, character data.frame", { expect_equal(res, 2) }) -context("lengthDS::smk::vector") +# context("lengthDS::smk::vector") test_that("simple lengthDS, numeric vector", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -60,6 +61,6 @@ test_that("simple lengthDS, character vector", { # Done # -context("lengthDS::smk::shutdown") +# context("lengthDS::smk::shutdown") -context("lengthDS::smk::done") +# context("lengthDS::smk::done") diff --git a/tests/testthat/test-smk-levelsDS.R b/tests/testthat/test-smk-levelsDS.R index e1b93daa..5ba10980 100644 --- a/tests/testthat/test-smk-levelsDS.R +++ b/tests/testthat/test-smk-levelsDS.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,7 +13,7 @@ # Set up # -context("levelsDS::smk::setup") +# context("levelsDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("levelsDS::smk::numeric vector") +# context("levelsDS::smk::numeric vector") test_that("numeric vector levelsDS", { input <- as.factor(c(0, 1, 2, 1, 2, 3, 1, 2, 1, 0, 1, 2, 0)) @@ -42,6 +43,6 @@ test_that("numeric vector levelsDS", { # Done # -context("levelsDS::smk::shutdown") +# context("levelsDS::smk::shutdown") -context("levelsDS::smk::done") +# context("levelsDS::smk::done") diff --git a/tests/testthat/test-smk-listDS.R b/tests/testthat/test-smk-listDS.R index f1e12e94..dfd0a171 100644 --- a/tests/testthat/test-smk-listDS.R +++ b/tests/testthat/test-smk-listDS.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("listDS::smk::setup") +# context("listDS::smk::setup") # # Tests # -context("listDS::smk::simple") +# context("listDS::smk::simple") test_that("simple listDS", { input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) eltnames <- c('n1', 'n2') @@ -42,6 +43,6 @@ test_that("simple listDS", { # Done # -context("listDS::smk::shutdown") +# context("listDS::smk::shutdown") -context("listDS::smk::done") +# context("listDS::smk::done") diff --git a/tests/testthat/test-smk-listDisclosureSettingsDS.R b/tests/testthat/test-smk-listDisclosureSettingsDS.R index 4ee63cf0..b680b3b3 100644 --- a/tests/testthat/test-smk-listDisclosureSettingsDS.R +++ b/tests/testthat/test-smk-listDisclosureSettingsDS.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,7 +13,7 @@ # Set up # -context("listDisclosureSettingsDS::smk::setup") +# context("listDisclosureSettingsDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("listDisclosureSettingsDS::smk") +# context("listDisclosureSettingsDS::smk") test_that("simple listDisclosureSettingsDS", { res <- listDisclosureSettingsDS() @@ -70,6 +71,6 @@ test_that("simple listDisclosureSettingsDS", { # Done # -context("listDisclosureSettingsDS::smk::shutdown") +# context("listDisclosureSettingsDS::smk::shutdown") -context("listDisclosureSettingsDS::smk::done") +# context("listDisclosureSettingsDS::smk::done") diff --git a/tests/testthat/test-smk-lsDS.R b/tests/testthat/test-smk-lsDS.R index 077ee9fe..b96eb0ec 100644 --- a/tests/testthat/test-smk-lsDS.R +++ b/tests/testthat/test-smk-lsDS.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,7 +13,7 @@ # Set up # -context("lsDS::smk::setup") +# context("lsDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("lsDS::smk::simple") +# context("lsDS::smk::simple") test_that("simple lsDS", { .GlobalEnv$test.obj <- "value" @@ -36,7 +37,7 @@ test_that("simple lsDS", { expect_true("test.obj" %in% res$objects.found) }) -context("lsDS::smk::simple") +# context("lsDS::smk::simple") test_that("simple lsDS", { .GlobalEnv$test.obj <- "value" @@ -58,6 +59,6 @@ test_that("simple lsDS", { # Done # -context("lsDS::smk::shutdown") +# context("lsDS::smk::shutdown") -context("lsDS::smk::done") +# context("lsDS::smk::done") diff --git a/tests/testthat/test-smk-meanDS.R b/tests/testthat/test-smk-meanDS.R index befc82ba..e6d81a73 100644 --- a/tests/testthat/test-smk-meanDS.R +++ b/tests/testthat/test-smk-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,7 +13,7 @@ # Set up # -context("meanDS::smk::setup") +# context("meanDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("meanDS::smk::numeric") +# context("meanDS::smk::numeric") test_that("numeric meanDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -40,7 +41,7 @@ test_that("numeric meanDS", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("meanDS::smk::numeric with NA") +# context("meanDS::smk::numeric with NA") test_that("numeric meanDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) @@ -60,7 +61,7 @@ test_that("numeric meanDS, with NA", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("meanDS::smk::numeric with all NA") +# context("meanDS::smk::numeric with all NA") test_that("numeric meanDS, with all NA", { input <- c(NA, NA, NA, NA, NA) @@ -84,6 +85,6 @@ test_that("numeric meanDS, with all NA", { # Done # -context("meanDS::smk::shutdown") +# context("meanDS::smk::shutdown") -context("meanDS::smk::done") +# context("meanDS::smk::done") diff --git a/tests/testthat/test-smk-messageDS.R b/tests/testthat/test-smk-messageDS.R index 871d2747..b92655e8 100644 --- a/tests/testthat/test-smk-messageDS.R +++ b/tests/testthat/test-smk-messageDS.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,7 +13,7 @@ # Set up # -context("messageDS::smk::setup") +# context("messageDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("messageDS::smk") +# context("messageDS::smk") test_that("simple messageDS", { expect_warning(base::rm("object"), "object 'object' not found", fixed = TRUE) @@ -86,6 +87,6 @@ test_that("simple messageDS", { # Done # -context("messageDS::smk::shutdown") +# context("messageDS::smk::shutdown") -context("messageDS::smk::done") +# context("messageDS::smk::done") diff --git a/tests/testthat/test-smk-metadataDS.R b/tests/testthat/test-smk-metadataDS.R index 1c4a3dab..4b0ab042 100644 --- a/tests/testthat/test-smk-metadataDS.R +++ b/tests/testthat/test-smk-metadataDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, 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,7 +12,7 @@ # Set up # -context("metadataDS::smk::setup") +# context("metadataDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("metadataDS::smk::list") +# context("metadataDS::smk::list") test_that("simple metadataDS, list of values", { input <- list(v1 = 0.0, v2 = 1.0) @@ -36,7 +36,7 @@ test_that("simple metadataDS, list of values", { expect_true("v2" %in% res$names) }) -context("metadataDS::smk::list field") +# context("metadataDS::smk::list field") test_that("simple metadataDS, list of vectors", { input <- list(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -50,6 +50,6 @@ test_that("simple metadataDS, list of vectors", { # Done # -context("metadataDS::smk::shutdown") +# context("metadataDS::smk::shutdown") -context("metadataDS::smk::done") +# context("metadataDS::smk::done") diff --git a/tests/testthat/test-smk-miceDS.R b/tests/testthat/test-smk-miceDS.R index 3c5af832..4f49f52b 100644 --- a/tests/testthat/test-smk-miceDS.R +++ b/tests/testthat/test-smk-miceDS.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("miceDS::smk::setup") +# context("miceDS::smk::setup") # # Tests # -context("miceDS::smk") +# context("miceDS::smk") test_that("miceDS", { load(file = 'data_files/CNSIM/CNSIM1.rda') @@ -53,6 +54,6 @@ test_that("miceDS", { # Done # -context("miceDS::smk::shutdown") +# context("miceDS::smk::shutdown") -context("miceDS::smk::done") +# context("miceDS::smk::done") diff --git a/tests/testthat/test-smk-minMaxRandDS.R b/tests/testthat/test-smk-minMaxRandDS.R index e5a9fe77..0e057e5a 100644 --- a/tests/testthat/test-smk-minMaxRandDS.R +++ b/tests/testthat/test-smk-minMaxRandDS.R @@ -1,5 +1,5 @@ #------------------------------------------------------------------------------- -# Copyright (c) 2024 Arjuna Technologies, 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,7 +12,7 @@ # Set up # -context("minMaxRandDS::smk::setup") +# context("minMaxRandDS::smk::setup") # # Tests @@ -33,6 +33,6 @@ test_that("minMaxRandDS", { # Done # -context("minMaxRandDS::smk::shutdown") +# context("minMaxRandDS::smk::shutdown") -context("minMaxRandDS::smk::done") +# context("minMaxRandDS::smk::done") diff --git a/tests/testthat/test-smk-namesDS.R b/tests/testthat/test-smk-namesDS.R index 238c26d3..dbc5f3b1 100644 --- a/tests/testthat/test-smk-namesDS.R +++ b/tests/testthat/test-smk-namesDS.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,7 +13,7 @@ # Set up # -context("namesDS::smk::setup") +# context("namesDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("namesDS::smk::list of atoms") +# context("namesDS::smk::list of atoms") test_that("simple namesDS, data.frame", { input <- list(v1 = 0.0, v2 = 1.0) @@ -32,7 +33,7 @@ test_that("simple namesDS, data.frame", { expect_true("v2" %in% res) }) -context("namesDS::smk::list of vectors") +# context("namesDS::smk::list of vectors") test_that("simple namesDS, data.matrix", { input <- list(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -48,6 +49,6 @@ test_that("simple namesDS, data.matrix", { # Done # -context("namesDS::smk::shutdown") +# context("namesDS::smk::shutdown") -context("namesDS::smk::done") +# context("namesDS::smk::done") diff --git a/tests/testthat/test-smk-numNaDS.R b/tests/testthat/test-smk-numNaDS.R index 5de3dc46..c77db4ed 100644 --- a/tests/testthat/test-smk-numNaDS.R +++ b/tests/testthat/test-smk-numNaDS.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("numNaDS::smk::setup") +# context("numNaDS::smk::setup") # # Tests # -context("numNaDS::smk::simple") +# context("numNaDS::smk::simple") test_that("simple numNaDS", { input <- c(NA, 1, NA, 2, NA) @@ -43,6 +44,6 @@ test_that("simple numNaDS", { # Done # -context("numNaDS::smk::shutdown") +# context("numNaDS::smk::shutdown") -context("numNaDS::smk::done") +# context("numNaDS::smk::done") diff --git a/tests/testthat/test-smk-quantileMeanDS.R b/tests/testthat/test-smk-quantileMeanDS.R index 7ca9ac18..33eb0c6f 100644 --- a/tests/testthat/test-smk-quantileMeanDS.R +++ b/tests/testthat/test-smk-quantileMeanDS.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("quantileMeanDS::smk::setup") +# context("quantileMeanDS::smk::setup") # # Tests # -context("quantileMeanDS::smk") +# context("quantileMeanDS::smk") test_that("numeric quantileMeanDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -49,7 +50,7 @@ test_that("numeric quantileMeanDS", { expect_equal(res.names[[8]], "Mean") }) -context("quantileMeanDS::smk::with NA") +# context("quantileMeanDS::smk::with NA") test_that("numeric quantileMeanDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) @@ -84,6 +85,6 @@ test_that("numeric quantileMeanDS, with NA", { # Done # -context("quantileMeanDS::smk::shutdown") +# context("quantileMeanDS::smk::shutdown") -context("quantileMeanDS::smk::done") +# context("quantileMeanDS::smk::done") diff --git a/tests/testthat/test-smk-rBinomDS.R b/tests/testthat/test-smk-rBinomDS.R index d52ff3e7..9cff07d0 100644 --- a/tests/testthat/test-smk-rBinomDS.R +++ b/tests/testthat/test-smk-rBinomDS.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("rBinomDS::smk::setup") +# context("rBinomDS::smk::setup") # # Tests # -context("rBinomDS::smk::simple") +# context("rBinomDS::smk::simple") test_that("simple rBinomDS, by name", { n <- 8 size <- 32 @@ -61,6 +62,6 @@ test_that("simple rBinomDS, direct", { # Done # -context("rBinomDS::smk::shutdown") +# context("rBinomDS::smk::shutdown") -context("rBinomDS::smk::done") +# context("rBinomDS::smk::done") diff --git a/tests/testthat/test-smk-rNormDS.R b/tests/testthat/test-smk-rNormDS.R index c5b62afc..484ef851 100644 --- a/tests/testthat/test-smk-rNormDS.R +++ b/tests/testthat/test-smk-rNormDS.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("rNormDS::smk::setup") +# context("rNormDS::smk::setup") # # Tests # -context("rNormDS::smk::simple") +# context("rNormDS::smk::simple") test_that("simple rNormDS, by name", { n <- 8 mean <- 32.0 @@ -61,6 +62,6 @@ test_that("simple rNormDS, direct", { # Done # -context("rNormDS::smk::shutdown") +# context("rNormDS::smk::shutdown") -context("rNormDS::smk::done") +# context("rNormDS::smk::done") diff --git a/tests/testthat/test-smk-rPoisDS.R b/tests/testthat/test-smk-rPoisDS.R index a5d5c1fd..c2cf55bf 100644 --- a/tests/testthat/test-smk-rPoisDS.R +++ b/tests/testthat/test-smk-rPoisDS.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("rPoisDS::smk::setup") +# context("rPoisDS::smk::setup") # # Tests # -context("rPoisDS::smk::simple") +# context("rPoisDS::smk::simple") test_that("simple rPoisDS, by name", { n <- 8 lambda <- 32 @@ -59,6 +60,6 @@ test_that("simple rPoisDS, direct", { # Done # -context("rPoisDS::smk::shutdown") +# context("rPoisDS::smk::shutdown") -context("rPoisDS::smk::done") +# context("rPoisDS::smk::done") diff --git a/tests/testthat/test-smk-rUnifDS.R b/tests/testthat/test-smk-rUnifDS.R index a0e8d306..87c208c4 100644 --- a/tests/testthat/test-smk-rUnifDS.R +++ b/tests/testthat/test-smk-rUnifDS.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("rUnifDS::smk::setup") +# context("rUnifDS::smk::setup") # # Tests # -context("rUnifDS::smk::simple") +# context("rUnifDS::smk::simple") test_that("simple rUnifDS, by name", { n <- 8 min <- 2 @@ -61,6 +62,6 @@ test_that("simple rUnifDS, direct", { # Done # -context("rUnifDS::smk::shutdown") +# context("rUnifDS::smk::shutdown") -context("rUnifDS::smk::done") +# context("rUnifDS::smk::done") diff --git a/tests/testthat/test-smk-rangeDS.R b/tests/testthat/test-smk-rangeDS.R index ef04d6b1..c59c9d32 100644 --- a/tests/testthat/test-smk-rangeDS.R +++ b/tests/testthat/test-smk-rangeDS.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,7 +13,7 @@ # Set up # -context("rangeDS::smk::setup") +# context("rangeDS::smk::setup") set.random.seed.setting(1234) @@ -20,7 +21,7 @@ set.random.seed.setting(1234) # Tests # -context("rangeDS::smk::without NAs") +# context("rangeDS::smk::without NAs") test_that("numeric rangeDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0, 4.0, 3.0, 2.0, 1.0, 0.0) @@ -32,7 +33,7 @@ test_that("numeric rangeDS", { expect_equal(res[2], 4.12446, tolerance = 1e-6) }) -context("rangeDS::smk::with NAs") +# context("rangeDS::smk::with NAs") test_that("character rangeDS", { input <- c(0.0, NA, 2.0, NA, 4.0, NA, 3.0, NA, 1.0, NA) @@ -48,6 +49,6 @@ test_that("character rangeDS", { # Done # -context("rangeDS::smk::shutdown") +# context("rangeDS::smk::shutdown") -context("rangeDS::smk::done") +# context("rangeDS::smk::done") diff --git a/tests/testthat/test-smk-rbindDS.R b/tests/testthat/test-smk-rbindDS.R index 846b31bc..7f757a1e 100644 --- a/tests/testthat/test-smk-rbindDS.R +++ b/tests/testthat/test-smk-rbindDS.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("rbindDS::smk::setup") +# context("rbindDS::smk::setup") # # Tests # -context("rbindDS::smk::simple") +# context("rbindDS::smk::simple") test_that("simple rbindDS", { inputs <- 'input1, input2' input1 <- c(0.0, 1.0, 2.0, 3.0) @@ -61,6 +62,6 @@ test_that("simple rbindDS", { # Done # -context("rbindDS::smk::shutdown") +# context("rbindDS::smk::shutdown") -context("rbindDS::smk::done") +# context("rbindDS::smk::done") diff --git a/tests/testthat/test-smk-recodeLevelsDS.R b/tests/testthat/test-smk-recodeLevelsDS.R index 2eaef21b..9e365836 100644 --- a/tests/testthat/test-smk-recodeLevelsDS.R +++ b/tests/testthat/test-smk-recodeLevelsDS.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,7 +13,7 @@ # Set up # -context("recodeLevelsDS::smk::setup") +# context("recodeLevelsDS::smk::setup") # # Tests @@ -41,6 +42,6 @@ test_that("simple recodeLevelsDS", { # Done # -context("recodeLevelsDS::smk::shutdown") +# context("recodeLevelsDS::smk::shutdown") -context("recodeLevelsDS::smk::done") +# context("recodeLevelsDS::smk::done") diff --git a/tests/testthat/test-smk-recodeValuesDS.R b/tests/testthat/test-smk-recodeValuesDS.R index 14e7cb98..09b9e2f3 100644 --- a/tests/testthat/test-smk-recodeValuesDS.R +++ b/tests/testthat/test-smk-recodeValuesDS.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,7 +13,7 @@ # Set up # -context("recodeValuesDS::smk::setup") +# context("recodeValuesDS::smk::setup") set.standard.disclosure.settings() @@ -126,6 +127,6 @@ test_that("simple recodeValuesDS, character input with missings", { # Done # -context("recodeValuesDS::smk::shutdown") +# context("recodeValuesDS::smk::shutdown") -context("recodeValuesDS::smk::done") +# context("recodeValuesDS::smk::done") diff --git a/tests/testthat/test-smk-replaceNaDS.R b/tests/testthat/test-smk-replaceNaDS.R index f092b9cd..b2b4cfff 100644 --- a/tests/testthat/test-smk-replaceNaDS.R +++ b/tests/testthat/test-smk-replaceNaDS.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,7 +13,7 @@ # Set up # -context("replaceNaDS::smk::setup") +# context("replaceNaDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("replaceNaDS::smk") +# context("replaceNaDS::smk") test_that("simple replaceNaDS", { input <- c(0.0, NA, 2.0, NA, 4.0, NA, 6.0, NA) replacements <- c(1.1, 3.3, 5.5, 7.7) @@ -43,6 +44,6 @@ test_that("simple replaceNaDS", { # Done # -context("replaceNaDS::smk::shutdown") +# context("replaceNaDS::smk::shutdown") -context("replaceNaDS::smk::done") +# context("replaceNaDS::smk::done") diff --git a/tests/testthat/test-smk-rmDS.R b/tests/testthat/test-smk-rmDS.R index 7bab6da2..aae9c5f1 100644 --- a/tests/testthat/test-smk-rmDS.R +++ b/tests/testthat/test-smk-rmDS.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,7 +13,7 @@ # Set up # -context("rmDS::smk::setup") +# context("rmDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("rmDS::smk::single") +# context("rmDS::smk::single") test_that("single rmDS", { expect_false(exists("input")) @@ -40,7 +41,7 @@ test_that("single rmDS", { expect_equal(res$problem.objects, "", fixed = TRUE) }) -context("rmDS::smk::multiple") +# context("rmDS::smk::multiple") test_that("multiple rmDS", { expect_false(exists("input1")) expect_false(exists("input2")) @@ -65,7 +66,7 @@ test_that("multiple rmDS", { expect_equal(res$problem.objects, "", fixed = TRUE) }) -context("rmDS::smk::single missing") +# context("rmDS::smk::single missing") test_that("single missing rmDS", { expect_false(exists("input")) @@ -82,7 +83,7 @@ test_that("single missing rmDS", { }) -context("rmDS::smk::multiple missing") +# context("rmDS::smk::multiple missing") test_that("multiple missing rmDS", { expect_false(exists("input1")) expect_false(exists("input2")) @@ -100,7 +101,7 @@ test_that("multiple missing rmDS", { expect_equal(res$problem.objects, "", fixed = TRUE) }) -context("rmDS::smk::multiple mixed") +# context("rmDS::smk::multiple mixed") test_that("multiple mixed rmDS", { expect_false(exists("input1")) expect_false(exists("input2")) @@ -124,6 +125,6 @@ test_that("multiple mixed rmDS", { # Done # -context("rmDS::smk::shutdown") +# context("rmDS::smk::shutdown") -context("rmDS::smk::done") +# context("rmDS::smk::done") diff --git a/tests/testthat/test-smk-rowColCalcDS.R b/tests/testthat/test-smk-rowColCalcDS.R index c951a73b..615aa2ff 100644 --- a/tests/testthat/test-smk-rowColCalcDS.R +++ b/tests/testthat/test-smk-rowColCalcDS.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,7 +13,7 @@ # Set up # -context("rowColCalcDS::smk::setup") +# context("rowColCalcDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("rowColCalcDS::smk") +# context("rowColCalcDS::smk") test_that("simple rowColCalcDS, operation 1", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0), ncol = 2) @@ -77,6 +78,6 @@ test_that("simple rowColCalcDS, operation 4", { # Done # -context("rowColCalcDS::smk::shutdown") +# context("rowColCalcDS::smk::shutdown") -context("rowColCalcDS::smk::done") +# context("rowColCalcDS::smk::done") diff --git a/tests/testthat/test-smk-sampleDS.R b/tests/testthat/test-smk-sampleDS.R index b30f86e6..e3927518 100644 --- a/tests/testthat/test-smk-sampleDS.R +++ b/tests/testthat/test-smk-sampleDS.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,7 +13,7 @@ # Set up # -context("sampleDS::smk::setup") +# context("sampleDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("sampleDS::smk::simple") +# context("sampleDS::smk::simple") test_that("simple sampleDS", { x <- c(1:32) size <- 16 @@ -49,6 +50,6 @@ test_that("simple sampleDS", { # Done # -context("sampleDS::smk::shutdown") +# context("sampleDS::smk::shutdown") -context("sampleDS::smk::done") +# context("sampleDS::smk::done") diff --git a/tests/testthat/test-smk-seqDS.R b/tests/testthat/test-smk-seqDS.R index b0660b58..7cdd62eb 100644 --- a/tests/testthat/test-smk-seqDS.R +++ b/tests/testthat/test-smk-seqDS.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,7 +13,7 @@ # Set up # -context("seqDS::smk::setup") +# context("seqDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("seqDS::smk") +# context("seqDS::smk") test_that("simple seqDS", { FROM.value.char <- "1" TO.value.char <- "12" @@ -121,6 +122,6 @@ test_that("simple seqDS", { # Done # -context("seqDS::smk::shutdown") +# context("seqDS::smk::shutdown") -context("seqDS::smk::done") +# context("seqDS::smk::done") diff --git a/tests/testthat/test-smk-setFilterDS.R b/tests/testthat/test-smk-setFilterDS.R index 2b32a6f9..93e54b7e 100644 --- a/tests/testthat/test-smk-setFilterDS.R +++ b/tests/testthat/test-smk-setFilterDS.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,7 +13,7 @@ # Set up # -context("setFilterDS::smk::setup") +# context("setFilterDS::smk::setup") set.standard.disclosure.settings @@ -20,7 +21,7 @@ set.standard.disclosure.settings # Tests # -context("setFilterDS::smk::simple") +# context("setFilterDS::smk::simple") test_that("simple setFilterDS", { res <- setFilterDS() @@ -43,6 +44,6 @@ test_that("simple setFilterDS", { # Done # -context("setFilterDS::smk::shutdown") +# context("setFilterDS::smk::shutdown") -context("setFilterDS::smk::done") +# context("setFilterDS::smk::done") diff --git a/tests/testthat/test-smk-setSeedDS.R b/tests/testthat/test-smk-setSeedDS.R index 6db3d8bc..0cdbf2e9 100644 --- a/tests/testthat/test-smk-setSeedDS.R +++ b/tests/testthat/test-smk-setSeedDS.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("setSeedDS::smk::setup") +# context("setSeedDS::smk::setup") # # Tests # -context("setSeedDS::smk::simple") +# context("setSeedDS::smk::simple") test_that("simple setSeedDS", { seedtext <- "19" kind <- NULL @@ -35,6 +36,6 @@ test_that("simple setSeedDS", { # Done # -context("setSeedDS::smk::shutdown") +# context("setSeedDS::smk::shutdown") -context("setSeedDS::smk::done") +# context("setSeedDS::smk::done") diff --git a/tests/testthat/test-smk-skewnessDS1.R b/tests/testthat/test-smk-skewnessDS1.R index 76f8d4fd..bfd0cceb 100644 --- a/tests/testthat/test-smk-skewnessDS1.R +++ b/tests/testthat/test-smk-skewnessDS1.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,7 +13,7 @@ # Set up # -context("skewnessDS1::smk::setup") +# context("skewnessDS1::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("skewnessDS1::smk::method 1") +# context("skewnessDS1::smk::method 1") test_that("simple skewnessDS1, method 1", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -36,7 +37,7 @@ test_that("simple skewnessDS1, method 1", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("skewnessDS1::smk::method 2") +# context("skewnessDS1::smk::method 2") test_that("simple skewnessDS1, method 2", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -52,7 +53,7 @@ test_that("simple skewnessDS1, method 2", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("skewnessDS1::smk::method 3") +# context("skewnessDS1::smk::method 3") test_that("simple skewnessDS1, method 3", { input <- c(0.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 3.0, 4.0) @@ -72,6 +73,6 @@ test_that("simple skewnessDS1, method 3", { # Done # -context("skewnessDS1::smk::shutdown") +# context("skewnessDS1::smk::shutdown") -context("skewnessDS1::smk::done") +# context("skewnessDS1::smk::done") diff --git a/tests/testthat/test-smk-skewnessDS2.R b/tests/testthat/test-smk-skewnessDS2.R index 1966109d..9e59061d 100644 --- a/tests/testthat/test-smk-skewnessDS2.R +++ b/tests/testthat/test-smk-skewnessDS2.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,7 +13,7 @@ # Set up # -context("skewnessDS2::smk::setup") +# context("skewnessDS2::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("skewnessDS2::smk") +# context("skewnessDS2::smk") test_that("simple skewnessDS2", { input <- c(1.0, 2.0, 2.0, 3.0, 3.0) global.mean <- 2.5 @@ -43,6 +44,6 @@ test_that("simple skewnessDS2", { # Done # -context("skewnessDS2::smk::shutdown") +# context("skewnessDS2::smk::shutdown") -context("skewnessDS2::smk::done") +# context("skewnessDS2::smk::done") diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index 2689d375..fe9ac9eb 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.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("sqrtDS::smk::setup") +# context("sqrtDS::smk::setup") # # Tests # -context("sqrtDS::smk::special") +# context("sqrtDS::smk::special") test_that("simple sqrtDS, NA", { input <- NA @@ -59,7 +60,7 @@ test_that("simple sqrtDS, -Inf", { expect_true(is.nan(res)) }) -context("sqrtDS::smk::numeric") +# context("sqrtDS::smk::numeric") test_that("simple sqrtDS, numeric 0.0", { input <- 0.0 @@ -90,7 +91,7 @@ test_that("simple sqrtDS, numeric -10.0", { expect_true(is.nan(res)) }) -context("sqrtDS::smk::integer") +# context("sqrtDS::smk::integer") test_that("simple sqrtDS, integer 0L", { input <- 0L @@ -121,7 +122,7 @@ test_that("simple sqrtDS, integer -10L", { expect_true(is.nan(res)) }) -context("sqrtDS::smk::special vector") +# context("sqrtDS::smk::special vector") test_that("simple sqrtDS", { input <- c(NA, NaN, Inf, -Inf) @@ -134,7 +135,7 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[4])) }) -context("sqrtDS::smk::numeric vector") +# context("sqrtDS::smk::numeric vector") test_that("simple sqrtDS", { input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) @@ -150,7 +151,7 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[6])) }) -context("sqrtDS::smk::integer vector") +# context("sqrtDS::smk::integer vector") test_that("simple sqrtDS", { input <- c(0L, 4L, 9L, -10L, -50L, -20L) @@ -170,6 +171,6 @@ test_that("simple sqrtDS", { # Done # -context("sqrtDS::smk::shutdown") +# context("sqrtDS::smk::shutdown") -context("sqrtDS::smk::done") +# context("sqrtDS::smk::done") diff --git a/tests/testthat/test-smk-subsetByClassDS.R b/tests/testthat/test-smk-subsetByClassDS.R index 8de5114b..82ccab5d 100644 --- a/tests/testthat/test-smk-subsetByClassDS.R +++ b/tests/testthat/test-smk-subsetByClassDS.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,7 +13,7 @@ # Set up # -context("subsetByClassDS::smk::setup") +# context("subsetByClassDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("subsetByClassDS::smk") +# context("subsetByClassDS::smk") test_that("simple subsetByClassDS, data.frame, unspecified variables", { data <- data.frame(v1 = factor(c(0, 0, 0, 1, 1, 1, 2, 1, 2, 2)), v2 = c(4.0, 0.0, 3.0, 1.0, 2.0, 2.0, 1.0, 3.0, 0.0, 4.0), v3 = c(1:10), v4 = c(1:10)) variables <- NULL @@ -82,6 +83,6 @@ test_that("simple subsetByClassDS, factor vector, specified variables", { # Done # -context("subsetByClassDS::smk::shutdown") +# context("subsetByClassDS::smk::shutdown") -context("subsetByClassDS::smk::done") +# context("subsetByClassDS::smk::done") diff --git a/tests/testthat/test-smk-subsetDS.R b/tests/testthat/test-smk-subsetDS.R index f34119c4..53d291c4 100644 --- a/tests/testthat/test-smk-subsetDS.R +++ b/tests/testthat/test-smk-subsetDS.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,7 +13,7 @@ # Set up # -context("subsetDS::smk::setup") +# context("subsetDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("subsetDS::smk") +# context("subsetDS::smk") test_that("simple subsetDS, no NAs", { data <- data.frame(v1 = c(0, 0, 1, 1, 2, 2, 3, 3, 4, 4), v2 = c(4.0, 0.0, 3.0, 1.0, 2.0, 2.0, 1.0, 3.0, 0.0, 4.0)) complt <- FALSE @@ -120,6 +121,6 @@ test_that("simple subsetDS, NAs, complete.case TRUE", { # Done # -context("subsetDS::smk::shutdown") +# context("subsetDS::smk::shutdown") -context("subsetDS::smk::done") +# context("subsetDS::smk::done") diff --git a/tests/testthat/test-smk-tapplyDS.R b/tests/testthat/test-smk-tapplyDS.R index 5824713d..7925b49a 100644 --- a/tests/testthat/test-smk-tapplyDS.R +++ b/tests/testthat/test-smk-tapplyDS.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,7 +13,7 @@ # Set up # -context("tapplyDS::smk::setup") +# context("tapplyDS::smk::setup") set.standard.disclosure.settings() @@ -161,6 +162,6 @@ test_that("simple tapplyDS, quantile", { # Done # -context("tapplyDS::smk::shutdown") +# context("tapplyDS::smk::shutdown") -context("tapplyDS::smk::done") +# context("tapplyDS::smk::done") diff --git a/tests/testthat/test-smk-tapplyDS.assign.R b/tests/testthat/test-smk-tapplyDS.assign.R index 90c57654..7d899a2e 100644 --- a/tests/testthat/test-smk-tapplyDS.assign.R +++ b/tests/testthat/test-smk-tapplyDS.assign.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,7 +13,7 @@ # Set up # -context("tapplyDS.assign::smk::setup") +# context("tapplyDS.assign::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("tapplyDS.assign::smk::simple") +# context("tapplyDS.assign::smk::simple") test_that("simple tapplyDS.assign", { x <- c(1, 2, 1, 2, 1, 2, 1, 2) index <- factor(c(1, 2, 1, 2, 1, 2, 1, 2)) @@ -54,6 +55,6 @@ test_that("simple tapplyDS.assign", { # Done # -context("tapplyDS.assign::smk::shutdown") +# context("tapplyDS.assign::smk::shutdown") -context("tapplyDS.assign::smk::done") +# context("tapplyDS.assign::smk::done") diff --git a/tests/testthat/test-smk-testObjExistsDS.R b/tests/testthat/test-smk-testObjExistsDS.R index 6dd2780d..705948d0 100644 --- a/tests/testthat/test-smk-testObjExistsDS.R +++ b/tests/testthat/test-smk-testObjExistsDS.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("testObjExistsDS::smk::setup") +# context("testObjExistsDS::smk::setup") # # Tests # -context("testObjExistsDS::smk::character") +# context("testObjExistsDS::smk::character") test_that("simple testObjExistsDS, character", { input <- "value" @@ -41,7 +42,7 @@ test_that("simple testObjExistsDS, character vector", { expect_equal(res$test.obj.class, "character") }) -context("testObjExistsDS::smk::integer") +# context("testObjExistsDS::smk::integer") test_that("simple testObjExistsDS, integer", { input <- 1L @@ -64,7 +65,7 @@ test_that("simple testObjExistsDS, integer vector", { expect_equal(res$test.obj.class, "integer") }) -context("testObjExistsDS::smk::numeric") +# context("testObjExistsDS::smk::numeric") test_that("simple testObjExistsDS, numeric", { input <- 1.1 @@ -87,7 +88,7 @@ test_that("simple testObjExistsDS, numeric vector", { expect_equal(res$test.obj.class, "numeric") }) -context("testObjExistsDS::smk::logical") +# context("testObjExistsDS::smk::logical") test_that("simple testObjExistsDS, logical, FALSE", { input <- FALSE @@ -121,7 +122,7 @@ test_that("simple testObjExistsDS, logical vector", { expect_equal(res$test.obj.class, "logical") }) -context("testObjExistsDS::smk::data.frame") +# context("testObjExistsDS::smk::data.frame") test_that("simple testObjExistsDS, data.frame", { input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) @@ -133,7 +134,7 @@ test_that("simple testObjExistsDS, data.frame", { expect_equal(res$test.obj.class, "data.frame") }) -context("testObjExistsDS::smk::array") +# context("testObjExistsDS::smk::array") test_that("simple testObjExistsDS, array", { input <- array(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -145,7 +146,7 @@ test_that("simple testObjExistsDS, array", { expect_equal(res$test.obj.class, "array") }) -context("testObjExistsDS::smk::matrix") +# context("testObjExistsDS::smk::matrix") test_that("simple testObjExistsDS, matrix", { input <- matrix(c(0.0, 1.0, 2.0, 3.0, 4.0)) @@ -167,7 +168,7 @@ test_that("simple testObjExistsDS, matrix", { } }) -context("testObjExistsDS::smk::data.matrix") +# context("testObjExistsDS::smk::data.matrix") test_that("simple testObjExistsDS, data.matrix", { input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) @@ -190,7 +191,7 @@ test_that("simple testObjExistsDS, data.matrix", { } }) -context("testObjExistsDS::smk::date") +# context("testObjExistsDS::smk::date") test_that("simple testObjExistsDS, date", { input <- Sys.Date() @@ -202,7 +203,7 @@ test_that("simple testObjExistsDS, date", { expect_equal(res$test.obj.class, "Date") }) -context("testObjExistsDS::smk::formula") +# context("testObjExistsDS::smk::formula") test_that("simple testObjExistsDS, formula", { input <- X ~ A + B @@ -214,7 +215,7 @@ test_that("simple testObjExistsDS, formula", { expect_equal(res$test.obj.class, "formula") }) -context("testObjExistsDS::smk::environment") +# context("testObjExistsDS::smk::environment") test_that("simple testObjExistsDS, environment", { input <- environment() @@ -226,7 +227,7 @@ test_that("simple testObjExistsDS, environment", { expect_equal(res$test.obj.class, "environment") }) -context("testObjExistsDS::smk::NA") +# context("testObjExistsDS::smk::NA") test_that("special testObjExistsDS, NA", { input <- NA @@ -238,7 +239,7 @@ test_that("special testObjExistsDS, NA", { expect_equal(res$test.obj.class, "logical") }) -context("testObjExistsDS::smk::NULL") +# context("testObjExistsDS::smk::NULL") test_that("special testObjExistsDS, NULL", { input <- NULL @@ -250,7 +251,7 @@ test_that("special testObjExistsDS, NULL", { expect_equal(res$test.obj.class, "NULL") }) -context("testObjExistsDS::smk::not exists") +# context("testObjExistsDS::smk::not exists") test_that("special testObjExistsDS, not exists", { res <- testObjExistsDS("XXXinputXXX") @@ -264,6 +265,6 @@ test_that("special testObjExistsDS, not exists", { # Done # -context("testObjExistsDS::smk::shutdown") +# context("testObjExistsDS::smk::shutdown") -context("testObjExistsDS::smk::done") +# context("testObjExistsDS::smk::done") diff --git a/tests/testthat/test-smk-unListDS.R b/tests/testthat/test-smk-unListDS.R index 316806d3..b8f814fe 100644 --- a/tests/testthat/test-smk-unListDS.R +++ b/tests/testthat/test-smk-unListDS.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("unListDS::smk::setup") +# context("unListDS::smk::setup") # # Tests # -context("unListDS::smk::simple") +# context("unListDS::smk::simple") test_that("simple unListDS", { input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) @@ -49,6 +50,6 @@ test_that("simple unListDS", { # Done # -context("unListDS::smk::shutdown") +# context("unListDS::smk::shutdown") -context("unListDS::smk::done") +# context("unListDS::smk::done") diff --git a/tests/testthat/test-smk-uniqueDS.R b/tests/testthat/test-smk-uniqueDS.R index 2bad97cf..3f4b908c 100644 --- a/tests/testthat/test-smk-uniqueDS.R +++ b/tests/testthat/test-smk-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,13 +13,13 @@ # Set up # -context("uniqueDS::smk::setup") +# context("uniqueDS::smk::setup") # # Tests # -context("uniqueDS::smk::simple for vector") +# context("uniqueDS::smk::simple for vector") test_that("simple uniqueDS for vector", { input <- c(1, 2, 3, 2, 3, 6) @@ -32,7 +33,7 @@ test_that("simple uniqueDS for vector", { expect_equal(res[[4]], 6) }) -context("uniqueDS::smk::simple for vector") +# context("uniqueDS::smk::simple for vector") test_that("simple uniqueDS for list", { input <- list(a=1, b=2, c=3, d=2, e=3, f=6) @@ -52,6 +53,6 @@ test_that("simple uniqueDS for list", { # Done # -context("uniqueDS::smk::shutdown") +# context("uniqueDS::smk::shutdown") -context("uniqueDS::smk::done") +# context("uniqueDS::smk::done") diff --git a/tests/testthat/test-smk-varDS.R b/tests/testthat/test-smk-varDS.R index 34ba8670..517b8d8f 100644 --- a/tests/testthat/test-smk-varDS.R +++ b/tests/testthat/test-smk-varDS.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,7 +13,7 @@ # Set up # -context("varDS::smk::setup") +# context("varDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +21,7 @@ set.standard.disclosure.settings() # Tests # -context("varDS::smk::numeric") +# context("varDS::smk::numeric") test_that("numeric varDS", { input <- c(0.0, 1.0, 2.0, 3.0, 4.0) @@ -42,7 +43,7 @@ test_that("numeric varDS", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("varDS::smk::numeric with NA") +# context("varDS::smk::numeric with NA") test_that("numeric varDS, with NA", { input <- c(0.0, NA, 2.0, NA, 4.0) @@ -64,7 +65,7 @@ test_that("numeric varDS, with NA", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) -context("varDS::smk::numeric with all NA") +# context("varDS::smk::numeric with all NA") test_that("numeric varDS, with all NA", { input <- c(NA, NA, NA, NA, NA) @@ -90,6 +91,6 @@ test_that("numeric varDS, with all NA", { # Done # -context("varDS::smk::shutdown") +# context("varDS::smk::shutdown") -context("varDS::smk::done") +# context("varDS::smk::done") diff --git a/tests/testthat/test-smk-vectorDS.R b/tests/testthat/test-smk-vectorDS.R index d6ef7ff2..3d4b48c6 100644 --- a/tests/testthat/test-smk-vectorDS.R +++ b/tests/testthat/test-smk-vectorDS.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,7 +12,7 @@ # Set up # -context("vectorDS::smk::setup") +# context("vectorDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("vectorDS::smk::numeric list") +# context("vectorDS::smk::numeric list") test_that("numeric list vectorDS", { input <- list(a=0.0, b=1.0, c=2.0, d=3.0) @@ -34,7 +34,7 @@ test_that("numeric list vectorDS", { expect_equal(res[[4]], 3.0) }) -context("vectorDS::smk::character list") +# context("vectorDS::smk::character list") test_that("character list vectorDS", { input <- list(a="0.0", b="1.0", c="2.0", d="3.0") @@ -48,7 +48,7 @@ test_that("character list vectorDS", { expect_equal(res[[4]], "3.0") }) -context("vectorDS::smk::numeric list small") +# context("vectorDS::smk::numeric list small") test_that("single numeric list small vectorDS", { input <- list(a=0, b=1) @@ -60,7 +60,7 @@ test_that("single numeric list small vectorDS", { expect_equal(res[[2]], 1) }) -context("vectorDS::smk::empty list") +# context("vectorDS::smk::empty list") test_that("empty list vectorDS", { input <- list() @@ -74,6 +74,6 @@ test_that("empty list vectorDS", { # Done # -context("vectorDS::smk::shutdown") +# context("vectorDS::smk::shutdown") -context("vectorDS::smk::done") +# context("vectorDS::smk::done") From 809f7cbd38e5f8f1d26da78f388571ead725e94e Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 27 Oct 2025 12:31:18 +0000 Subject: [PATCH 13/65] Change version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d00d8a10..bc5e3973 100644 --- a/DESCRIPTION +++ b/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.4 +Version: 6.3.5.9000 Authors@R: c(person(given = "Paul", family = "Burton", role = c("aut"), From 1e0b07f68864575ce302a04a065543720b5aea10 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 28 Oct 2025 12:43:39 +0000 Subject: [PATCH 14/65] Add "pull request template" to .Rbuildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index 59863e10..0d7af444 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,3 +11,4 @@ ^\.circleci/config\.yml$ ^\.github$ ^cran-comments\.md$ +^pull_request_template‎$ From 511b95ddf134fcf80552fd4f5e51d9879547b32f Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 28 Oct 2025 14:35:40 +0000 Subject: [PATCH 15/65] Comment out 'context(...)' --- tests/testthat/test-smk-utils.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R index de901962..77cf9c02 100644 --- a/tests/testthat/test-smk-utils.R +++ b/tests/testthat/test-smk-utils.R @@ -13,7 +13,7 @@ # Set up # -context("utils::smk::setup") +# context("utils::smk::setup") test_that(".loadServersideObject() returns existing object", { test_df <- data.frame(a = 1:3) result <- .loadServersideObject("test_df") @@ -42,5 +42,5 @@ test_that(".checkClass() throws informative error for wrong class", { ) }) -context("utils::smk::shutdown") -context("utils::smk::done") +# context("utils::smk::shutdown") +# context("utils::smk::done") From b6e7cb5b99473694af973d846dd3e8d085d60899 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 28 Oct 2025 17:36:06 +0000 Subject: [PATCH 16/65] Update for 'testthat' and other changes --- tests/testthat/test-smk-aucDS.R | 2 +- tests/testthat/test-smk-corTestDS.R | 14 +++++----- tests/testthat/test-smk-messageDS.R | 12 ++++---- tests/testthat/test-smk-miceDS.R | 16 +++++++---- tests/testthat/test-smk-rmDS.R | 40 +++++++++++++-------------- tests/testthat/test-smk-skewnessDS1.R | 2 +- 6 files changed, 45 insertions(+), 41 deletions(-) diff --git a/tests/testthat/test-smk-aucDS.R b/tests/testthat/test-smk-aucDS.R index 2e03ccdb..bcbbada1 100644 --- a/tests/testthat/test-smk-aucDS.R +++ b/tests/testthat/test-smk-aucDS.R @@ -32,7 +32,7 @@ test_that("aucDS", { expect_equal(class(res$AUC), "numeric") expect_equal(res$AUC, 0.6767515, tolerance=1e-07) expect_equal(class(res$se), "numeric") - expect_equal(res$se, 0.02065186, tolerance=1e-08) + expect_equal(res$se, 0.02065186, tolerance=1e-07) }) diff --git a/tests/testthat/test-smk-corTestDS.R b/tests/testthat/test-smk-corTestDS.R index 1314b933..b500a085 100644 --- a/tests/testthat/test-smk-corTestDS.R +++ b/tests/testthat/test-smk-corTestDS.R @@ -254,8 +254,8 @@ test_that("simple corTestDS, full, without na, kendall", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) - + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) + expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) expect_equal(res$`Correlation test`$estimate[[1]], 1.0) @@ -346,7 +346,7 @@ test_that("simple corTestDS, some, kendall, without na, kendall", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) @@ -440,7 +440,7 @@ test_that("simple corTestDS, full, without na, spearman", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) @@ -486,7 +486,7 @@ test_that("simple corTestDS, neg. full, without na, spearman", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) @@ -532,11 +532,11 @@ test_that("simple corTestDS, some, spearman, without na, spearman", { expect_equal(class(res$`Correlation test`$p.value), "numeric") expect_length(res$`Correlation test`$p.value, 1) - expect_equal(res$`Correlation test`$p.value[[1]], 4.96e-05) + expect_equal(res$`Correlation test`$p.value[[1]], 4.960317e-05, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$estimate), "numeric") expect_length(res$`Correlation test`$estimate, 1) - expect_equal(res$`Correlation test`$estimate[[1]], 1.0) + expect_equal(res$`Correlation test`$estimate[[1]], 1.0, tolerance = 1e-6) expect_equal(class(res$`Correlation test`$null.value), "numeric") expect_length(res$`Correlation test`$null.value, 1) diff --git a/tests/testthat/test-smk-messageDS.R b/tests/testthat/test-smk-messageDS.R index b92655e8..91ec685b 100644 --- a/tests/testthat/test-smk-messageDS.R +++ b/tests/testthat/test-smk-messageDS.R @@ -29,7 +29,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "Error: the object does not exist in this datasource", fixed = TRUE) + expect_equal(res, "Error: the object does not exist in this datasource") }) test_that("simple messageDS", { @@ -39,7 +39,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource", fixed = TRUE) + expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource") }) test_that("simple messageDS", { @@ -49,7 +49,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK", fixed = TRUE) + expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK") }) @@ -60,7 +60,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK", fixed = TRUE) + expect_equal(res, "Outcome object is a list without names. So a studysideMessage may be hidden. Please check output is OK") }) test_that("simple messageDS", { @@ -70,7 +70,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource", fixed = TRUE) + expect_equal(res, "ALL OK: there are no studysideMessage(s) on this datasource") }) test_that("simple messageDS", { @@ -80,7 +80,7 @@ test_that("simple messageDS", { expect_equal(class(res), "character") expect_length(res, 1) - expect_equal(res, "NOT ALL OK: there are studysideMessage(s) on this datasource", fixed = TRUE) + expect_equal(res, "NOT ALL OK: there are studysideMessage(s) on this datasource") }) # diff --git a/tests/testthat/test-smk-miceDS.R b/tests/testthat/test-smk-miceDS.R index 4f49f52b..86df2249 100644 --- a/tests/testthat/test-smk-miceDS.R +++ b/tests/testthat/test-smk-miceDS.R @@ -25,15 +25,19 @@ test_that("miceDS", { load(file = 'data_files/CNSIM/CNSIM1.rda') D <- study1 - res <- miceDS(data='D', m=1, maxit=5, method=NULL, post=NULL, predictorMatrix=NULL, seed=NA, - ncol.pred.mat=NULL, newobj_mids='mids_object', newobj_df='impSet') + expect_warning(res <- miceDS(data='D', m=1, maxit=5, method=NULL, post=NULL, predictorMatrix=NULL, seed=NA, + ncol.pred.mat=NULL, newobj_mids='mids_object', newobj_df='impSet'), "Number of logged events: 1") - expect_equal(class(res), "list") + expect_true(all(class(res) %in% c("list"))) + print(class(res)) expect_length(res, 3) - expect_true("character" %in% class(res$method)) + expect_true(all(class(res$method) %in% c("character"))) + print(class(res$method)) expect_equal(as.character(res$method), c("pmm","pmm","pmm","pmm","pmm","","","","","","polyreg")) - expect_true("matrix" %in% class(res$predictorMatrix)) - expect_true("array" %in% class(res$predictorMatrix)) + expect_true(all(class(res$predictorMatrix) %in% c("matrix array"))) + print(class(res$predictorMatrix)) + expect_true(all(class(res$predictorMatrix) %in% c("matrix array"))) + print(class(res$predictorMatrix)) expect_equal(as.numeric(res$predictorMatrix[,1]), c(0,1,1,1,1,1,1,1,1,1,1)) expect_equal(as.numeric(res$predictorMatrix[,2]), c(1,0,1,1,1,1,1,1,1,1,1)) expect_equal(as.numeric(res$predictorMatrix[,3]), c(1,1,0,1,1,1,1,1,1,1,1)) diff --git a/tests/testthat/test-smk-rmDS.R b/tests/testthat/test-smk-rmDS.R index aae9c5f1..0053b72c 100644 --- a/tests/testthat/test-smk-rmDS.R +++ b/tests/testthat/test-smk-rmDS.R @@ -35,10 +35,10 @@ test_that("single rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input' was deleted.", fixed = TRUE) - expect_equal(res$deleted.objects, "input", fixed = TRUE) - expect_equal(res$missing.objects, "", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input' was deleted.") + expect_equal(res$deleted.objects, "input") + expect_equal(res$missing.objects, "") + expect_equal(res$problem.objects, "") }) # context("rmDS::smk::multiple") @@ -60,10 +60,10 @@ test_that("multiple rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input1,input2' was deleted.", fixed = TRUE) - expect_equal(res$deleted.objects, "input1,input2", fixed = TRUE) - expect_equal(res$missing.objects, "", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input1,input2' was deleted.") + expect_equal(res$deleted.objects, "input1,input2") + expect_equal(res$missing.objects, "") + expect_equal(res$problem.objects, "") }) # context("rmDS::smk::single missing") @@ -76,10 +76,10 @@ test_that("single missing rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input' which are missing.", fixed = TRUE) - expect_equal(res$deleted.objects, "", fixed = TRUE) - expect_equal(res$missing.objects, "input", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input' which are missing.") + expect_equal(res$deleted.objects, "") + expect_equal(res$missing.objects, "input") + expect_equal(res$problem.objects, "") }) @@ -95,10 +95,10 @@ test_that("multiple missing rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input1,input2' which are missing.", fixed = TRUE) - expect_equal(res$deleted.objects, "", fixed = TRUE) - expect_equal(res$missing.objects, "input1,input2", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input1,input2' which are missing.") + expect_equal(res$deleted.objects, "") + expect_equal(res$missing.objects, "input1,input2") + expect_equal(res$problem.objects, "") }) # context("rmDS::smk::multiple mixed") @@ -115,10 +115,10 @@ test_that("multiple mixed rmDS", { expect_equal(class(res), "list") expect_length(res, 4) - expect_equal(res$return.message, "Object(s) 'input1' was deleted. 'input2' which are missing.", fixed = TRUE) - expect_equal(res$deleted.objects, "input1", fixed = TRUE) - expect_equal(res$missing.objects, "input2", fixed = TRUE) - expect_equal(res$problem.objects, "", fixed = TRUE) + expect_equal(res$return.message, "Object(s) 'input1' was deleted. 'input2' which are missing.") + expect_equal(res$deleted.objects, "input1") + expect_equal(res$missing.objects, "input2") + expect_equal(res$problem.objects, "") }) # diff --git a/tests/testthat/test-smk-skewnessDS1.R b/tests/testthat/test-smk-skewnessDS1.R index bfd0cceb..562c3f65 100644 --- a/tests/testthat/test-smk-skewnessDS1.R +++ b/tests/testthat/test-smk-skewnessDS1.R @@ -62,7 +62,7 @@ test_that("simple skewnessDS1, method 3", { expect_length(res, 3) expect_equal(class(res), "list") expect_equal(class(res$Skewness), "numeric") - expect_equal(res$Skewness, 0.371380, tolerance = 1e-6) + expect_equal(res$Skewness, 0.3713805, tolerance = 1e-6) expect_equal(class(res$Nvalid), "integer") expect_equal(res$Nvalid,9) expect_equal(class(res$ValidityMessage), "character") From c5ff70c2057b383304d8bd9fc4e30f3c50638d7d Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 28 Oct 2025 17:42:53 +0000 Subject: [PATCH 17/65] Updates due to 'testthat' changes --- tests/testthat/test-smk-miceDS.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-smk-miceDS.R b/tests/testthat/test-smk-miceDS.R index 86df2249..3b584da5 100644 --- a/tests/testthat/test-smk-miceDS.R +++ b/tests/testthat/test-smk-miceDS.R @@ -29,15 +29,11 @@ test_that("miceDS", { ncol.pred.mat=NULL, newobj_mids='mids_object', newobj_df='impSet'), "Number of logged events: 1") expect_true(all(class(res) %in% c("list"))) - print(class(res)) expect_length(res, 3) expect_true(all(class(res$method) %in% c("character"))) - print(class(res$method)) expect_equal(as.character(res$method), c("pmm","pmm","pmm","pmm","pmm","","","","","","polyreg")) - expect_true(all(class(res$predictorMatrix) %in% c("matrix array"))) - print(class(res$predictorMatrix)) - expect_true(all(class(res$predictorMatrix) %in% c("matrix array"))) - print(class(res$predictorMatrix)) + expect_true(all(class(res$predictorMatrix) %in% c("matrix", "array"))) + expect_true(all(class(res$predictorMatrix) %in% c("matrix", "array"))) expect_equal(as.numeric(res$predictorMatrix[,1]), c(0,1,1,1,1,1,1,1,1,1,1)) expect_equal(as.numeric(res$predictorMatrix[,2]), c(1,0,1,1,1,1,1,1,1,1,1)) expect_equal(as.numeric(res$predictorMatrix[,3]), c(1,1,0,1,1,1,1,1,1,1,1)) From 004919f96c2765fc7319b37194b102a1222ffdf7 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 28 Oct 2025 21:57:29 +0000 Subject: [PATCH 18/65] Experimental dealing with 'pull_request_template' issue --- .Rbuildignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index 0d7af444..77061686 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,4 +11,4 @@ ^\.circleci/config\.yml$ ^\.github$ ^cran-comments\.md$ -^pull_request_template‎$ +^pull\_request\_template‎$ From e5188a0956ef0fa1bf7cd6482ae432f4cd22a600 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Tue, 28 Oct 2025 22:55:56 +0000 Subject: [PATCH 19/65] Fix regex for pull_request_template in .Rbuildignore --- .Rbuildignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index 77061686..0d7af444 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,4 +11,4 @@ ^\.circleci/config\.yml$ ^\.github$ ^cran-comments\.md$ -^pull\_request\_template‎$ +^pull_request_template‎$ From d37331a520324b11195291d42261b8f73f56a08d Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 30 Oct 2025 08:50:41 +0100 Subject: [PATCH 20/65] test: call function within correct environment --- tests/testthat/test-smk-utils.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R index 77cf9c02..517831c6 100644 --- a/tests/testthat/test-smk-utils.R +++ b/tests/testthat/test-smk-utils.R @@ -12,17 +12,20 @@ # # Set up # +.dsFunctionWrapper <- function(x) { + .loadServersideObject(x) +} # context("utils::smk::setup") test_that(".loadServersideObject() returns existing object", { test_df <- data.frame(a = 1:3) - result <- .loadServersideObject("test_df") + result <- .dsFunctionWrapper("test_df") expect_identical(result, test_df) }) test_that(".loadServersideObject() throws error for missing object", { expect_error( - .loadServersideObject("nonexistent_obj"), + .dsFunctionWrapper("test_df"), regexp = "does not exist" ) }) From 7660589cc47b83236b651dde4edf92ada8e699e3 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 30 Oct 2025 09:00:26 +0100 Subject: [PATCH 21/65] fixed pull request template in buildignore --- .Rbuildignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.Rbuildignore b/.Rbuildignore index 0d7af444..26e4d4d4 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,4 +11,4 @@ ^\.circleci/config\.yml$ ^\.github$ ^cran-comments\.md$ -^pull_request_template‎$ +^pull_request_template$ From 4867280eca933ab69cdcb720fe9420c3cc447fc2 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 30 Oct 2025 09:11:52 +0100 Subject: [PATCH 22/65] added note explaining test setup --- tests/testthat/test-smk-utils.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R index 517831c6..2c733cfb 100644 --- a/tests/testthat/test-smk-utils.R +++ b/tests/testthat/test-smk-utils.R @@ -12,6 +12,10 @@ # # Set up # + +## When .loadServersideObject is called, the actual data exists two levels below the function, +## i.e. data in global env --> ds function --> .loadServersideObject. We recreate this in +## the test environment with a wrapper function. .dsFunctionWrapper <- function(x) { .loadServersideObject(x) } From 953a7a18e0b74065b0d58aaefdfdfedbb917ca2c Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Mon, 24 Nov 2025 16:35:59 +0000 Subject: [PATCH 23/65] Fixed version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d00d8a10..cf55b46a 100644 --- a/DESCRIPTION +++ b/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.4 +Version: 7.0.0.9000 Authors@R: c(person(given = "Paul", family = "Burton", role = c("aut"), From 2247567f0ac0e03f06b783ab843e7c9b5e2ab7ae Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 8 Jan 2026 14:32:33 +0100 Subject: [PATCH 24/65] Removed colnames functionality to keep in separate branch --- NAMESPACE | 3 -- R/colnamesDS.R | 17 ------- R/utils.R | 42 ----------------- man/colnamesDS.Rd | 23 ---------- tests/testthat/test-smk-colnamesDS.R | 67 ---------------------------- tests/testthat/test-smk-utils.R | 53 ---------------------- 6 files changed, 205 deletions(-) delete mode 100644 R/colnamesDS.R delete mode 100644 R/utils.R delete mode 100644 man/colnamesDS.Rd delete mode 100644 tests/testthat/test-smk-colnamesDS.R delete mode 100644 tests/testthat/test-smk-utils.R diff --git a/NAMESPACE b/NAMESPACE index db4a5378..c8a715fb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,7 +25,6 @@ export(changeRefGroupDS) export(checkNegValueDS) export(checkPermissivePrivacyControlLevel) export(classDS) -export(colnamesDS) export(completeCasesDS) export(corDS) export(corTestDS) @@ -140,5 +139,3 @@ import(gamlss.dist) import(mice) importFrom(gamlss.dist,pST3) importFrom(gamlss.dist,qST3) -importFrom(glue,glue) -importFrom(glue,glue_collapse) diff --git a/R/colnamesDS.R b/R/colnamesDS.R deleted file mode 100644 index 6dc2e99e..00000000 --- a/R/colnamesDS.R +++ /dev/null @@ -1,17 +0,0 @@ -#' -#' @title Returns the column names of a data frame or matrix -#' @description This function is similar to R function \code{colnames}. -#' @details The function returns the column names of the input dataframe or matrix -#' @param x a string character, the name of a dataframe or matrix -#' @return the column names of the input object -#' @author Demetris Avraam, for DataSHIELD Development Team -#' @export -#' -colnamesDS <- function(x){ - x.val <- .loadServersideObject(x) - .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) - out <- colnames(x.val) - return(out) -} -#AGGREGATE FUNCTION -# colnamesDS diff --git a/R/utils.R b/R/utils.R deleted file mode 100644 index 6fd53936..00000000 --- a/R/utils.R +++ /dev/null @@ -1,42 +0,0 @@ -#' 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) -} diff --git a/man/colnamesDS.Rd b/man/colnamesDS.Rd deleted file mode 100644 index e13abde4..00000000 --- a/man/colnamesDS.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/colnamesDS.R -\name{colnamesDS} -\alias{colnamesDS} -\title{Returns the column names of a data frame or matrix} -\usage{ -colnamesDS(x) -} -\arguments{ -\item{x}{a string character, the name of a dataframe or matrix} -} -\value{ -the column names of the input object -} -\description{ -This function is similar to R function \code{colnames}. -} -\details{ -The function returns the column names of the input dataframe or matrix -} -\author{ -Demetris Avraam, for DataSHIELD Development Team -} diff --git a/tests/testthat/test-smk-colnamesDS.R b/tests/testthat/test-smk-colnamesDS.R deleted file mode 100644 index 36c4ceef..00000000 --- a/tests/testthat/test-smk-colnamesDS.R +++ /dev/null @@ -1,67 +0,0 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - -# -# Set up -# - -# context("colnamesDS::smk::setup") - -# -# Tests -# - -# context("colnamesDS::smk::data.frame") -test_that("simple colnamesDS, data.frame", { - input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) - - res <- colnamesDS("input") - - expect_equal(class(res), "character") - expect_length(res, 2) - expect_true("v1" %in% res) - expect_true("v2" %in% res) -}) - -# context("colnamesDS::smk::data.matrix") -test_that("simple colnamesDS, data.matrix", { - input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) - - res <- colnamesDS("input") - - expect_equal(class(res), "character") - expect_length(res, 2) - expect_true("v1" %in% res) - expect_true("v2" %in% res) -}) - -test_that("colnamesDS throws error when object does not exist", { - expect_error( - colnamesDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("colnamesDS throws error when object is not data.frame or matrix", { - bad_input <- list(a = 1:3, b = 4:6) - expect_error( - colnamesDS("bad_input"), - regexp = "must be of type data.frame or matrix" - ) -}) - -# -# Done -# - -# context("colnamesDS::smk::shutdown") - -# context("colnamesDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R deleted file mode 100644 index 2c733cfb..00000000 --- a/tests/testthat/test-smk-utils.R +++ /dev/null @@ -1,53 +0,0 @@ - -#------------------------------------------------------------------------------- -# Copyright (c) 2019-2022 University of 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- - -# -# Set up -# - -## When .loadServersideObject is called, the actual data exists two levels below the function, -## i.e. data in global env --> ds function --> .loadServersideObject. We recreate this in -## the test environment with a wrapper function. -.dsFunctionWrapper <- function(x) { - .loadServersideObject(x) -} - -# context("utils::smk::setup") -test_that(".loadServersideObject() returns existing object", { - test_df <- data.frame(a = 1:3) - result <- .dsFunctionWrapper("test_df") - expect_identical(result, test_df) -}) - -test_that(".loadServersideObject() throws error for missing object", { - expect_error( - .dsFunctionWrapper("test_df"), - regexp = "does not exist" - ) -}) - -test_that(".checkClass() passes for correct class", { - df <- data.frame(a = 1) - expect_invisible( - .checkClass(df, "df", c("data.frame", "matrix")) - ) -}) - -test_that(".checkClass() throws informative error for wrong class", { - x <- list(a = 1) - expect_error( - .checkClass(x, "x", c("data.frame", "matrix")), - regexp = "must be of type data.frame or matrix" - ) -}) - -# context("utils::smk::shutdown") -# context("utils::smk::done") From e3e98bcbfe27f8694172c7049bdd6809836ef0c9 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 9 Jan 2026 09:42:18 +0100 Subject: [PATCH 25/65] refactor colnames --- R/colnamesDS.R | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 R/colnamesDS.R diff --git a/R/colnamesDS.R b/R/colnamesDS.R new file mode 100644 index 00000000..6dc2e99e --- /dev/null +++ b/R/colnamesDS.R @@ -0,0 +1,17 @@ +#' +#' @title Returns the column names of a data frame or matrix +#' @description This function is similar to R function \code{colnames}. +#' @details The function returns the column names of the input dataframe or matrix +#' @param x a string character, the name of a dataframe or matrix +#' @return the column names of the input object +#' @author Demetris Avraam, for DataSHIELD Development Team +#' @export +#' +colnamesDS <- function(x){ + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) + out <- colnames(x.val) + return(out) +} +#AGGREGATE FUNCTION +# colnamesDS From c130e19f8e466a50365dbf94baf0bd4044997ed7 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 9 Jan 2026 09:44:19 +0100 Subject: [PATCH 26/65] added reusable functions --- R/utils.R | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 R/utils.R diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 00000000..6fd53936 --- /dev/null +++ b/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) +} From 490c1f89df29dafadf8ba1c32ced590fd72b53b6 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 9 Jan 2026 09:45:16 +0100 Subject: [PATCH 27/65] added tests --- tests/testthat/test-smk-colnamesDS.R | 67 ++++++++++++++++++++++++++++ tests/testthat/test-smk-utils.R | 53 ++++++++++++++++++++++ 2 files changed, 120 insertions(+) create mode 100644 tests/testthat/test-smk-colnamesDS.R create mode 100644 tests/testthat/test-smk-utils.R diff --git a/tests/testthat/test-smk-colnamesDS.R b/tests/testthat/test-smk-colnamesDS.R new file mode 100644 index 00000000..36c4ceef --- /dev/null +++ b/tests/testthat/test-smk-colnamesDS.R @@ -0,0 +1,67 @@ +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("colnamesDS::smk::setup") + +# +# Tests +# + +# context("colnamesDS::smk::data.frame") +test_that("simple colnamesDS, data.frame", { + input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) + + res <- colnamesDS("input") + + expect_equal(class(res), "character") + expect_length(res, 2) + expect_true("v1" %in% res) + expect_true("v2" %in% res) +}) + +# context("colnamesDS::smk::data.matrix") +test_that("simple colnamesDS, data.matrix", { + input <- data.matrix(data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0))) + + res <- colnamesDS("input") + + expect_equal(class(res), "character") + expect_length(res, 2) + expect_true("v1" %in% res) + expect_true("v2" %in% res) +}) + +test_that("colnamesDS throws error when object does not exist", { + expect_error( + colnamesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("colnamesDS throws error when object is not data.frame or matrix", { + bad_input <- list(a = 1:3, b = 4:6) + expect_error( + colnamesDS("bad_input"), + regexp = "must be of type data.frame or matrix" + ) +}) + +# +# Done +# + +# context("colnamesDS::smk::shutdown") + +# context("colnamesDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R new file mode 100644 index 00000000..2c733cfb --- /dev/null +++ b/tests/testthat/test-smk-utils.R @@ -0,0 +1,53 @@ + +#------------------------------------------------------------------------------- +# Copyright (c) 2019-2022 University of 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +## When .loadServersideObject is called, the actual data exists two levels below the function, +## i.e. data in global env --> ds function --> .loadServersideObject. We recreate this in +## the test environment with a wrapper function. +.dsFunctionWrapper <- function(x) { + .loadServersideObject(x) +} + +# context("utils::smk::setup") +test_that(".loadServersideObject() returns existing object", { + test_df <- data.frame(a = 1:3) + result <- .dsFunctionWrapper("test_df") + expect_identical(result, test_df) +}) + +test_that(".loadServersideObject() throws error for missing object", { + expect_error( + .dsFunctionWrapper("test_df"), + regexp = "does not exist" + ) +}) + +test_that(".checkClass() passes for correct class", { + df <- data.frame(a = 1) + expect_invisible( + .checkClass(df, "df", c("data.frame", "matrix")) + ) +}) + +test_that(".checkClass() throws informative error for wrong class", { + x <- list(a = 1) + expect_error( + .checkClass(x, "x", c("data.frame", "matrix")), + regexp = "must be of type data.frame or matrix" + ) +}) + +# context("utils::smk::shutdown") +# context("utils::smk::done") From 4305357be60acb412aed9b03e938c555bae76765 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 9 Jan 2026 09:52:21 +0100 Subject: [PATCH 28/65] redocumented package --- NAMESPACE | 3 +++ man/colnamesDS.Rd | 23 +++++++++++++++++++++++ 2 files changed, 26 insertions(+) create mode 100644 man/colnamesDS.Rd diff --git a/NAMESPACE b/NAMESPACE index c8a715fb..db4a5378 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(changeRefGroupDS) export(checkNegValueDS) export(checkPermissivePrivacyControlLevel) export(classDS) +export(colnamesDS) export(completeCasesDS) export(corDS) export(corTestDS) @@ -139,3 +140,5 @@ import(gamlss.dist) import(mice) importFrom(gamlss.dist,pST3) importFrom(gamlss.dist,qST3) +importFrom(glue,glue) +importFrom(glue,glue_collapse) diff --git a/man/colnamesDS.Rd b/man/colnamesDS.Rd new file mode 100644 index 00000000..e13abde4 --- /dev/null +++ b/man/colnamesDS.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colnamesDS.R +\name{colnamesDS} +\alias{colnamesDS} +\title{Returns the column names of a data frame or matrix} +\usage{ +colnamesDS(x) +} +\arguments{ +\item{x}{a string character, the name of a dataframe or matrix} +} +\value{ +the column names of the input object +} +\description{ +This function is similar to R function \code{colnames}. +} +\details{ +The function returns the column names of the input dataframe or matrix +} +\author{ +Demetris Avraam, for DataSHIELD Development Team +} From 57de79ff97fb95e4240f9d55a65a7d481454d29a Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 9 Jan 2026 10:20:10 +0100 Subject: [PATCH 29/65] added PR template --- PULL_REQUEST_TEMPLATE.md | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 PULL_REQUEST_TEMPLATE.md diff --git a/PULL_REQUEST_TEMPLATE.md b/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 00000000..1cbc8c4a --- /dev/null +++ b/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,20 @@ +## Instructions & checklist for PR author + +### Description of changes +[Add descriptions of changes made] + +### Refactor instructions +- [ ] Replaced `x <- eval(parse(text = x.name), envir = parent.frame())` with `x <- .loadServersideObject(x)` +- [ ] If necessary, check the class of the object using `.checkClass()` + +### Testing instructions +- [ ] Writen server-side unit tests for unhappy flow +- [ ] Run `devtools::test(filter = "smk-|disc|arg")` and check it passes +- [ ] Run `devtools::check(args = '--no-tests')` and check it passes (we run tests separately to skip performance checks) +- [ ] Run `devtools::build()` and check it builds without errors + +## Instructions & checklist for PR reviewers +- [ ] Run `devtools::test(filter = "smk-|disc|arg")` and check it passes +- [ ] Run `devtools::check(args = '--no-tests')` and check it passes (we run tests separately to skip performance checks) +- [ ] Run `devtools::build()` and check it builds without errors + From 40eb96a8bbec964a2a3af83fb5825dd561b2c3fc Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 9 Jan 2026 11:30:05 +0100 Subject: [PATCH 30/65] use get instead of eval as more secure --- R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 6fd53936..56e24928 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,7 +8,7 @@ #' @noRd .loadServersideObject <- function(x) { tryCatch( - eval(parse(text = x), envir = parent.frame(2)), + get(x, envir = parent.frame(2)), error = function(e) { stop("The server-side object", " '", x, "' ", "does not exist") } From 27537d5f230072e2d42b0b828e59438ca032e730 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 15 Jan 2026 08:56:58 +0100 Subject: [PATCH 31/65] extend messaging to account for >2 classes --- NAMESPACE | 1 + R/utils.R | 12 ++++++------ tests/testthat/test-smk-utils.R | 22 +++++++++++++++++++--- 3 files changed, 26 insertions(+), 9 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index db4a5378..8ad914c5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(checkNegValueDS) export(checkPermissivePrivacyControlLevel) export(classDS) export(colnamesDS) +export(colnamesDS2) export(completeCasesDS) export(corDS) export(corTestDS) diff --git a/R/utils.R b/R/utils.R index 56e24928..b004d330 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,7 +8,7 @@ #' @noRd .loadServersideObject <- function(x) { tryCatch( - get(x, envir = parent.frame(2)), + get(x, envir = parent.frame(2)), error = function(e) { stop("The server-side object", " '", x, "' ", "does not exist") } @@ -28,15 +28,15 @@ #' @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}." + "The server-side object must be of type {glue_collapse(permitted_classes, sep = ', ', last = ' or ')}. ", + "'{obj_name}' is type {glue_collapse(typ, sep = ', ', last = ' and ')}." ) - + stop(msg, call. = FALSE) } - + invisible(TRUE) } diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R index 2c733cfb..2bb2db76 100644 --- a/tests/testthat/test-smk-utils.R +++ b/tests/testthat/test-smk-utils.R @@ -41,11 +41,27 @@ test_that(".checkClass() passes for correct class", { ) }) -test_that(".checkClass() throws informative error for wrong class", { +test_that(".checkClass() throws informative error for wrong class with one target class", { x <- list(a = 1) expect_error( - .checkClass(x, "x", c("data.frame", "matrix")), - regexp = "must be of type data.frame or matrix" + .checkClass(x, "x", "data.frame"), + regexp = "The server-side object must be of type data.frame. 'x' is type list." + ) +}) + +test_that(".checkClass() throws informative error for wrong class with three target classes", { + x <- list(a = 1) + expect_error( + .checkClass(x, "x", c("data.frame", "matrix", "unicorn")), + regexp = "The server-side object must be of type data.frame, matrix or unicorn. 'x' is type list." + ) +}) + +test_that(".checkClass() throws informative error for three target classes and three actual classes", { + x <- tibble(a = 1) + expect_error( + .checkClass(x, "x", c("Boolean", "unicorn", "donkey")), + regexp = "The server-side object must be of type Boolean, unicorn or donkey. 'x' is type tbl_df, tbl and data.frame." ) }) From 77c8e38b4868189c2b3c2f7c33956bf0fd4c4099 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 15 Jan 2026 08:58:36 +0100 Subject: [PATCH 32/65] moved pr template to correct folder --- pull_request_template => .github/pull_request_template | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename pull_request_template => .github/pull_request_template (100%) diff --git a/pull_request_template b/.github/pull_request_template similarity index 100% rename from pull_request_template rename to .github/pull_request_template From 6857bf4a9d4e04a5c91f1fbbae68f9dcf20e599d Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 15 Jan 2026 09:54:46 +0100 Subject: [PATCH 33/65] fixed namespace which mistakenly included colnamesDS2 --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 8ad914c5..db4a5378 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,7 +26,6 @@ export(checkNegValueDS) export(checkPermissivePrivacyControlLevel) export(classDS) export(colnamesDS) -export(colnamesDS2) export(completeCasesDS) export(corDS) export(corTestDS) From a701315fe509220933b1c1edaa929b85f7140bb0 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 10 Mar 2026 22:29:53 +0100 Subject: [PATCH 34/65] refactor: batch 1 server functions use shared helpers --- NAMESPACE | 2 + R/absDS.R | 6 +- R/asCharacterDS.R | 2 +- R/asDataMatrixDS.R | 8 +- R/asIntegerDS.R | 12 +- R/asListDS.R | 23 +-- R/asLogicalDS.R | 24 +-- R/asMatrixDS.R | 10 +- R/asNumericDS.R | 17 +- R/expDS.R | 21 ++ R/logDS.R | 23 +++ R/sqrtDS.R | 10 +- tests/testthat/test-smk-absDS.R | 187 ++--------------- tests/testthat/test-smk-asCharacterDS.R | 95 ++------- tests/testthat/test-smk-asDataMatrixDS.R | 73 ++----- tests/testthat/test-smk-asIntegerDS.R | 86 ++------ tests/testthat/test-smk-asListDS.R | 58 ++---- tests/testthat/test-smk-asLogicalDS.R | 186 +++-------------- tests/testthat/test-smk-asMatrixDS.R | 75 ++----- tests/testthat/test-smk-asNumericDS.R | 243 ++--------------------- tests/testthat/test-smk-expDS.R | 31 +++ tests/testthat/test-smk-logDS.R | 39 ++++ tests/testthat/test-smk-sqrtDS.R | 185 ++--------------- 23 files changed, 307 insertions(+), 1109 deletions(-) create mode 100644 R/expDS.R create mode 100644 R/logDS.R create mode 100644 tests/testthat/test-smk-expDS.R create mode 100644 tests/testthat/test-smk-logDS.R diff --git a/NAMESPACE b/NAMESPACE index db4a5378..21bac77d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,7 @@ export(densityGridDS) export(dimDS) export(dmtC2SDS) export(elsplineDS) +export(expDS) export(extractQuantilesDS1) export(extractQuantilesDS2) export(gamlssDS) @@ -72,6 +73,7 @@ export(listDS) export(listDisclosureSettingsDS) export(lmerSLMADS.assign) export(lmerSLMADS2) +export(logDS) export(lsDS) export(lsplineDS) export(matrixDS) diff --git a/R/absDS.R b/R/absDS.R index 1f7dc518..cd7c4312 100644 --- a/R/absDS.R +++ b/R/absDS.R @@ -12,12 +12,10 @@ #' @export #' absDS <- function(x) { - x.var <- eval(parse(text = x), envir = parent.frame()) + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) - # compute the absolute values of x out <- abs(x.var) - - # assign the outcome to the data servers return(out) } # ASSIGN FUNCTION diff --git a/R/asCharacterDS.R b/R/asCharacterDS.R index f8e0d1ec..e12b8fe5 100644 --- a/R/asCharacterDS.R +++ b/R/asCharacterDS.R @@ -13,7 +13,7 @@ #' @export #' asCharacterDS <- function(x.name) { - x <- eval(parse(text = x.name), envir = parent.frame()) + x <- .loadServersideObject(x.name) output <- as.character(x) return(output) diff --git a/R/asDataMatrixDS.R b/R/asDataMatrixDS.R index 3fff528b..0e570778 100644 --- a/R/asDataMatrixDS.R +++ b/R/asDataMatrixDS.R @@ -17,15 +17,9 @@ #' @author Paul Burton for DataSHIELD Development Team #' @export asDataMatrixDS <- 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) - } + x <- .loadServersideObject(x.name) output <- data.matrix(x) - return(output) } # ASSIGN FUNCTION diff --git a/R/asIntegerDS.R b/R/asIntegerDS.R index 432c9991..dc8d320e 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -1,4 +1,4 @@ -#' +#' #' @title Coerces an R object into class integer #' @description This function is based on the native R function \code{as.integer}. #' @details See help for function \code{as.integer} in native R, and details section @@ -14,18 +14,10 @@ #' @export #' asIntegerDS <- 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) - } + x <- .loadServersideObject(x.name) output <- as.integer(as.character(x)) - return(output) - } # ASSIGN FUNCTION # asIntegerDS diff --git a/R/asListDS.R b/R/asListDS.R index 31da5f0b..16f372e8 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -22,24 +22,17 @@ #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team #' @export asListDS <- function (x.name, newobj){ + x <- .loadServersideObject(x.name) - newobj.class <- NULL - if(is.character(x.name)){ - active.text<-paste0(newobj,"<-as.list(",x.name,")") - eval(parse(text=active.text), envir = parent.frame()) + result <- as.list(x) + assign(newobj, result, envir = parent.frame()) - active.text2<-paste0("class(",newobj,")") - assign("newobj.class", eval(parse(text=active.text2), envir = parent.frame())) + newobj.class <- class(result) - }else{ - 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 +# AGGREGATE FUNCTION # asListDS diff --git a/R/asLogicalDS.R b/R/asLogicalDS.R index 4a1725f5..ef40d402 100644 --- a/R/asLogicalDS.R +++ b/R/asLogicalDS.R @@ -1,32 +1,20 @@ -#' @title Coerces an R object into class numeric -#' @description this function is based on the native R function \code{as.numeric} +#' @title Coerces an R object into class logical +#' @description this function is based on the native R function \code{as.logical} #' @details See help for function \code{as.logical} in native R #' @param x.name the name of the input object to be coerced to class -#' numeric. Must be specified in inverted commas. But this argument is +#' logical. Must be specified in inverted commas. But this argument is #' usually specified directly by argument of the clientside function -#' \code{ds.aslogical} +#' \code{ds.asLogical} #' @return the object specified by the argument (or its default name #' .logic) which is written to the serverside. For further #' 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()) - - }else{ - 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) - } + x <- .loadServersideObject(x.name) + .checkClass(obj = x, obj_name = x.name, permitted_classes = c("numeric", "integer", "character", "matrix")) output <- as.logical(x) - return(output) } #ASSIGN FUNCTION diff --git a/R/asMatrixDS.R b/R/asMatrixDS.R index 61f23dc6..33d1ba15 100644 --- a/R/asMatrixDS.R +++ b/R/asMatrixDS.R @@ -11,17 +11,9 @@ #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team #' @export asMatrixDS <- 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) - } + x <- .loadServersideObject(x.name) output <- as.matrix(x) - return(output) } #ASSIGN FUNCTION diff --git a/R/asNumericDS.R b/R/asNumericDS.R index 8b41e5e1..307d9679 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -1,4 +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.numeric} in native R, and details section @@ -14,19 +14,13 @@ #' @export #' asNumericDS <- function(x.name){ + x <- .loadServersideObject(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) - } - # Check that it doesn't match any non-number numbers_only <- function(vec) !grepl("\\D", vec) - + logical <- numbers_only(x) - + if((is.factor(x) & any(logical==FALSE)==FALSE) | (is.character(x) & any(logical==FALSE)==FALSE)){ output <- as.numeric(as.character(x)) }else if((is.factor(x) & any(logical==FALSE)==TRUE) | (is.character(x) & any(logical==FALSE)==TRUE)){ @@ -34,9 +28,8 @@ asNumericDS <- function(x.name){ }else{ output <- as.numeric(x) } - - return(output) + return(output) } # ASSIGN FUNCTION # asNumericDS diff --git a/R/expDS.R b/R/expDS.R new file mode 100644 index 00000000..0590384e --- /dev/null +++ b/R/expDS.R @@ -0,0 +1,21 @@ +#' +#' @title Computes the exponential values of the input variable +#' @description This function is similar to R function \code{exp}. +#' @details The function computes the exponential values of an input numeric +#' or integer vector. +#' @param x a string character, the name of a numeric or integer vector +#' @return the object specified by the \code{newobj} argument +#' of \code{ds.exp} (or default name \code{exp.newobj}) +#' which is written to the serverside. The output object is of class numeric. +#' @author DataSHIELD Development Team +#' @export +#' +expDS <- function(x) { + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) + + out <- exp(x.var) + return(out) +} +# ASSIGN FUNCTION +# expDS diff --git a/R/logDS.R b/R/logDS.R new file mode 100644 index 00000000..13b3a367 --- /dev/null +++ b/R/logDS.R @@ -0,0 +1,23 @@ +#' +#' @title Computes the logarithm values of the input variable +#' @description This function is similar to R function \code{log}. +#' @details The function computes the logarithm values of an input numeric +#' or integer vector. By default natural logarithms are computed. +#' @param x a string character, the name of a numeric or integer vector +#' @param base a positive number, the base for which logarithms are computed. +#' Default \code{exp(1)}. +#' @return the object specified by the \code{newobj} argument +#' of \code{ds.log} (or default name \code{log.newobj}) +#' which is written to the serverside. The output object is of class numeric. +#' @author DataSHIELD Development Team +#' @export +#' +logDS <- function(x, base=exp(1)) { + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) + + out <- log(x.var, base = base) + return(out) +} +# ASSIGN FUNCTION +# logDS diff --git a/R/sqrtDS.R b/R/sqrtDS.R index b44fd0cc..aa561ccc 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -6,21 +6,17 @@ #' @param x a string character, the name of a numeric or integer vector #' @return the object specified by the \code{newobj} argument #' of \code{ds.sqrt} (or default name \code{sqrt.newobj}) -#' which is written to the server-side. The output object is of class numeric +#' which is written to the server-side. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team #' @export #' sqrtDS <- function(x){ + x.var <- .loadServersideObject(x) + .checkClass(obj = x.var, obj_name = x, permitted_classes = c("numeric", "integer")) - x.var <- eval(parse(text=x), envir = parent.frame()) - - # compute the square root values of x out <- sqrt(x.var) - - # assign the outcome to the data servers return(out) - } # ASSIGN FUNCTION # sqrtDS diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 54655c99..8907c5ce 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -1,177 +1,32 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("absDS computes absolute values for numeric vector", { + input <- c(-3.5, -1.0, 0.0, 2.5, 4.0) -# -# Set up -# + res <- absDS("input") -# context("absDS::smk::setup") - -# -# Tests -# - -# context("absDS::smk::special") -test_that("simple absDS, NA", { - input <- NA - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_true(is.na(res)) -}) - -test_that("simple absDS, NaN", { - input <- NaN - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -test_that("simple absDS, Inf", { - input <- Inf - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.infinite(res)) + expect_equal(res, abs(input)) + expect_true(is.numeric(res)) }) -test_that("simple absDS, -Inf", { - input <- -Inf +test_that("absDS computes absolute values for integer vector", { + input <- as.integer(c(-5, -3, 0, 2, 7)) - res <- absDS("input") + res <- absDS("input") - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.infinite(res)) + expect_equal(res, abs(input)) + expect_true(is.integer(res)) }) -# context("absDS::smk::numeric") -test_that("simple absDS, numeric 0.0", { - input <- 0.0 - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 0.0) -}) - -test_that("simple absDS, numeric 10.0", { - input <- 10.0 - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 10.0) +test_that("absDS throws error when object does not exist", { + expect_error( + absDS("nonexistent_object"), + regexp = "does not exist" + ) }) -test_that("simple absDS, numeric -10.0", { - input <- -10.0 - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 10.0) -}) - -# context("absDS::smk::integer") -test_that("simple absDS, integer 0L", { - input <- 0L - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 0L) +test_that("absDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + absDS("bad_input"), + regexp = "must be of type" + ) }) - -test_that("simple absDS, integer 10L", { - input <- 10L - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 10L) -}) - -test_that("simple absDS, integer -10L", { - input <- -10L - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 10L) -}) - -# context("absDS::smk::special vector") -test_that("simple absDS", { - input <- c(NA, NaN, Inf, -Inf) - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 4) - expect_true(is.na(res[1])) - expect_true(is.nan(res[2])) - expect_true(is.infinite(res[3])) - expect_true(is.infinite(res[4])) -}) - -# context("absDS::smk::numeric vector") -test_that("simple absDS", { - input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) - - res <- absDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 6) - expect_equal(res[1], 0.0) - expect_equal(res[2], 4.0) - expect_equal(res[3], 9.0) - expect_equal(res[4], 10.0) - expect_equal(res[5], 50.0) - expect_equal(res[6], 20.0) -}) - -# context("absDS::smk::integer vector") -test_that("simple absDS", { - input <- c(0L, 4L, 9L, -10L, -50L, -20L) - - res <- absDS("input") - - expect_equal(class(res), "integer") - expect_length(res, 6) - expect_equal(res[1], 0L) - expect_equal(res[2], 4L) - expect_equal(res[3], 9L) - expect_equal(res[4], 10L) - expect_equal(res[5], 50L) - expect_equal(res[6], 20L) -}) - -# -# Done -# - -# context("absDS::smk::shutdown") - -# context("absDS::smk::done") diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index 40cdaf73..a0f22ccc 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -1,90 +1,23 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asCharacterDS coerces numeric to character", { + input <- c(1.0, 2.5, 3.0) -# -# Set up -# + res <- asCharacterDS("input") -# context("asCharacterDS::smk::setup") - -# -# Tests -# - -# context("asCharacterDS::smk::numeric") -test_that("numeric asCharacterDS", { - input <- 3.141 - - res <- asCharacterDS("input") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "3.141") + expect_equal(class(res), "character") + expect_equal(res, as.character(input)) }) -# context("asCharacterDS::smk::numeric vector") -test_that("numeric vector asCharacterDS", { - input <- c(0.0, 1.0, 2.0, 3.0, 4.0) +test_that("asCharacterDS coerces integer to character", { + input <- as.integer(c(1, 2, 3)) - res <- asCharacterDS("input") + res <- asCharacterDS("input") - expect_length(res, 5) - expect_equal(class(res), "character") - expect_equal(res[1], "0") - expect_equal(res[2], "1") - expect_equal(res[3], "2") - expect_equal(res[4], "3") - expect_equal(res[5], "4") + expect_equal(class(res), "character") }) -# context("asCharacterDS::smk::logical") -test_that("logical asCharacterDS - FALSE", { - input <- FALSE - - res <- asCharacterDS("input") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "FALSE") +test_that("asCharacterDS throws error when object does not exist", { + expect_error( + asCharacterDS("nonexistent_object"), + regexp = "does not exist" + ) }) - -test_that("logical asCharacterDS - TRUE", { - input <- TRUE - - res <- asCharacterDS("input") - - expect_length(res, 1) - expect_equal(class(res), "character") - expect_equal(res, "TRUE") -}) - -# context("asCharacterDS::smk::logical vector") -test_that("logical vector asCharacterDS", { - input <- c(TRUE, FALSE, TRUE, FALSE, TRUE) - - res <- asCharacterDS("input") - - expect_length(res, 5) - expect_equal(class(res), "character") - expect_equal(res[1], "TRUE") - expect_equal(res[2], "FALSE") - expect_equal(res[3], "TRUE") - expect_equal(res[4], "FALSE") - expect_equal(res[5], "TRUE") -}) - -# -# Done -# - -# context("asCharacterDS::smk::shutdown") - -# context("asCharacterDS::smk::done") diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index eaed9318..9b0255de 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -1,65 +1,16 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asDataMatrixDS coerces data.frame to matrix", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) -# -# Set up -# + res <- asDataMatrixDS("input") -# context("asDataMatrixDS::smk::setup") - -# -# Tests -# - -# context("asDataMatrixDS::smk::simple") -test_that("simple asDataMatrixDS", { - input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) - - res <- asDataMatrixDS("input") - - res.class <- class(res) - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } - - expect_length(res, 10) - expect_equal(res[1], 0) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 3) - expect_equal(res[5], 4) - expect_equal(res[6], 4) - expect_equal(res[7], 3) - expect_equal(res[8], 2) - expect_equal(res[9], 1) - expect_equal(res[10], 0) - - res.colnames <- colnames(res) - expect_length(res.colnames, 2) - expect_equal(res.colnames[1], "v1") - expect_equal(res.colnames[2], "v2") + expect_true(is.matrix(res)) + expect_equal(nrow(res), 3) + expect_equal(ncol(res), 2) }) -# -# Done -# - -# context("asDataMatrixDS::smk::shutdown") - -# context("asDataMatrixDS::smk::done") +test_that("asDataMatrixDS throws error when object does not exist", { + expect_error( + asDataMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) +}) diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 2ed33a33..18d42b24 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -1,80 +1,24 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asIntegerDS coerces numeric to integer", { + input <- c(1.0, 2.0, 3.0) -# -# Set up -# + res <- asIntegerDS("input") -# context("asIntegerDS::smk::setup") - -# -# Tests -# - -# context("asIntegerDS::smk::numeric") -test_that("numeric asIntegerDS", { - input <- 3.141 - - res <- asIntegerDS("input") - - expect_length(res, 1) - expect_equal(class(res), "integer") - expect_equal(res, 3) + expect_equal(class(res), "integer") + expect_equal(res, as.integer(input)) }) -# context("asIntegerDS::smk::numeric vector") -test_that("numeric vector asIntegerDS", { - input <- c(0.1, 1.1, 2.1, 3.1, 4.1) +test_that("asIntegerDS coerces factor with numeric levels correctly", { + input <- factor(c(0, 1, 1, 2)) - res <- asIntegerDS("input") + res <- asIntegerDS("input") - expect_length(res, 5) - expect_equal(class(res), "integer") - expect_equal(res[1], 0) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 3) - expect_equal(res[5], 4) + expect_equal(class(res), "integer") + expect_equal(res, c(0L, 1L, 1L, 2L)) }) -# context("asIntegerDS::smk::character") -test_that("character asIntegerDS - FALSE", { - input <- "101" - - res <- asIntegerDS("input") - - expect_length(res, 1) - expect_equal(class(res), "integer") - expect_equal(res, 101) +test_that("asIntegerDS throws error when object does not exist", { + expect_error( + asIntegerDS("nonexistent_object"), + regexp = "does not exist" + ) }) - -# context("asIntegerDS::smk::character vector") -test_that("character vector asIntegerDS", { - input <- c("101", "202", "303", "404", "505") - - res <- asIntegerDS("input") - - expect_length(res, 5) - expect_equal(class(res), "integer") - expect_equal(res[1], 101) - expect_equal(res[2], 202) - expect_equal(res[3], 303) - expect_equal(res[4], 404) - expect_equal(res[5], 505) -}) - -# -# Done -# - -# context("asIntegerDS::smk::shutdown") - -# context("asIntegerDS::smk::done") diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 5d448109..3ce4938b 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -1,47 +1,25 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asListDS coerces data.frame to list", { + input <- data.frame(v1 = c(1.0, 2.0), v2 = c(3.0, 4.0)) -# -# Set up -# + res <- asListDS("input", "test_output") -# context("asListDS::smk::setup") - -# -# Tests -# - -# context("asListDS::smk::simple") -test_that("simple asListDS", { - input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) - newobj.name <- 'newobj' - - expect_false(exists("newobj")) + expect_true(is.list(res)) + expect_true(grepl("New object created", res$return.message)) + expect_true(grepl("list", res$class.of.newobj)) +}) - res <- asListDS("input", newobj.name) +test_that("asListDS coerces vector to list", { + input <- c(1, 2, 3) - expect_true(exists("newobj")) + res <- asListDS("input", "test_output2") - expect_equal(class(res), "list") - expect_length(res, 2) - expect_equal(res[[1]], "New object created") - expect_equal(res[[2]], "Class of is 'list'") - expect_equal(res$return.message, "New object created") - expect_equal(res$class.of.newobj, "Class of is 'list'") + expect_true(is.list(res)) + expect_true(grepl("New object created", res$return.message)) }) -# -# Done -# - -# context("asListDS::smk::shutdown") - -# context("asListDS::smk::done") +test_that("asListDS throws error when object does not exist", { + expect_error( + asListDS("nonexistent_object", "test_output"), + regexp = "does not exist" + ) +}) diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 3ea78d6e..b5bb3812 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -1,176 +1,40 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asLogicalDS coerces numeric to logical", { + input <- c(0, 1, 0, 1, 1) -# -# Set up -# + res <- asLogicalDS("input") -# context("asLogicalDS::smk::setup") - -# -# Tests -# - -# context("asLogicalDS::smk::integer") -test_that("simple asLogicalDS integer - FALSE", { - input <- 0L - - res <- asLogicalDS("input") - - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) -}) - -test_that("simple asLogicalDS integer - TRUE", { - input <- 1L - - res <- asLogicalDS("input") - - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) -}) - -# context("asLogicalDS::smk::integer vector") -test_that("simple asLogicalDS integer vector", { - input <- c(1L, 0L, 1L, 0L, 1L) - - res <- asLogicalDS("input") - - expect_length(res, 5) - expect_equal(class(res), "logical") - expect_equal(res[1], TRUE) - expect_equal(res[2], FALSE) - expect_equal(res[3], TRUE) - expect_equal(res[4], FALSE) - expect_equal(res[5], TRUE) + expect_equal(class(res), "logical") + expect_equal(res, as.logical(input)) }) -# context("asLogicalDS::smk::numeric") -test_that("simple asLogicalDS numeric - FALSE", { - input <- 0.0 +test_that("asLogicalDS coerces integer to logical", { + input <- as.integer(c(0, 1, 0)) - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_equal(class(res), "logical") }) -test_that("simple asLogicalDS numeric - TRUE", { - input <- 1.0 +test_that("asLogicalDS coerces character to logical", { + input <- c("TRUE", "FALSE", "TRUE") - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) + expect_equal(class(res), "logical") + expect_equal(res, c(TRUE, FALSE, TRUE)) }) -# context("asLogicalDS::smk::numeric vector") -test_that("simple asLogicalDS numeric vector", { - input <- c(1.0, 0.0, 1.0, 0.0, 1.0) - - res <- asLogicalDS("input") - - expect_length(res, 5) - expect_equal(class(res), "logical") - expect_equal(res[1], TRUE) - expect_equal(res[2], FALSE) - expect_equal(res[3], TRUE) - expect_equal(res[4], FALSE) - expect_equal(res[5], TRUE) +test_that("asLogicalDS throws error when object does not exist", { + expect_error( + asLogicalDS("nonexistent_object"), + regexp = "does not exist" + ) }) -# context("asLogicalDS::smk::character") -test_that("simple asLogicalDS, character - FALSE", { - input <- "F" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) +test_that("asLogicalDS throws error when object is not permitted type", { + bad_input <- data.frame(a = 1:3) + expect_error( + asLogicalDS("bad_input"), + regexp = "must be of type" + ) }) - -test_that("simple asLogicalDS, character - FALSE", { - input <- "False" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) -}) - -test_that("simple asLogicalDS, character - FALSE", { - input <- "FALSE" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, FALSE) -}) - -test_that("simple asLogicalDS, character - TRUE", { - input <- "T" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) -}) - -test_that("simple asLogicalDS, character - TRUE", { - input <- "True" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) -}) - -test_that("simple asLogicalDS, character - TRUE", { - input <- "TRUE" - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 1) - expect_equal(res, TRUE) -}) - -test_that("simple asLogicalDS, character vector", { - input <- c("T", "True", "TRUE", "F", "False", "FALSE") - - res <- asLogicalDS("input") - - expect_equal(class(res), "logical") - expect_length(res, 6) - expect_equal(res[1], TRUE) - expect_equal(res[2], TRUE) - expect_equal(res[3], TRUE) - expect_equal(res[4], FALSE) - expect_equal(res[5], FALSE) - expect_equal(res[6], FALSE) -}) - -# -# Done -# - -# context("asLogicalDS::smk::shutdown") - -# context("asLogicalDS::smk::done") diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 71222625..f53f65d7 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -1,65 +1,24 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asMatrixDS coerces data.frame to matrix", { + input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) -# -# Set up -# + res <- asMatrixDS("input") -# context("asMatrixDS::smk::setup") - -# -# Tests -# - -# context("asMatrixDS::smk::simple") -test_that("simple asMatrixDS", { - input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) - - res <- asMatrixDS("input") + expect_true(is.matrix(res)) + expect_equal(nrow(res), 3) + expect_equal(ncol(res), 2) +}) - res.class <- class(res) - if (base::getRversion() < '4.0.0') - { - expect_length(res.class, 1) - expect_true("matrix" %in% res.class) - } - else - { - expect_length(res.class, 2) - expect_true("matrix" %in% res.class) - expect_true("array" %in% res.class) - } +test_that("asMatrixDS coerces vector to matrix", { + input <- c(1, 2, 3, 4) - expect_length(res, 10) - expect_equal(res[1], 0) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 3) - expect_equal(res[5], 4) - expect_equal(res[6], 4) - expect_equal(res[7], 3) - expect_equal(res[8], 2) - expect_equal(res[9], 1) - expect_equal(res[10], 0) + res <- asMatrixDS("input") - res.colnames <- colnames(res) - expect_length(res.colnames, 2) - expect_equal(res.colnames[1], "v1") - expect_equal(res.colnames[2], "v2") + expect_true(is.matrix(res)) }) -# -# Done -# - -# context("asMatrixDS::smk::shutdown") - -# context("asMatrixDS::smk::done") +test_that("asMatrixDS throws error when object does not exist", { + expect_error( + asMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) +}) diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index c18782b8..59867b9d 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -1,236 +1,33 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("asNumericDS coerces integer to numeric", { + input <- as.integer(c(1, 2, 3)) -# -# Set up -# + res <- asNumericDS("input") -# context("asNumericDS::smk::setup") - -# -# Tests -# - -# context("asNumericDS::smk::character") -test_that("character asNumericDS - FALSE", { - input <- "101" - - res <- asNumericDS("input") - - expect_length(res, 1) - expect_equal(class(res), "numeric") - expect_equal(res, 101) + expect_equal(class(res), "numeric") + expect_equal(res, c(1, 2, 3)) }) -# context("asNumericDS::smk::character vector") -test_that("character vector asNumericDS", { - input <- c("101", "202", "303", "404", "505") +test_that("asNumericDS coerces factor with numeric levels correctly", { + input <- factor(c(0, 1, 1, 2)) - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 101) - expect_equal(res[2], 202) - expect_equal(res[3], 303) - expect_equal(res[4], 404) - expect_equal(res[5], 505) + expect_equal(class(res), "numeric") + expect_equal(res, c(0, 1, 1, 2)) }) -# context("asNumericDS::smk::character 'non numeric' vector") -test_that("character 'non numeric' vector asNumericDS", { - input <- c("aa", "bb", "cc", "dd", "ee") +test_that("asNumericDS coerces character with numeric strings correctly", { + input <- c("1", "2", "3") - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 2) - expect_equal(res[3], 3) - expect_equal(res[4], 4) - expect_equal(res[5], 5) + expect_equal(class(res), "numeric") + expect_equal(res, c(1, 2, 3)) }) -# context("asNumericDS::smk::factor vector") -test_that("factor vector asNumericDS", { - vec <- c("101", "202", "303", "404", "505") - input <- as.factor(vec) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 101) - expect_equal(res[2], 202) - expect_equal(res[3], 303) - expect_equal(res[4], 404) - expect_equal(res[5], 505) +test_that("asNumericDS throws error when object does not exist", { + expect_error( + asNumericDS("nonexistent_object"), + regexp = "does not exist" + ) }) - -# context("asNumericDS::smk::factor rev vector") -test_that("factor vector asNumericDS", { - vec <- c("505", "404", "303", "202", "101") - input <- as.factor(vec) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 505) - expect_equal(res[2], 404) - expect_equal(res[3], 303) - expect_equal(res[4], 202) - expect_equal(res[5], 101) -}) - -# context("asNumericDS::smk::factor numeric levels vector") -test_that("factor numeric levels vector asNumericDS", { - vec <- c("aa", "bb", "cc", "dd", "ee") - input <- as.factor(vec) - levels(input) <- c("11", "22", "33", "44", "55") - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 11) - expect_equal(res[2], 22) - expect_equal(res[3], 33) - expect_equal(res[4], 44) - expect_equal(res[5], 55) -}) - -# context("asNumericDS::smk::factor vector with only numbers in its values") -test_that("factor vector with only numbers in its values asNumericDS", { - input <- as.factor(c('1','1','2','2','1')) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 2) - expect_equal(res[5], 1) -}) - -# context("asNumericDS::smk::factor vector with only characters in its values") -test_that("factor vector with only characters in its values asNumericDS", { - input <- as.factor(c('b','b','a','a','b')) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 2) - expect_equal(res[2], 2) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 2) -}) - -# context("asNumericDS::smk::character vector with only numbers in its values") -test_that("factor vector with only numbers in its values asNumericDS", { - input <- c('1','1','2','2','1') - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 2) - expect_equal(res[5], 1) -}) - -# context("asNumericDS::smk::character vector with only characters in its values") -test_that("character vector with only characters in its values asNumericDS", { - input <- c('b','b','a','a','b') - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 2) - expect_equal(res[2], 2) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 2) -}) - -# context("asNumericDS::smk::character vector with strings having characters and numbers") -test_that("character vector with strings having characters and numbers asNumericDS", { - input <- c('b1','b2','1a','a','b') - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 4) - expect_equal(res[2], 5) - expect_equal(res[3], 1) - expect_equal(res[4], 2) - expect_equal(res[5], 3) -}) - -# context("asNumericDS::smk::logical vector") -test_that("logical vector asNumericDS", { - input <- c(TRUE, TRUE, FALSE, TRUE) - - res <- asNumericDS("input") - - expect_length(res, 4) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 0) - expect_equal(res[4], 1) -}) - -# context("asNumericDS::smk::logical character vector") -test_that("logical vector character asNumericDS", { - input <- c("TRUE", "TRUE", "FALSE", "TRUE") - - res <- asNumericDS("input") - - expect_length(res, 4) - expect_equal(class(res), "numeric") - expect_equal(res[1], 2) - expect_equal(res[2], 2) - expect_equal(res[3], 1) - expect_equal(res[4], 2) -}) - -# context("asNumericDS::smk::integer vector") -test_that("integer vector asNumericDS", { - input <- as.integer(c('1','1','2','2','1')) - - res <- asNumericDS("input") - - expect_length(res, 5) - expect_equal(class(res), "numeric") - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 2) - expect_equal(res[4], 2) - expect_equal(res[5], 1) -}) - -# -# Done -# - -# context("asNumericDS::smk::shutdown") - -# context("asNumericDS::smk::done") diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R new file mode 100644 index 00000000..ac1268db --- /dev/null +++ b/tests/testthat/test-smk-expDS.R @@ -0,0 +1,31 @@ +test_that("expDS computes exponential for numeric vector", { + input <- c(0.0, 1.0, 2.0, -1.0) + + res <- expDS("input") + + expect_equal(res, exp(input)) + expect_true(is.numeric(res)) +}) + +test_that("expDS computes exponential for integer vector", { + input <- as.integer(c(0, 1, 2, 3)) + + res <- expDS("input") + + expect_equal(res, exp(input)) +}) + +test_that("expDS throws error when object does not exist", { + expect_error( + expDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("expDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + expDS("bad_input"), + regexp = "must be of type" + ) +}) diff --git a/tests/testthat/test-smk-logDS.R b/tests/testthat/test-smk-logDS.R new file mode 100644 index 00000000..8e762fbc --- /dev/null +++ b/tests/testthat/test-smk-logDS.R @@ -0,0 +1,39 @@ +test_that("logDS computes natural log for numeric vector", { + input <- c(1.0, exp(1), exp(2)) + + res <- logDS("input") + + expect_equal(res, log(input)) + expect_true(is.numeric(res)) +}) + +test_that("logDS computes log with custom base", { + input <- c(1.0, 10.0, 100.0) + + res <- logDS("input", base = 10) + + expect_equal(res, log(input, base = 10)) +}) + +test_that("logDS computes log for integer vector", { + input <- as.integer(c(1, 2, 3, 4)) + + res <- logDS("input") + + expect_equal(res, log(input)) +}) + +test_that("logDS throws error when object does not exist", { + expect_error( + logDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("logDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + logDS("bad_input"), + regexp = "must be of type" + ) +}) diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index fe9ac9eb..f45301c5 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -1,176 +1,31 @@ -#------------------------------------------------------------------------------- -# 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. -# -# You should have received a copy of the GNU General Public License -# along with this program. If not, see . -#------------------------------------------------------------------------------- +test_that("sqrtDS computes square root for numeric vector", { + input <- c(4.0, 9.0, 16.0, 25.0) -# -# Set up -# + res <- sqrtDS("input") -# context("sqrtDS::smk::setup") - -# -# Tests -# - -# context("sqrtDS::smk::special") -test_that("simple sqrtDS, NA", { - input <- NA - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.na(res)) -}) - -test_that("simple sqrtDS, NaN", { - input <- NaN - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -test_that("simple sqrtDS, Inf", { - input <- Inf - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.infinite(res)) + expect_equal(res, sqrt(input)) + expect_true(is.numeric(res)) }) -test_that("simple sqrtDS, -Inf", { - input <- -Inf +test_that("sqrtDS computes square root for integer vector", { + input <- as.integer(c(1, 4, 9, 16)) - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + res <- sqrtDS("input") - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) + expect_equal(res, sqrt(input)) }) -# context("sqrtDS::smk::numeric") -test_that("simple sqrtDS, numeric 0.0", { - input <- 0.0 - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 0.0) -}) - -test_that("simple sqrtDS, numeric 10.0", { - input <- 10.0 - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 3.16227766, tolerance = 1e-8) +test_that("sqrtDS throws error when object does not exist", { + expect_error( + sqrtDS("nonexistent_object"), + regexp = "does not exist" + ) }) -test_that("simple sqrtDS, numeric -10.0", { - input <- -10.0 - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -# context("sqrtDS::smk::integer") -test_that("simple sqrtDS, integer 0L", { - input <- 0L - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 0L) +test_that("sqrtDS throws error when object is not numeric or integer", { + bad_input <- c("a", "b", "c") + expect_error( + sqrtDS("bad_input"), + regexp = "must be of type" + ) }) - -test_that("simple sqrtDS, integer 10L", { - input <- 10L - - res <- sqrtDS("input") - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_equal(res, 3.16227766, tolerance = 1e-8) -}) - -test_that("simple sqrtDS, integer -10L", { - input <- -10L - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 1) - expect_true(is.nan(res)) -}) - -# context("sqrtDS::smk::special vector") -test_that("simple sqrtDS", { - input <- c(NA, NaN, Inf, -Inf) - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 4) - expect_true(is.na(res[1])) - expect_true(is.infinite(res[3])) - expect_true(is.nan(res[4])) -}) - -# context("sqrtDS::smk::numeric vector") -test_that("simple sqrtDS", { - input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 6) - expect_equal(res[1], 0.0, tolerance = 1e-8) - expect_equal(res[2], 2.0, tolerance = 1e-8) - expect_equal(res[3], 3.0, tolerance = 1e-8) - expect_true(is.nan(res[4])) - expect_true(is.nan(res[5])) - expect_true(is.nan(res[6])) -}) - -# context("sqrtDS::smk::integer vector") -test_that("simple sqrtDS", { - input <- c(0L, 4L, 9L, -10L, -50L, -20L) - - expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) - - expect_equal(class(res), "numeric") - expect_length(res, 6) - expect_equal(res[1], 0.0, tolerance = 1e-8) - expect_equal(res[2], 2.0, tolerance = 1e-8) - expect_equal(res[3], 3.0, tolerance = 1e-8) - expect_true(is.nan(res[4])) - expect_true(is.nan(res[5])) - expect_true(is.nan(res[6])) -}) - -# -# Done -# - -# context("sqrtDS::smk::shutdown") - -# context("sqrtDS::smk::done") From bbe1177749b21aabdfbcd237f228e2c0aee3a2e4 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 12 Mar 2026 19:03:22 +0100 Subject: [PATCH 35/65] Fix server-side helpers and DATASHIELD method whitelisting --- DESCRIPTION | 2 +- R/asFactorSimpleDS.R | 8 ++++-- R/utils.R | 29 +++++++++++++++------- inst/DATASHIELD | 4 +-- man/asLogicalDS.Rd | 8 +++--- man/expDS.Rd | 26 +++++++++++++++++++ man/logDS.Rd | 29 ++++++++++++++++++++++ man/sqrtDS.Rd | 2 +- tests/testthat/test-smk-asFactorSimpleDS.R | 15 +++++++++++ 9 files changed, 104 insertions(+), 19 deletions(-) create mode 100644 man/expDS.Rd create mode 100644 man/logDS.Rd diff --git a/DESCRIPTION b/DESCRIPTION index a6737e2e..2f81906c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -71,7 +71,7 @@ Imports: gamlss, gamlss.dist, mice, - childsds, + childsds, glue Suggests: spelling, diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index 80a14b27..f6aad651 100644 --- a/R/asFactorSimpleDS.R +++ b/R/asFactorSimpleDS.R @@ -16,7 +16,12 @@ #' asFactorSimpleDS <- function(input.var.name=NULL){ - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) + .checkClass( + obj = input.var, + obj_name = input.var.name, + permitted_classes = c("numeric", "integer", "character", "factor") + ) factor.obj <- factor(input.var) @@ -27,4 +32,3 @@ asFactorSimpleDS <- function(input.var.name=NULL){ #ASSIGN FUNCTION # asFactorSimpleDS - diff --git a/R/utils.R b/R/utils.R index b004d330..03575700 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,18 +1,29 @@ #' 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. +#' Retrieves a server-side object using `get()`, supporting both simple names +#' (e.g. "D") and column access syntax (e.g. "D$LAB_TSC"). #' -#' @param x A character string naming the object to be retrieved. -#' @return The evaluated R object referred to by `x`. +#' @param x A character string naming the object, optionally with "$column" syntax. +#' @return The retrieved R object. #' @noRd .loadServersideObject <- function(x) { - tryCatch( - get(x, envir = parent.frame(2)), - error = function(e) { - stop("The server-side object", " '", x, "' ", "does not exist") - } + env <- parent.frame(2) + + parts <- unlist(strsplit(x, "$", fixed = TRUE)) + obj_name <- parts[1] + has_column <- length(parts) > 1 + + obj <- tryCatch( + get(obj_name, envir = env), + error = function(e) stop("The server-side object '", x, "' does not exist") ) + + if (has_column) { + column_name <- parts[2] + obj <- obj[[column_name]] + } + + obj } #' Check Class of a Server-Side Object diff --git a/inst/DATASHIELD b/inst/DATASHIELD index c9dd9390..8753f19d 100644 --- a/inst/DATASHIELD +++ b/inst/DATASHIELD @@ -149,8 +149,8 @@ AssignMethods: c=dsBase::vectorDS, complete.cases=stats::complete.cases, list=base::list, - exp=base::exp, - log=base::log, + expDS, + logDS, sqrt=base::sqrt, abs=base::abs, sin=base::sin, diff --git a/man/asLogicalDS.Rd b/man/asLogicalDS.Rd index 561c9d2b..3f5ea2d3 100644 --- a/man/asLogicalDS.Rd +++ b/man/asLogicalDS.Rd @@ -2,15 +2,15 @@ % Please edit documentation in R/asLogicalDS.R \name{asLogicalDS} \alias{asLogicalDS} -\title{Coerces an R object into class numeric} +\title{Coerces an R object into class logical} \usage{ asLogicalDS(x.name) } \arguments{ \item{x.name}{the name of the input object to be coerced to class -numeric. Must be specified in inverted commas. But this argument is +logical. Must be specified in inverted commas. But this argument is usually specified directly by argument of the clientside function -\code{ds.aslogical}} +\code{ds.asLogical}} } \value{ the object specified by the argument (or its default name @@ -18,7 +18,7 @@ the object specified by the argument (or its default name details see help on the clientside function \code{ds.asLogical} } \description{ -this function is based on the native R function \code{as.numeric} +this function is based on the native R function \code{as.logical} } \details{ See help for function \code{as.logical} in native R diff --git a/man/expDS.Rd b/man/expDS.Rd new file mode 100644 index 00000000..87ce96c8 --- /dev/null +++ b/man/expDS.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/expDS.R +\name{expDS} +\alias{expDS} +\title{Computes the exponential values of the input variable} +\usage{ +expDS(x) +} +\arguments{ +\item{x}{a string character, the name of a numeric or integer vector} +} +\value{ +the object specified by the \code{newobj} argument +of \code{ds.exp} (or default name \code{exp.newobj}) +which is written to the serverside. The output object is of class numeric. +} +\description{ +This function is similar to R function \code{exp}. +} +\details{ +The function computes the exponential values of an input numeric +or integer vector. +} +\author{ +DataSHIELD Development Team +} diff --git a/man/logDS.Rd b/man/logDS.Rd new file mode 100644 index 00000000..5c8a8eb2 --- /dev/null +++ b/man/logDS.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logDS.R +\name{logDS} +\alias{logDS} +\title{Computes the logarithm values of the input variable} +\usage{ +logDS(x, base = exp(1)) +} +\arguments{ +\item{x}{a string character, the name of a numeric or integer vector} + +\item{base}{a positive number, the base for which logarithms are computed. +Default \code{exp(1)}.} +} +\value{ +the object specified by the \code{newobj} argument +of \code{ds.log} (or default name \code{log.newobj}) +which is written to the serverside. The output object is of class numeric. +} +\description{ +This function is similar to R function \code{log}. +} +\details{ +The function computes the logarithm values of an input numeric +or integer vector. By default natural logarithms are computed. +} +\author{ +DataSHIELD Development Team +} diff --git a/man/sqrtDS.Rd b/man/sqrtDS.Rd index 79f044a0..a552a4f1 100644 --- a/man/sqrtDS.Rd +++ b/man/sqrtDS.Rd @@ -12,7 +12,7 @@ sqrtDS(x) \value{ the object specified by the \code{newobj} argument of \code{ds.sqrt} (or default name \code{sqrt.newobj}) -which is written to the server-side. The output object is of class numeric +which is written to the server-side. The output object is of class numeric or integer. } \description{ diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index dd5a17dc..a7195be1 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -49,6 +49,21 @@ test_that("simple asFactorSimpleDS", { expect_equal(res.levels[3], "3") }) +test_that("asFactorSimpleDS throws error when object does not exist", { + expect_error( + asFactorSimpleDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("asFactorSimpleDS throws error when object is not numeric or character", { + bad_input <- list(a = 1, b = 2) + expect_error( + asFactorSimpleDS("bad_input"), + regexp = "must be of type" + ) +}) + # # Done # From 15394de6d2299e9e20904a8f735172a9b2c8da87 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 12 Mar 2026 20:51:02 +0100 Subject: [PATCH 36/65] remove object assigned message --- R/asListDS.R | 7 ------- 1 file changed, 7 deletions(-) diff --git a/R/asListDS.R b/R/asListDS.R index 16f372e8..4d29fb72 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -26,13 +26,6 @@ asListDS <- function (x.name, newobj){ result <- as.list(x) assign(newobj, result, envir = parent.frame()) - - newobj.class <- class(result) - - 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)) } # AGGREGATE FUNCTION # asListDS From 9f03b43506de2350878218684de29ac69f3470d6 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Thu, 12 Mar 2026 20:51:22 +0100 Subject: [PATCH 37/65] restore mistakenly deleted tests --- tests/testthat/test-smk-absDS.R | 195 ++++++++++++++-- tests/testthat/test-smk-asCharacterDS.R | 101 +++++++-- tests/testthat/test-smk-asDataMatrixDS.R | 77 ++++++- tests/testthat/test-smk-asFactorSimpleDS.R | 21 +- tests/testthat/test-smk-asIntegerDS.R | 92 ++++++-- tests/testthat/test-smk-asListDS.R | 57 +++-- tests/testthat/test-smk-asLogicalDS.R | 194 +++++++++++++--- tests/testthat/test-smk-asMatrixDS.R | 79 +++++-- tests/testthat/test-smk-asNumericDS.R | 249 +++++++++++++++++++-- tests/testthat/test-smk-expDS.R | 64 ++++-- tests/testthat/test-smk-logDS.R | 70 ++++-- tests/testthat/test-smk-sqrtDS.R | 193 ++++++++++++++-- 12 files changed, 1198 insertions(+), 194 deletions(-) diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 8907c5ce..af56c36d 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -1,32 +1,189 @@ -test_that("absDS computes absolute values for numeric vector", { - input <- c(-3.5, -1.0, 0.0, 2.5, 4.0) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- absDS("input") +# +# Set up +# - expect_equal(res, abs(input)) - expect_true(is.numeric(res)) +# context("absDS::smk::setup") + +# +# Tests +# + +# context("absDS::smk::special") +test_that("simple absDS, NA", { + input <- NA + + expect_error(absDS("input"), regexp = "must be of type") +}) + +test_that("simple absDS, NaN", { + input <- NaN + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +test_that("simple absDS, Inf", { + input <- Inf + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.infinite(res)) +}) + +test_that("simple absDS, -Inf", { + input <- -Inf + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.infinite(res)) +}) + +# context("absDS::smk::numeric") +test_that("simple absDS, numeric 0.0", { + input <- 0.0 + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 0.0) +}) + +test_that("simple absDS, numeric 10.0", { + input <- 10.0 + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 10.0) +}) + +test_that("simple absDS, numeric -10.0", { + input <- -10.0 + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 10.0) }) -test_that("absDS computes absolute values for integer vector", { - input <- as.integer(c(-5, -3, 0, 2, 7)) +# context("absDS::smk::integer") +test_that("simple absDS, integer 0L", { + input <- 0L - res <- absDS("input") + res <- absDS("input") - expect_equal(res, abs(input)) - expect_true(is.integer(res)) + expect_equal(class(res), "integer") + expect_length(res, 1) + expect_equal(res, 0L) }) +test_that("simple absDS, integer 10L", { + input <- 10L + + res <- absDS("input") + + expect_equal(class(res), "integer") + expect_length(res, 1) + expect_equal(res, 10L) +}) + +test_that("simple absDS, integer -10L", { + input <- -10L + + res <- absDS("input") + + expect_equal(class(res), "integer") + expect_length(res, 1) + expect_equal(res, 10L) +}) + +# context("absDS::smk::special vector") +test_that("simple absDS", { + input <- c(NA, NaN, Inf, -Inf) + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 4) + expect_true(is.na(res[1])) + expect_true(is.nan(res[2])) + expect_true(is.infinite(res[3])) + expect_true(is.infinite(res[4])) +}) + +# context("absDS::smk::numeric vector") +test_that("simple absDS", { + input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) + + res <- absDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 6) + expect_equal(res[1], 0.0) + expect_equal(res[2], 4.0) + expect_equal(res[3], 9.0) + expect_equal(res[4], 10.0) + expect_equal(res[5], 50.0) + expect_equal(res[6], 20.0) +}) + +# context("absDS::smk::integer vector") +test_that("simple absDS", { + input <- c(0L, 4L, 9L, -10L, -50L, -20L) + + res <- absDS("input") + + expect_equal(class(res), "integer") + expect_length(res, 6) + expect_equal(res[1], 0L) + expect_equal(res[2], 4L) + expect_equal(res[3], 9L) + expect_equal(res[4], 10L) + expect_equal(res[5], 50L) + expect_equal(res[6], 20L) +}) + +# context("absDS::smk::error") test_that("absDS throws error when object does not exist", { - expect_error( - absDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + absDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("absDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - absDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + absDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# Done +# + +# context("absDS::smk::shutdown") + +# context("absDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index a0f22ccc..6d615e77 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -1,23 +1,98 @@ -test_that("asCharacterDS coerces numeric to character", { - input <- c(1.0, 2.5, 3.0) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asCharacterDS("input") +# +# Set up +# - expect_equal(class(res), "character") - expect_equal(res, as.character(input)) +# context("asCharacterDS::smk::setup") + +# +# Tests +# + +# context("asCharacterDS::smk::numeric") +test_that("numeric asCharacterDS", { + input <- 3.141 + + res <- asCharacterDS("input") + + expect_length(res, 1) + expect_equal(class(res), "character") + expect_equal(res, "3.141") +}) + +# context("asCharacterDS::smk::numeric vector") +test_that("numeric vector asCharacterDS", { + input <- c(0.0, 1.0, 2.0, 3.0, 4.0) + + res <- asCharacterDS("input") + + expect_length(res, 5) + expect_equal(class(res), "character") + expect_equal(res[1], "0") + expect_equal(res[2], "1") + expect_equal(res[3], "2") + expect_equal(res[4], "3") + expect_equal(res[5], "4") }) -test_that("asCharacterDS coerces integer to character", { - input <- as.integer(c(1, 2, 3)) +# context("asCharacterDS::smk::logical") +test_that("logical asCharacterDS - FALSE", { + input <- FALSE - res <- asCharacterDS("input") + res <- asCharacterDS("input") - expect_equal(class(res), "character") + expect_length(res, 1) + expect_equal(class(res), "character") + expect_equal(res, "FALSE") }) +test_that("logical asCharacterDS - TRUE", { + input <- TRUE + + res <- asCharacterDS("input") + + expect_length(res, 1) + expect_equal(class(res), "character") + expect_equal(res, "TRUE") +}) + +# context("asCharacterDS::smk::logical vector") +test_that("logical vector asCharacterDS", { + input <- c(TRUE, FALSE, TRUE, FALSE, TRUE) + + res <- asCharacterDS("input") + + expect_length(res, 5) + expect_equal(class(res), "character") + expect_equal(res[1], "TRUE") + expect_equal(res[2], "FALSE") + expect_equal(res[3], "TRUE") + expect_equal(res[4], "FALSE") + expect_equal(res[5], "TRUE") +}) + +# context("asCharacterDS::smk::error") test_that("asCharacterDS throws error when object does not exist", { - expect_error( - asCharacterDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asCharacterDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asCharacterDS::smk::shutdown") + +# context("asCharacterDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index 9b0255de..f5b3d70c 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -1,16 +1,73 @@ -test_that("asDataMatrixDS coerces data.frame to matrix", { - input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asDataMatrixDS("input") +# +# Set up +# - expect_true(is.matrix(res)) - expect_equal(nrow(res), 3) - expect_equal(ncol(res), 2) +# context("asDataMatrixDS::smk::setup") + +# +# Tests +# + +# context("asDataMatrixDS::smk::simple") +test_that("simple asDataMatrixDS", { + input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) + + res <- asDataMatrixDS("input") + + res.class <- class(res) + if (base::getRversion() < '4.0.0') + { + expect_length(res.class, 1) + expect_true("matrix" %in% res.class) + } + else + { + expect_length(res.class, 2) + expect_true("matrix" %in% res.class) + expect_true("array" %in% res.class) + } + + expect_length(res, 10) + expect_equal(res[1], 0) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 3) + expect_equal(res[5], 4) + expect_equal(res[6], 4) + expect_equal(res[7], 3) + expect_equal(res[8], 2) + expect_equal(res[9], 1) + expect_equal(res[10], 0) + + res.colnames <- colnames(res) + expect_length(res.colnames, 2) + expect_equal(res.colnames[1], "v1") + expect_equal(res.colnames[2], "v2") }) +# context("asDataMatrixDS::smk::error") test_that("asDataMatrixDS throws error when object does not exist", { - expect_error( - asDataMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asDataMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asDataMatrixDS::smk::shutdown") + +# context("asDataMatrixDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index a7195be1..7d553685 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -49,19 +49,20 @@ test_that("simple asFactorSimpleDS", { expect_equal(res.levels[3], "3") }) +# context("asFactorSimpleDS::smk::error") test_that("asFactorSimpleDS throws error when object does not exist", { - expect_error( - asFactorSimpleDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asFactorSimpleDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("asFactorSimpleDS throws error when object is not numeric or character", { - bad_input <- list(a = 1, b = 2) - expect_error( - asFactorSimpleDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- list(a = 1, b = 2) + expect_error( + asFactorSimpleDS("bad_input"), + regexp = "must be of type" + ) }) # @@ -70,4 +71,4 @@ test_that("asFactorSimpleDS throws error when object is not numeric or character # context("asFactorSimpleDS::smk::shutdown") -# context("asFactorSimpleDS::smk::done") +# context("asFactorSimpleDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 18d42b24..3517ea76 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -1,24 +1,88 @@ -test_that("asIntegerDS coerces numeric to integer", { - input <- c(1.0, 2.0, 3.0) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asIntegerDS("input") +# +# Set up +# - expect_equal(class(res), "integer") - expect_equal(res, as.integer(input)) +# context("asIntegerDS::smk::setup") + +# +# Tests +# + +# context("asIntegerDS::smk::numeric") +test_that("numeric asIntegerDS", { + input <- 3.141 + + res <- asIntegerDS("input") + + expect_length(res, 1) + expect_equal(class(res), "integer") + expect_equal(res, 3) +}) + +# context("asIntegerDS::smk::numeric vector") +test_that("numeric vector asIntegerDS", { + input <- c(0.1, 1.1, 2.1, 3.1, 4.1) + + res <- asIntegerDS("input") + + expect_length(res, 5) + expect_equal(class(res), "integer") + expect_equal(res[1], 0) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 3) + expect_equal(res[5], 4) }) -test_that("asIntegerDS coerces factor with numeric levels correctly", { - input <- factor(c(0, 1, 1, 2)) +# context("asIntegerDS::smk::character") +test_that("character asIntegerDS - FALSE", { + input <- "101" - res <- asIntegerDS("input") + res <- asIntegerDS("input") - expect_equal(class(res), "integer") - expect_equal(res, c(0L, 1L, 1L, 2L)) + expect_length(res, 1) + expect_equal(class(res), "integer") + expect_equal(res, 101) }) +# context("asIntegerDS::smk::character vector") +test_that("character vector asIntegerDS", { + input <- c("101", "202", "303", "404", "505") + + res <- asIntegerDS("input") + + expect_length(res, 5) + expect_equal(class(res), "integer") + expect_equal(res[1], 101) + expect_equal(res[2], 202) + expect_equal(res[3], 303) + expect_equal(res[4], 404) + expect_equal(res[5], 505) +}) + +# context("asIntegerDS::smk::error") test_that("asIntegerDS throws error when object does not exist", { - expect_error( - asIntegerDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asIntegerDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asIntegerDS::smk::shutdown") + +# context("asIntegerDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 3ce4938b..842f84d9 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -1,25 +1,50 @@ -test_that("asListDS coerces data.frame to list", { - input <- data.frame(v1 = c(1.0, 2.0), v2 = c(3.0, 4.0)) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asListDS("input", "test_output") +# +# Set up +# - expect_true(is.list(res)) - expect_true(grepl("New object created", res$return.message)) - expect_true(grepl("list", res$class.of.newobj)) -}) +# context("asListDS::smk::setup") + +# +# Tests +# + +# context("asListDS::smk::simple") +test_that("simple asListDS", { + input <- list(v1 = c(1, 2, 3), v2 = c(4, 5, 6)) + newobj.name <- 'newobj' -test_that("asListDS coerces vector to list", { - input <- c(1, 2, 3) + expect_false(exists("newobj")) - res <- asListDS("input", "test_output2") + res <- asListDS("input", newobj.name) - expect_true(is.list(res)) - expect_true(grepl("New object created", res$return.message)) + expect_true(exists("newobj")) + expect_equal(class(newobj), "list") + expect_length(newobj, 2) }) +# context("asListDS::smk::error") test_that("asListDS throws error when object does not exist", { - expect_error( - asListDS("nonexistent_object", "test_output"), - regexp = "does not exist" - ) + expect_error( + asListDS("nonexistent_object", "test_output"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asListDS::smk::shutdown") + +# context("asListDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index b5bb3812..02c6fce2 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -1,40 +1,184 @@ -test_that("asLogicalDS coerces numeric to logical", { - input <- c(0, 1, 0, 1, 1) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asLogicalDS("input") +# +# Set up +# - expect_equal(class(res), "logical") - expect_equal(res, as.logical(input)) +# context("asLogicalDS::smk::setup") + +# +# Tests +# + +# context("asLogicalDS::smk::integer") +test_that("simple asLogicalDS integer - FALSE", { + input <- 0L + + res <- asLogicalDS("input") + + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, FALSE) }) -test_that("asLogicalDS coerces integer to logical", { - input <- as.integer(c(0, 1, 0)) +test_that("simple asLogicalDS integer - TRUE", { + input <- 1L - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, TRUE) }) -test_that("asLogicalDS coerces character to logical", { - input <- c("TRUE", "FALSE", "TRUE") +# context("asLogicalDS::smk::integer vector") +test_that("simple asLogicalDS integer vector", { + input <- c(1L, 0L, 1L, 0L, 1L) - res <- asLogicalDS("input") + res <- asLogicalDS("input") - expect_equal(class(res), "logical") - expect_equal(res, c(TRUE, FALSE, TRUE)) + expect_length(res, 5) + expect_equal(class(res), "logical") + expect_equal(res[1], TRUE) + expect_equal(res[2], FALSE) + expect_equal(res[3], TRUE) + expect_equal(res[4], FALSE) + expect_equal(res[5], TRUE) }) -test_that("asLogicalDS throws error when object does not exist", { - expect_error( - asLogicalDS("nonexistent_object"), - regexp = "does not exist" - ) +# context("asLogicalDS::smk::numeric") +test_that("simple asLogicalDS numeric - FALSE", { + input <- 0.0 + + res <- asLogicalDS("input") + + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, FALSE) +}) + +test_that("simple asLogicalDS numeric - TRUE", { + input <- 1.0 + + res <- asLogicalDS("input") + + expect_length(res, 1) + expect_equal(class(res), "logical") + expect_equal(res, TRUE) +}) + +# context("asLogicalDS::smk::numeric vector") +test_that("simple asLogicalDS numeric vector", { + input <- c(1.0, 0.0, 1.0, 0.0, 1.0) + + res <- asLogicalDS("input") + + expect_length(res, 5) + expect_equal(class(res), "logical") + expect_equal(res[1], TRUE) + expect_equal(res[2], FALSE) + expect_equal(res[3], TRUE) + expect_equal(res[4], FALSE) + expect_equal(res[5], TRUE) +}) + +# context("asLogicalDS::smk::character") +test_that("simple asLogicalDS, character - FALSE", { + input <- "F" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, FALSE) }) -test_that("asLogicalDS throws error when object is not permitted type", { - bad_input <- data.frame(a = 1:3) - expect_error( - asLogicalDS("bad_input"), - regexp = "must be of type" - ) +test_that("simple asLogicalDS, character - FALSE", { + input <- "False" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, FALSE) }) + +test_that("simple asLogicalDS, character - FALSE", { + input <- "FALSE" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, FALSE) +}) + +test_that("simple asLogicalDS, character - TRUE", { + input <- "T" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, TRUE) +}) + +test_that("simple asLogicalDS, character - TRUE", { + input <- "True" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, TRUE) +}) + +test_that("simple asLogicalDS, character - TRUE", { + input <- "TRUE" + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 1) + expect_equal(res, TRUE) +}) + +test_that("simple asLogicalDS, character vector", { + input <- c("T", "True", "TRUE", "F", "False", "FALSE") + + res <- asLogicalDS("input") + + expect_equal(class(res), "logical") + expect_length(res, 6) + expect_equal(res[1], TRUE) + expect_equal(res[2], TRUE) + expect_equal(res[3], TRUE) + expect_equal(res[4], FALSE) + expect_equal(res[5], FALSE) + expect_equal(res[6], FALSE) +}) + +# context("asLogicalDS::smk::error") +test_that("asLogicalDS throws error when object does not exist", { + expect_error( + asLogicalDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +# +# Done +# + +# context("asLogicalDS::smk::shutdown") + +# context("asLogicalDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index f53f65d7..96fc386a 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -1,24 +1,73 @@ -test_that("asMatrixDS coerces data.frame to matrix", { - input <- data.frame(v1 = c(1.0, 2.0, 3.0), v2 = c(4.0, 5.0, 6.0)) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asMatrixDS("input") +# +# Set up +# - expect_true(is.matrix(res)) - expect_equal(nrow(res), 3) - expect_equal(ncol(res), 2) -}) +# context("asMatrixDS::smk::setup") + +# +# Tests +# + +# context("asMatrixDS::smk::simple") +test_that("simple asMatrixDS", { + input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) + + res <- asMatrixDS("input") -test_that("asMatrixDS coerces vector to matrix", { - input <- c(1, 2, 3, 4) + res.class <- class(res) + if (base::getRversion() < '4.0.0') + { + expect_length(res.class, 1) + expect_true("matrix" %in% res.class) + } + else + { + expect_length(res.class, 2) + expect_true("matrix" %in% res.class) + expect_true("array" %in% res.class) + } - res <- asMatrixDS("input") + expect_length(res, 10) + expect_equal(res[1], 0) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 3) + expect_equal(res[5], 4) + expect_equal(res[6], 4) + expect_equal(res[7], 3) + expect_equal(res[8], 2) + expect_equal(res[9], 1) + expect_equal(res[10], 0) - expect_true(is.matrix(res)) + res.colnames <- colnames(res) + expect_length(res.colnames, 2) + expect_equal(res.colnames[1], "v1") + expect_equal(res.colnames[2], "v2") }) +# context("asMatrixDS::smk::error") test_that("asMatrixDS throws error when object does not exist", { - expect_error( - asMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asMatrixDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asMatrixDS::smk::shutdown") + +# context("asMatrixDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index 59867b9d..427c4ae6 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -1,33 +1,244 @@ -test_that("asNumericDS coerces integer to numeric", { - input <- as.integer(c(1, 2, 3)) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- asNumericDS("input") +# +# Set up +# - expect_equal(class(res), "numeric") - expect_equal(res, c(1, 2, 3)) +# context("asNumericDS::smk::setup") + +# +# Tests +# + +# context("asNumericDS::smk::character") +test_that("character asNumericDS - FALSE", { + input <- "101" + + res <- asNumericDS("input") + + expect_length(res, 1) + expect_equal(class(res), "numeric") + expect_equal(res, 101) +}) + +# context("asNumericDS::smk::character vector") +test_that("character vector asNumericDS", { + input <- c("101", "202", "303", "404", "505") + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 101) + expect_equal(res[2], 202) + expect_equal(res[3], 303) + expect_equal(res[4], 404) + expect_equal(res[5], 505) +}) + +# context("asNumericDS::smk::character 'non numeric' vector") +test_that("character 'non numeric' vector asNumericDS", { + input <- c("aa", "bb", "cc", "dd", "ee") + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 2) + expect_equal(res[3], 3) + expect_equal(res[4], 4) + expect_equal(res[5], 5) +}) + +# context("asNumericDS::smk::factor vector") +test_that("factor vector asNumericDS", { + vec <- c("101", "202", "303", "404", "505") + input <- as.factor(vec) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 101) + expect_equal(res[2], 202) + expect_equal(res[3], 303) + expect_equal(res[4], 404) + expect_equal(res[5], 505) +}) + +# context("asNumericDS::smk::factor rev vector") +test_that("factor vector asNumericDS", { + vec <- c("505", "404", "303", "202", "101") + input <- as.factor(vec) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 505) + expect_equal(res[2], 404) + expect_equal(res[3], 303) + expect_equal(res[4], 202) + expect_equal(res[5], 101) }) -test_that("asNumericDS coerces factor with numeric levels correctly", { - input <- factor(c(0, 1, 1, 2)) +# context("asNumericDS::smk::factor numeric levels vector") +test_that("factor numeric levels vector asNumericDS", { + vec <- c("aa", "bb", "cc", "dd", "ee") + input <- as.factor(vec) + levels(input) <- c("11", "22", "33", "44", "55") - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_equal(class(res), "numeric") - expect_equal(res, c(0, 1, 1, 2)) + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 11) + expect_equal(res[2], 22) + expect_equal(res[3], 33) + expect_equal(res[4], 44) + expect_equal(res[5], 55) }) -test_that("asNumericDS coerces character with numeric strings correctly", { - input <- c("1", "2", "3") +# context("asNumericDS::smk::factor vector with only numbers in its values") +test_that("factor vector with only numbers in its values asNumericDS", { + input <- as.factor(c('1','1','2','2','1')) - res <- asNumericDS("input") + res <- asNumericDS("input") - expect_equal(class(res), "numeric") - expect_equal(res, c(1, 2, 3)) + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 2) + expect_equal(res[5], 1) }) +# context("asNumericDS::smk::factor vector with only characters in its values") +test_that("factor vector with only characters in its values asNumericDS", { + input <- as.factor(c('b','b','a','a','b')) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 2) + expect_equal(res[2], 2) + expect_equal(res[3], 1) + expect_equal(res[4], 1) + expect_equal(res[5], 2) +}) + +# context("asNumericDS::smk::character vector with only numbers in its values") +test_that("factor vector with only numbers in its values asNumericDS", { + input <- c('1','1','2','2','1') + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 2) + expect_equal(res[5], 1) +}) + +# context("asNumericDS::smk::character vector with only characters in its values") +test_that("character vector with only characters in its values asNumericDS", { + input <- c('b','b','a','a','b') + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 2) + expect_equal(res[2], 2) + expect_equal(res[3], 1) + expect_equal(res[4], 1) + expect_equal(res[5], 2) +}) + +# context("asNumericDS::smk::character vector with strings having characters and numbers") +test_that("character vector with strings having characters and numbers asNumericDS", { + input <- c('b1','b2','1a','a','b') + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 4) + expect_equal(res[2], 5) + expect_equal(res[3], 1) + expect_equal(res[4], 2) + expect_equal(res[5], 3) +}) + +# context("asNumericDS::smk::logical vector") +test_that("logical vector asNumericDS", { + input <- c(TRUE, TRUE, FALSE, TRUE) + + res <- asNumericDS("input") + + expect_length(res, 4) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 0) + expect_equal(res[4], 1) +}) + +# context("asNumericDS::smk::logical character vector") +test_that("logical vector character asNumericDS", { + input <- c("TRUE", "TRUE", "FALSE", "TRUE") + + res <- asNumericDS("input") + + expect_length(res, 4) + expect_equal(class(res), "numeric") + expect_equal(res[1], 2) + expect_equal(res[2], 2) + expect_equal(res[3], 1) + expect_equal(res[4], 2) +}) + +# context("asNumericDS::smk::integer vector") +test_that("integer vector asNumericDS", { + input <- as.integer(c('1','1','2','2','1')) + + res <- asNumericDS("input") + + expect_length(res, 5) + expect_equal(class(res), "numeric") + expect_equal(res[1], 1) + expect_equal(res[2], 1) + expect_equal(res[3], 2) + expect_equal(res[4], 2) + expect_equal(res[5], 1) +}) + +# context("asNumericDS::smk::error") test_that("asNumericDS throws error when object does not exist", { - expect_error( - asNumericDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + asNumericDS("nonexistent_object"), + regexp = "does not exist" + ) }) + +# +# Done +# + +# context("asNumericDS::smk::shutdown") + +# context("asNumericDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R index ac1268db..4f4aca8c 100644 --- a/tests/testthat/test-smk-expDS.R +++ b/tests/testthat/test-smk-expDS.R @@ -1,31 +1,63 @@ +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("expDS::smk::setup") + +# +# Tests +# + +# context("expDS::smk::numeric") test_that("expDS computes exponential for numeric vector", { - input <- c(0.0, 1.0, 2.0, -1.0) + input <- c(0.0, 1.0, 2.0, -1.0) - res <- expDS("input") + res <- expDS("input") - expect_equal(res, exp(input)) - expect_true(is.numeric(res)) + expect_equal(res, exp(input)) + expect_true(is.numeric(res)) }) +# context("expDS::smk::integer") test_that("expDS computes exponential for integer vector", { - input <- as.integer(c(0, 1, 2, 3)) + input <- as.integer(c(0, 1, 2, 3)) - res <- expDS("input") + res <- expDS("input") - expect_equal(res, exp(input)) + expect_equal(res, exp(input)) }) +# context("expDS::smk::error") test_that("expDS throws error when object does not exist", { - expect_error( - expDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + expDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("expDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - expDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + expDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# Done +# + +# context("expDS::smk::shutdown") + +# context("expDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-logDS.R b/tests/testthat/test-smk-logDS.R index 8e762fbc..01b18d01 100644 --- a/tests/testthat/test-smk-logDS.R +++ b/tests/testthat/test-smk-logDS.R @@ -1,39 +1,71 @@ +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("logDS::smk::setup") + +# +# Tests +# + +# context("logDS::smk::numeric") test_that("logDS computes natural log for numeric vector", { - input <- c(1.0, exp(1), exp(2)) + input <- c(1.0, exp(1), exp(2)) - res <- logDS("input") + res <- logDS("input") - expect_equal(res, log(input)) - expect_true(is.numeric(res)) + expect_equal(res, log(input)) + expect_true(is.numeric(res)) }) test_that("logDS computes log with custom base", { - input <- c(1.0, 10.0, 100.0) + input <- c(1.0, 10.0, 100.0) - res <- logDS("input", base = 10) + res <- logDS("input", base = 10) - expect_equal(res, log(input, base = 10)) + expect_equal(res, log(input, base = 10)) }) +# context("logDS::smk::integer") test_that("logDS computes log for integer vector", { - input <- as.integer(c(1, 2, 3, 4)) + input <- as.integer(c(1, 2, 3, 4)) - res <- logDS("input") + res <- logDS("input") - expect_equal(res, log(input)) + expect_equal(res, log(input)) }) +# context("logDS::smk::error") test_that("logDS throws error when object does not exist", { - expect_error( - logDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + logDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("logDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - logDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + logDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# Done +# + +# context("logDS::smk::shutdown") + +# context("logDS::smk::done") \ No newline at end of file diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index f45301c5..a7aa3641 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -1,31 +1,188 @@ -test_that("sqrtDS computes square root for numeric vector", { - input <- c(4.0, 9.0, 16.0, 25.0) +#------------------------------------------------------------------------------- +# 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. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +#------------------------------------------------------------------------------- - res <- sqrtDS("input") +# +# Set up +# - expect_equal(res, sqrt(input)) - expect_true(is.numeric(res)) +# context("sqrtDS::smk::setup") + +# +# Tests +# + +# context("sqrtDS::smk::special") +test_that("simple sqrtDS, NA", { + input <- NA + + expect_error(sqrtDS("input"), regexp = "must be of type") +}) + +test_that("simple sqrtDS, NaN", { + input <- NaN + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +test_that("simple sqrtDS, Inf", { + input <- Inf + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.infinite(res)) +}) + +test_that("simple sqrtDS, -Inf", { + input <- -Inf + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +# context("sqrtDS::smk::numeric") +test_that("simple sqrtDS, numeric 0.0", { + input <- 0.0 + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 0.0) +}) + +test_that("simple sqrtDS, numeric 10.0", { + input <- 10.0 + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 3.16227766, tolerance = 1e-8) +}) + +test_that("simple sqrtDS, numeric -10.0", { + input <- -10.0 + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) }) -test_that("sqrtDS computes square root for integer vector", { - input <- as.integer(c(1, 4, 9, 16)) +# context("sqrtDS::smk::integer") +test_that("simple sqrtDS, integer 0L", { + input <- 0L - res <- sqrtDS("input") + res <- sqrtDS("input") - expect_equal(res, sqrt(input)) + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 0L) }) +test_that("simple sqrtDS, integer 10L", { + input <- 10L + + res <- sqrtDS("input") + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_equal(res, 3.16227766, tolerance = 1e-8) +}) + +test_that("simple sqrtDS, integer -10L", { + input <- -10L + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 1) + expect_true(is.nan(res)) +}) + +# context("sqrtDS::smk::special vector") +test_that("simple sqrtDS", { + input <- c(NA, NaN, Inf, -Inf) + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 4) + expect_true(is.na(res[1])) + expect_true(is.infinite(res[3])) + expect_true(is.nan(res[4])) +}) + +# context("sqrtDS::smk::numeric vector") +test_that("simple sqrtDS", { + input <- c(0.0, 4.0, 9.0, -10.0, -50.0, -20.0) + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 6) + expect_equal(res[1], 0.0, tolerance = 1e-8) + expect_equal(res[2], 2.0, tolerance = 1e-8) + expect_equal(res[3], 3.0, tolerance = 1e-8) + expect_true(is.nan(res[4])) + expect_true(is.nan(res[5])) + expect_true(is.nan(res[6])) +}) + +# context("sqrtDS::smk::integer vector") +test_that("simple sqrtDS", { + input <- c(0L, 4L, 9L, -10L, -50L, -20L) + + expect_warning(res <- sqrtDS("input"), "NaNs produced", fixed = TRUE) + + expect_equal(class(res), "numeric") + expect_length(res, 6) + expect_equal(res[1], 0.0, tolerance = 1e-8) + expect_equal(res[2], 2.0, tolerance = 1e-8) + expect_equal(res[3], 3.0, tolerance = 1e-8) + expect_true(is.nan(res[4])) + expect_true(is.nan(res[5])) + expect_true(is.nan(res[6])) +}) + +# context("sqrtDS::smk::error") test_that("sqrtDS throws error when object does not exist", { - expect_error( - sqrtDS("nonexistent_object"), - regexp = "does not exist" - ) + expect_error( + sqrtDS("nonexistent_object"), + regexp = "does not exist" + ) }) test_that("sqrtDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - sqrtDS("bad_input"), - regexp = "must be of type" - ) + bad_input <- c("a", "b", "c") + expect_error( + sqrtDS("bad_input"), + regexp = "must be of type" + ) }) + +# +# Done +# + +# context("sqrtDS::smk::shutdown") + +# context("sqrtDS::smk::done") \ No newline at end of file From 91f997dbf0570bbd5eb8f923efb913cd19d91f79 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 13 Mar 2026 11:46:21 +0100 Subject: [PATCH 38/65] Revert whitespace-only changes and fix test assertions --- DESCRIPTION | 2 +- R/asIntegerDS.R | 2 +- R/asNumericDS.R | 10 +++--- R/sqrtDS.R | 2 +- man/sqrtDS.Rd | 2 +- tests/testthat/test-smk-absDS.R | 2 +- tests/testthat/test-smk-asCharacterDS.R | 2 +- tests/testthat/test-smk-asDataMatrixDS.R | 4 +-- tests/testthat/test-smk-asFactorSimpleDS.R | 2 +- tests/testthat/test-smk-asIntegerDS.R | 2 +- tests/testthat/test-smk-asListDS.R | 2 +- tests/testthat/test-smk-asLogicalDS.R | 2 +- tests/testthat/test-smk-asMatrixDS.R | 4 +-- tests/testthat/test-smk-asNumericDS.R | 42 +++++++++++----------- tests/testthat/test-smk-sqrtDS.R | 2 +- 15 files changed, 41 insertions(+), 41 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2f81906c..a6737e2e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -71,7 +71,7 @@ Imports: gamlss, gamlss.dist, mice, - childsds, + childsds, glue Suggests: spelling, diff --git a/R/asIntegerDS.R b/R/asIntegerDS.R index dc8d320e..b982ed88 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -1,4 +1,4 @@ -#' +#' #' @title Coerces an R object into class integer #' @description This function is based on the native R function \code{as.integer}. #' @details See help for function \code{as.integer} in native R, and details section diff --git a/R/asNumericDS.R b/R/asNumericDS.R index 307d9679..17b9fd34 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -1,4 +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.numeric} in native R, and details section @@ -15,12 +15,12 @@ #' asNumericDS <- function(x.name){ x <- .loadServersideObject(x.name) - + # Check that it doesn't match any non-number numbers_only <- function(vec) !grepl("\\D", vec) - + logical <- numbers_only(x) - + if((is.factor(x) & any(logical==FALSE)==FALSE) | (is.character(x) & any(logical==FALSE)==FALSE)){ output <- as.numeric(as.character(x)) }else if((is.factor(x) & any(logical==FALSE)==TRUE) | (is.character(x) & any(logical==FALSE)==TRUE)){ @@ -28,7 +28,7 @@ asNumericDS <- function(x.name){ }else{ output <- as.numeric(x) } - + return(output) } # ASSIGN FUNCTION diff --git a/R/sqrtDS.R b/R/sqrtDS.R index aa561ccc..7643a532 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -6,7 +6,7 @@ #' @param x a string character, the name of a numeric or integer vector #' @return the object specified by the \code{newobj} argument #' of \code{ds.sqrt} (or default name \code{sqrt.newobj}) -#' which is written to the server-side. The output object is of class numeric +#' which is written to the server-side. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team #' @export diff --git a/man/sqrtDS.Rd b/man/sqrtDS.Rd index a552a4f1..79f044a0 100644 --- a/man/sqrtDS.Rd +++ b/man/sqrtDS.Rd @@ -12,7 +12,7 @@ sqrtDS(x) \value{ the object specified by the \code{newobj} argument of \code{ds.sqrt} (or default name \code{sqrt.newobj}) -which is written to the server-side. The output object is of class numeric +which is written to the server-side. The output object is of class numeric or integer. } \description{ diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index af56c36d..8413bb15 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -186,4 +186,4 @@ test_that("absDS throws error when object is not numeric or integer", { # context("absDS::smk::shutdown") -# context("absDS::smk::done") \ No newline at end of file +# context("absDS::smk::done") diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index 6d615e77..1465f0f2 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -95,4 +95,4 @@ test_that("asCharacterDS throws error when object does not exist", { # context("asCharacterDS::smk::shutdown") -# context("asCharacterDS::smk::done") \ No newline at end of file +# context("asCharacterDS::smk::done") diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index f5b3d70c..90bd5e4d 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -51,7 +51,7 @@ test_that("simple asDataMatrixDS", { expect_equal(res[10], 0) res.colnames <- colnames(res) - expect_length(res.colnames, 2) + expect_length(res.colnames, 2) expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) @@ -70,4 +70,4 @@ test_that("asDataMatrixDS throws error when object does not exist", { # context("asDataMatrixDS::smk::shutdown") -# context("asDataMatrixDS::smk::done") \ No newline at end of file +# context("asDataMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 7d553685..49193900 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -71,4 +71,4 @@ test_that("asFactorSimpleDS throws error when object is not numeric or character # context("asFactorSimpleDS::smk::shutdown") -# context("asFactorSimpleDS::smk::done") \ No newline at end of file +# context("asFactorSimpleDS::smk::done") diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 3517ea76..8417a8f5 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -85,4 +85,4 @@ test_that("asIntegerDS throws error when object does not exist", { # context("asIntegerDS::smk::shutdown") -# context("asIntegerDS::smk::done") \ No newline at end of file +# context("asIntegerDS::smk::done") diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index 842f84d9..f220dc63 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -47,4 +47,4 @@ test_that("asListDS throws error when object does not exist", { # context("asListDS::smk::shutdown") -# context("asListDS::smk::done") \ No newline at end of file +# context("asListDS::smk::done") diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 02c6fce2..53fcba85 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -181,4 +181,4 @@ test_that("asLogicalDS throws error when object does not exist", { # context("asLogicalDS::smk::shutdown") -# context("asLogicalDS::smk::done") \ No newline at end of file +# context("asLogicalDS::smk::done") diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index 96fc386a..f5d5720c 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -51,7 +51,7 @@ test_that("simple asMatrixDS", { expect_equal(res[10], 0) res.colnames <- colnames(res) - expect_length(res.colnames, 2) + expect_length(res.colnames, 2) expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) @@ -70,4 +70,4 @@ test_that("asMatrixDS throws error when object does not exist", { # context("asMatrixDS::smk::shutdown") -# context("asMatrixDS::smk::done") \ No newline at end of file +# context("asMatrixDS::smk::done") diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index 427c4ae6..3803e805 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -96,7 +96,7 @@ test_that("factor vector asNumericDS", { test_that("factor numeric levels vector asNumericDS", { vec <- c("aa", "bb", "cc", "dd", "ee") input <- as.factor(vec) - levels(input) <- c("11", "22", "33", "44", "55") + levels(input) <- c("11", "22", "33", "44", "55") res <- asNumericDS("input") @@ -111,10 +111,10 @@ test_that("factor numeric levels vector asNumericDS", { # context("asNumericDS::smk::factor vector with only numbers in its values") test_that("factor vector with only numbers in its values asNumericDS", { - input <- as.factor(c('1','1','2','2','1')) - + input <- as.factor(c('1','1','2','2','1')) + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -126,10 +126,10 @@ test_that("factor vector with only numbers in its values asNumericDS", { # context("asNumericDS::smk::factor vector with only characters in its values") test_that("factor vector with only characters in its values asNumericDS", { - input <- as.factor(c('b','b','a','a','b')) - + input <- as.factor(c('b','b','a','a','b')) + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 2) @@ -142,9 +142,9 @@ test_that("factor vector with only characters in its values asNumericDS", { # context("asNumericDS::smk::character vector with only numbers in its values") test_that("factor vector with only numbers in its values asNumericDS", { input <- c('1','1','2','2','1') - + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -157,9 +157,9 @@ test_that("factor vector with only numbers in its values asNumericDS", { # context("asNumericDS::smk::character vector with only characters in its values") test_that("character vector with only characters in its values asNumericDS", { input <- c('b','b','a','a','b') - + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 2) @@ -172,9 +172,9 @@ test_that("character vector with only characters in its values asNumericDS", { # context("asNumericDS::smk::character vector with strings having characters and numbers") test_that("character vector with strings having characters and numbers asNumericDS", { input <- c('b1','b2','1a','a','b') - + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 4) @@ -187,9 +187,9 @@ test_that("character vector with strings having characters and numbers asNumeric # context("asNumericDS::smk::logical vector") test_that("logical vector asNumericDS", { input <- c(TRUE, TRUE, FALSE, TRUE) - + res <- asNumericDS("input") - + expect_length(res, 4) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -201,9 +201,9 @@ test_that("logical vector asNumericDS", { # context("asNumericDS::smk::logical character vector") test_that("logical vector character asNumericDS", { input <- c("TRUE", "TRUE", "FALSE", "TRUE") - + res <- asNumericDS("input") - + expect_length(res, 4) expect_equal(class(res), "numeric") expect_equal(res[1], 2) @@ -214,10 +214,10 @@ test_that("logical vector character asNumericDS", { # context("asNumericDS::smk::integer vector") test_that("integer vector asNumericDS", { - input <- as.integer(c('1','1','2','2','1')) - + input <- as.integer(c('1','1','2','2','1')) + res <- asNumericDS("input") - + expect_length(res, 5) expect_equal(class(res), "numeric") expect_equal(res[1], 1) @@ -241,4 +241,4 @@ test_that("asNumericDS throws error when object does not exist", { # context("asNumericDS::smk::shutdown") -# context("asNumericDS::smk::done") \ No newline at end of file +# context("asNumericDS::smk::done") diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index a7aa3641..30904237 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -185,4 +185,4 @@ test_that("sqrtDS throws error when object is not numeric or integer", { # context("sqrtDS::smk::shutdown") -# context("sqrtDS::smk::done") \ No newline at end of file +# context("sqrtDS::smk::done") From 4d2d6183ad69af1911bec93ad573b2ac3777d17e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 13:13:38 +0100 Subject: [PATCH 39/65] refactor: make column extraction clearer --- R/utils.R | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/R/utils.R b/R/utils.R index 03575700..84358dea 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,29 +1,36 @@ #' Load a Server-Side Object by Name #' -#' Retrieves a server-side object using `get()`, supporting both simple names -#' (e.g. "D") and column access syntax (e.g. "D$LAB_TSC"). +#' Retrieves a server-side object using `get()`. Supports both simple object +#' names (e.g. "D") and `$` column access (e.g. "D$LAB_TSC"). When `$` is +#' present, the object is retrieved first, then the named column is extracted +#' using `[[`. #' #' @param x A character string naming the object, optionally with "$column" syntax. -#' @return The retrieved R object. +#' @return The retrieved R object, or the specified column if `$` syntax is used. #' @noRd .loadServersideObject <- function(x) { env <- parent.frame(2) - parts <- unlist(strsplit(x, "$", fixed = TRUE)) - obj_name <- parts[1] - has_column <- length(parts) > 1 + hasColumn <- grepl("$", x, fixed = TRUE) + + if(hasColumn) { + parts <- unlist(strsplit(x, "$", fixed = TRUE)) + obj_name <- parts[1] + col_name <- parts[2] + } else { + obj_name <- x + } obj <- tryCatch( get(obj_name, envir = env), error = function(e) stop("The server-side object '", x, "' does not exist") ) - if (has_column) { - column_name <- parts[2] - obj <- obj[[column_name]] + if (hasColumn) { + obj <- obj[[col_name]] } - obj + return(obj) } #' Check Class of a Server-Side Object From b8010872f000b80276367c7452d41f0956b826de Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 14:44:27 +0100 Subject: [PATCH 40/65] added error handling for missing columns --- R/utils.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/R/utils.R b/R/utils.R index 84358dea..91fa3844 100644 --- a/R/utils.R +++ b/R/utils.R @@ -28,6 +28,9 @@ if (hasColumn) { obj <- obj[[col_name]] + if (is.null(obj)) { + stop("Column '", col_name, "' not found in '", obj_name, "'", call. = FALSE) + } } return(obj) From f6f6b0d4659f1020d258b1b51f65d260391edada Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 14:44:41 +0100 Subject: [PATCH 41/65] test: removed redundant checks --- tests/testthat/test-smk-absDS.R | 23 ----------------------- tests/testthat/test-smk-asCharacterDS.R | 8 -------- tests/testthat/test-smk-asDataMatrixDS.R | 9 --------- tests/testthat/test-smk-asIntegerDS.R | 9 --------- tests/testthat/test-smk-asListDS.R | 9 --------- tests/testthat/test-smk-asLogicalDS.R | 9 --------- tests/testthat/test-smk-asMatrixDS.R | 9 --------- tests/testthat/test-smk-asNumericDS.R | 9 --------- tests/testthat/test-smk-expDS.R | 17 ----------------- tests/testthat/test-smk-logDS.R | 17 ----------------- tests/testthat/test-smk-sqrtDS.R | 23 ----------------------- tests/testthat/test-smk-utils.R | 16 +++++++++++++++- 12 files changed, 15 insertions(+), 143 deletions(-) diff --git a/tests/testthat/test-smk-absDS.R b/tests/testthat/test-smk-absDS.R index 8413bb15..6b2f9a76 100644 --- a/tests/testthat/test-smk-absDS.R +++ b/tests/testthat/test-smk-absDS.R @@ -20,12 +20,6 @@ # # context("absDS::smk::special") -test_that("simple absDS, NA", { - input <- NA - - expect_error(absDS("input"), regexp = "must be of type") -}) - test_that("simple absDS, NaN", { input <- NaN @@ -163,23 +157,6 @@ test_that("simple absDS", { expect_equal(res[5], 50L) expect_equal(res[6], 20L) }) - -# context("absDS::smk::error") -test_that("absDS throws error when object does not exist", { - expect_error( - absDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("absDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - absDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asCharacterDS.R b/tests/testthat/test-smk-asCharacterDS.R index 1465f0f2..40cdaf73 100644 --- a/tests/testthat/test-smk-asCharacterDS.R +++ b/tests/testthat/test-smk-asCharacterDS.R @@ -81,14 +81,6 @@ test_that("logical vector asCharacterDS", { expect_equal(res[5], "TRUE") }) -# context("asCharacterDS::smk::error") -test_that("asCharacterDS throws error when object does not exist", { - expect_error( - asCharacterDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asDataMatrixDS.R b/tests/testthat/test-smk-asDataMatrixDS.R index 90bd5e4d..6529b1ab 100644 --- a/tests/testthat/test-smk-asDataMatrixDS.R +++ b/tests/testthat/test-smk-asDataMatrixDS.R @@ -55,15 +55,6 @@ test_that("simple asDataMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - -# context("asDataMatrixDS::smk::error") -test_that("asDataMatrixDS throws error when object does not exist", { - expect_error( - asDataMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asIntegerDS.R b/tests/testthat/test-smk-asIntegerDS.R index 8417a8f5..1fc8445b 100644 --- a/tests/testthat/test-smk-asIntegerDS.R +++ b/tests/testthat/test-smk-asIntegerDS.R @@ -70,15 +70,6 @@ test_that("character vector asIntegerDS", { expect_equal(res[4], 404) expect_equal(res[5], 505) }) - -# context("asIntegerDS::smk::error") -test_that("asIntegerDS throws error when object does not exist", { - expect_error( - asIntegerDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asListDS.R b/tests/testthat/test-smk-asListDS.R index f220dc63..1ac8ac68 100644 --- a/tests/testthat/test-smk-asListDS.R +++ b/tests/testthat/test-smk-asListDS.R @@ -32,15 +32,6 @@ test_that("simple asListDS", { expect_equal(class(newobj), "list") expect_length(newobj, 2) }) - -# context("asListDS::smk::error") -test_that("asListDS throws error when object does not exist", { - expect_error( - asListDS("nonexistent_object", "test_output"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asLogicalDS.R b/tests/testthat/test-smk-asLogicalDS.R index 53fcba85..41ef866e 100644 --- a/tests/testthat/test-smk-asLogicalDS.R +++ b/tests/testthat/test-smk-asLogicalDS.R @@ -166,15 +166,6 @@ test_that("simple asLogicalDS, character vector", { expect_equal(res[5], FALSE) expect_equal(res[6], FALSE) }) - -# context("asLogicalDS::smk::error") -test_that("asLogicalDS throws error when object does not exist", { - expect_error( - asLogicalDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asMatrixDS.R b/tests/testthat/test-smk-asMatrixDS.R index f5d5720c..ba759e27 100644 --- a/tests/testthat/test-smk-asMatrixDS.R +++ b/tests/testthat/test-smk-asMatrixDS.R @@ -55,15 +55,6 @@ test_that("simple asMatrixDS", { expect_equal(res.colnames[1], "v1") expect_equal(res.colnames[2], "v2") }) - -# context("asMatrixDS::smk::error") -test_that("asMatrixDS throws error when object does not exist", { - expect_error( - asMatrixDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-asNumericDS.R b/tests/testthat/test-smk-asNumericDS.R index 3803e805..4ace90f5 100644 --- a/tests/testthat/test-smk-asNumericDS.R +++ b/tests/testthat/test-smk-asNumericDS.R @@ -226,15 +226,6 @@ test_that("integer vector asNumericDS", { expect_equal(res[4], 2) expect_equal(res[5], 1) }) - -# context("asNumericDS::smk::error") -test_that("asNumericDS throws error when object does not exist", { - expect_error( - asNumericDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-expDS.R b/tests/testthat/test-smk-expDS.R index 4f4aca8c..4c359470 100644 --- a/tests/testthat/test-smk-expDS.R +++ b/tests/testthat/test-smk-expDS.R @@ -37,23 +37,6 @@ test_that("expDS computes exponential for integer vector", { expect_equal(res, exp(input)) }) - -# context("expDS::smk::error") -test_that("expDS throws error when object does not exist", { - expect_error( - expDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("expDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - expDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-logDS.R b/tests/testthat/test-smk-logDS.R index 01b18d01..d56ea1c9 100644 --- a/tests/testthat/test-smk-logDS.R +++ b/tests/testthat/test-smk-logDS.R @@ -45,23 +45,6 @@ test_that("logDS computes log for integer vector", { expect_equal(res, log(input)) }) - -# context("logDS::smk::error") -test_that("logDS throws error when object does not exist", { - expect_error( - logDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("logDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - logDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-sqrtDS.R b/tests/testthat/test-smk-sqrtDS.R index 30904237..273baec1 100644 --- a/tests/testthat/test-smk-sqrtDS.R +++ b/tests/testthat/test-smk-sqrtDS.R @@ -20,12 +20,6 @@ # # context("sqrtDS::smk::special") -test_that("simple sqrtDS, NA", { - input <- NA - - expect_error(sqrtDS("input"), regexp = "must be of type") -}) - test_that("simple sqrtDS, NaN", { input <- NaN @@ -162,23 +156,6 @@ test_that("simple sqrtDS", { expect_true(is.nan(res[5])) expect_true(is.nan(res[6])) }) - -# context("sqrtDS::smk::error") -test_that("sqrtDS throws error when object does not exist", { - expect_error( - sqrtDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("sqrtDS throws error when object is not numeric or integer", { - bad_input <- c("a", "b", "c") - expect_error( - sqrtDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # diff --git a/tests/testthat/test-smk-utils.R b/tests/testthat/test-smk-utils.R index 2bb2db76..131454e1 100644 --- a/tests/testthat/test-smk-utils.R +++ b/tests/testthat/test-smk-utils.R @@ -27,9 +27,23 @@ test_that(".loadServersideObject() returns existing object", { expect_identical(result, test_df) }) +test_that(".loadServersideObject() extracts column with $ syntax", { + test_df <- data.frame(a = 1:3, b = 4:6) + result <- .dsFunctionWrapper("test_df$b") + expect_identical(result, 4:6) +}) + +test_that(".loadServersideObject() throws error for nonexistent column", { + test_df <- data.frame(a = 1:3) + expect_error( + .dsFunctionWrapper("test_df$nonexistent"), + regexp = "Column 'nonexistent' not found in 'test_df'" + ) +}) + test_that(".loadServersideObject() throws error for missing object", { expect_error( - .dsFunctionWrapper("test_df"), + .dsFunctionWrapper("no_such_object"), regexp = "does not exist" ) }) From e3c1f927a03d5abe1dc32f471c1282a301196eb5 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 16 Mar 2026 14:54:19 +0100 Subject: [PATCH 42/65] revert: shouldn't have touched these files --- R/asFactorSimpleDS.R | 8 ++----- tests/testthat/test-smk-asFactorSimpleDS.R | 25 ++++------------------ 2 files changed, 6 insertions(+), 27 deletions(-) diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index f6aad651..80a14b27 100644 --- a/R/asFactorSimpleDS.R +++ b/R/asFactorSimpleDS.R @@ -16,12 +16,7 @@ #' asFactorSimpleDS <- function(input.var.name=NULL){ - input.var <- .loadServersideObject(input.var.name) - .checkClass( - obj = input.var, - obj_name = input.var.name, - permitted_classes = c("numeric", "integer", "character", "factor") - ) + input.var <- eval(parse(text=input.var.name), envir = parent.frame()) factor.obj <- factor(input.var) @@ -32,3 +27,4 @@ asFactorSimpleDS <- function(input.var.name=NULL){ #ASSIGN FUNCTION # asFactorSimpleDS + diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 49193900..bafe51b3 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -1,6 +1,5 @@ #------------------------------------------------------------------------------- # 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. @@ -13,7 +12,7 @@ # Set up # -# context("asFactorSimpleDS::smk::setup") +context("asFactorSimpleDS::smk::setup") set.standard.disclosure.settings() @@ -21,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -# context("asFactorSimpleDS::smk::simple") +context("asFactorSimpleDS::smk::simple") test_that("simple asFactorSimpleDS", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -49,26 +48,10 @@ test_that("simple asFactorSimpleDS", { expect_equal(res.levels[3], "3") }) -# context("asFactorSimpleDS::smk::error") -test_that("asFactorSimpleDS throws error when object does not exist", { - expect_error( - asFactorSimpleDS("nonexistent_object"), - regexp = "does not exist" - ) -}) - -test_that("asFactorSimpleDS throws error when object is not numeric or character", { - bad_input <- list(a = 1, b = 2) - expect_error( - asFactorSimpleDS("bad_input"), - regexp = "must be of type" - ) -}) - # # Done # -# context("asFactorSimpleDS::smk::shutdown") +context("asFactorSimpleDS::smk::shutdown") -# context("asFactorSimpleDS::smk::done") +context("asFactorSimpleDS::smk::done") From c6211ae4eec53ea1883efcb489d6d34b17c49a28 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 12:31:13 +0100 Subject: [PATCH 43/65] test: updated test expectations to fit changed message --- tests/testthat/test-arg-asIntegerDS.R | 2 +- tests/testthat/test-arg-asLogicalDS.R | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-arg-asIntegerDS.R b/tests/testthat/test-arg-asIntegerDS.R index c2ebd028..a3635bfd 100644 --- a/tests/testthat/test-arg-asIntegerDS.R +++ b/tests/testthat/test-arg-asIntegerDS.R @@ -20,7 +20,7 @@ # 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) + expect_error(asIntegerDS(1.0), "The input must be a single character string", fixed = TRUE) }) # diff --git a/tests/testthat/test-arg-asLogicalDS.R b/tests/testthat/test-arg-asLogicalDS.R index 33159504..d778e010 100644 --- a/tests/testthat/test-arg-asLogicalDS.R +++ b/tests/testthat/test-arg-asLogicalDS.R @@ -21,21 +21,21 @@ # 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) + expect_error(asLogicalDS(1.0), "The input must be a single character string", fixed = TRUE) }) # 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) + expect_error(asLogicalDS("input"), "The server-side object must be of type numeric, integer, character or matrix. 'input' is type NULL.", fixed = TRUE) }) # context("asLogicalDS::arg::input NA") test_that("simple asLogicalDS NA", { input <- NA - 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) + expect_error(asLogicalDS("input"), "The server-side object must be of type numeric, integer, character or matrix. 'input' is type logical.", fixed = TRUE) }) # From 433af424bc832bb08a9e2b93f34bd5c75eaad0d3 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:24:07 +0100 Subject: [PATCH 44/65] test: added performance profile| --- tests/testthat/perf_files/performance_refactor_profile.csv | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 tests/testthat/perf_files/performance_refactor_profile.csv diff --git a/tests/testthat/perf_files/performance_refactor_profile.csv b/tests/testthat/perf_files/performance_refactor_profile.csv new file mode 100644 index 00000000..ab12f3e8 --- /dev/null +++ b/tests/testthat/perf_files/performance_refactor_profile.csv @@ -0,0 +1,5 @@ +"refer_name","rate","lower_tolerance","upper_tolerance" +"meanDS::perf::numeric::0","11557.1204746495","0.5","10000" +"meanDS::perf::numberAndNA::0","11718.8520447749","0.5","10000" +"varDS::perf::numeric::0","12758.5511531009","0.5","10000" +"varDS::perf::numberAndNA::0","12545.8819532662","0.5","10000" From 9facea0c0dc5b87623ecdd670ad92b96657b20a2 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:29:34 +0100 Subject: [PATCH 45/65] added PR template to buildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index 26e4d4d4..4b349a88 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,3 +12,4 @@ ^\.github$ ^cran-comments\.md$ ^pull_request_template$ +PULL_REQUEST_TEMPLATE.md From bd188560d03cca35e1b1d1122625c58f46d76c80 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:31:12 +0100 Subject: [PATCH 46/65] feat: validate input type in .loadServersideObject --- R/utils.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/utils.R b/R/utils.R index 91fa3844..b96d8735 100644 --- a/R/utils.R +++ b/R/utils.R @@ -9,6 +9,10 @@ #' @return The retrieved R object, or the specified column if `$` syntax is used. #' @noRd .loadServersideObject <- function(x) { + if (!is.character(x) || length(x) != 1) { + stop("The input must be a single character string", call. = FALSE) + } + env <- parent.frame(2) hasColumn <- grepl("$", x, fixed = TRUE) From 0c59ba95c9fe10bed8127cd631972189237efaab Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:31:39 +0100 Subject: [PATCH 47/65] refactor: make perf test tolerances configurable via profile --- tests/testthat/perf_tests/README.md | 48 +++++++++++++++++++++++++++ tests/testthat/perf_tests/perf_rate.R | 16 ++++++++- tests/testthat/setup.R | 1 + tests/testthat/test-perf-meanDS.R | 8 ++--- tests/testthat/test-perf-varDS.R | 8 ++--- 5 files changed, 72 insertions(+), 9 deletions(-) create mode 100644 tests/testthat/perf_tests/README.md diff --git a/tests/testthat/perf_tests/README.md b/tests/testthat/perf_tests/README.md new file mode 100644 index 00000000..33dac773 --- /dev/null +++ b/tests/testthat/perf_tests/README.md @@ -0,0 +1,48 @@ +# Performance Tests + +Performance tests measure the throughput (operations per second) of server-side functions and compare against baseline rates stored in profile CSV files. + +## How it works + +Each performance test: + +1. Runs a function in a loop for 30 seconds and calculates the current rate (ops/sec). +2. Looks up the baseline rate for that test in the active profile CSV. +3. If no entry exists, a new one is saved to the profile using the current rate and the profile-level default tolerances. +4. Asserts that the current rate falls within `[baseline * lower_tolerance, baseline * upper_tolerance]`. + +## Profiles + +Profile CSVs live in `perf_files/` and contain columns: + +| Column | Description | +|--------|-------------| +| `refer_name` | Unique test identifier (e.g. `meanDS::perf::numeric::0`) | +| `rate` | Baseline ops/sec | +| `lower_tolerance` | Multiplier for the lower bound (e.g. `0.5` = 50% of baseline) | +| `upper_tolerance` | Multiplier for the upper bound (e.g. `2.0` = 200% of baseline) | + +Available profiles: + +- `default_perf_profile.csv` -- default baseline +- `performance_refactor_profile.csv` -- for local development; no effective upper limit +- `azure-pipeline.csv`, `circleci.csv` -- CI-specific baselines + +## Switching profiles + +Set `.perf.reference.filename` in `setup.R` before sourcing `perf_rate.R`: + +```r +.perf.reference.filename <- "perf_files/performance_refactor_profile.csv" +source("perf_tests/perf_rate.R") +``` + +If not set, `perf_rate.R` defaults to `perf_files/default_perf_profile.csv`. + +## Self-populating entries + +When a test has no entry in the active profile, `perf.reference.save()` creates one using the current measured rate and the profile-level tolerances (`perf.profile.tolerance.lower/upper()`), which are read from the first row of the profile CSV. This means new tests automatically inherit the tolerance policy of whichever profile is active. + +## Skipping + +Performance tests are skipped on CRAN (`skip_on_cran()`) and CI (`skip_on_ci()`) by default, since results are hardware-dependent. diff --git a/tests/testthat/perf_tests/perf_rate.R b/tests/testthat/perf_tests/perf_rate.R index 1884cda8..584de1b0 100644 --- a/tests/testthat/perf_tests/perf_rate.R +++ b/tests/testthat/perf_tests/perf_rate.R @@ -8,7 +8,7 @@ # along with this program. If not, see . #------------------------------------------------------------------------------- -.perf.reference.filename <- 'perf_files/default_perf_profile.csv' +.perf.reference.filename <- getOption("perf.profile", "perf_files/default_perf_profile.csv") .perf.reference <- NULL @@ -16,6 +16,20 @@ .perf.reference <<- read.csv(.perf.reference.filename, header = TRUE, sep = ",") } +perf.profile.tolerance.lower <- function() { + if (is.null(.perf.reference)) + .load.pref() + + return(as.numeric(.perf.reference$lower_tolerance[1])) +} + +perf.profile.tolerance.upper <- function() { + if (is.null(.perf.reference)) + .load.pref() + + return(as.numeric(.perf.reference$upper_tolerance[1])) +} + perf.reference.save <- function(perf.ref.name, rate, tolerance.lower, tolerance.upper) { if (is.null(.perf.reference)) load.pref() diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index c3e6b288..b5ab705f 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -21,6 +21,7 @@ library(lme4) source("disclosure/set_disclosure_settings.R") source("random/set_random_seed_settings.R") +options(perf.profile = "perf_files/performance_refactor_profile.csv") source("perf_tests/perf_rate.R") # context("setup - done") diff --git a/tests/testthat/test-perf-meanDS.R b/tests/testthat/test-perf-meanDS.R index 4cee2473..59266cb2 100644 --- a/tests/testthat/test-perf-meanDS.R +++ b/tests/testthat/test-perf-meanDS.R @@ -45,8 +45,8 @@ test_that("numeric meanDS - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("meanDS::perf::numeric::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("meanDS::perf::numeric::0 ", .current.rate, 0.5, 2.0)) - perf.reference.save("meanDS::perf::numeric::0", .current.rate, 0.5, 2.0) + print(paste("meanDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + perf.reference.save("meanDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { print(paste("meanDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } @@ -80,8 +80,8 @@ test_that("numeric meanDS, with NA - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("meanDS::perf::numberAndNA::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("meanDS::perf::numberAndNA::0 ", .current.rate, 0.5, 2.0)) - perf.reference.save("meanDS::perf::numberAndNA::0", .current.rate, 0.5, 2.0) + print(paste("meanDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + perf.reference.save("meanDS::perf::numberAndNA::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { print(paste("meanDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } diff --git a/tests/testthat/test-perf-varDS.R b/tests/testthat/test-perf-varDS.R index 459e6f03..10fff94a 100644 --- a/tests/testthat/test-perf-varDS.R +++ b/tests/testthat/test-perf-varDS.R @@ -45,8 +45,8 @@ test_that("numeric varDS - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("varDS::perf::numeric::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("varDS::perf::numeric::0 ", .current.rate, 0.5, 2.0)) - perf.reference.save("varDS::perf::numeric::0", .current.rate, 0.5, 2.0) + print(paste("varDS::perf::numeric::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + perf.reference.save("varDS::perf::numeric::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { print(paste("varDS::perf::numeric::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } @@ -80,8 +80,8 @@ test_that("numeric varDS, with NA - performance", { .current.rate <- .count / (difftime(.current.time, .start.time, units = "secs")[[1]]) .reference.rate <- perf.reference.rate("varDS::perf::numberAndNA::0") if (any(length(.reference.rate) == 0) || any(is.null(.reference.rate))) { - print(paste("varDS::perf::numberAndNA::0 ", .current.rate, 0.5, 2.0)) - perf.reference.save("varDS::perf::numberAndNA::0", .current.rate, 0.5, 2.0) + print(paste("varDS::perf::numberAndNA::0 ", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper())) + perf.reference.save("varDS::perf::numberAndNA::0", .current.rate, perf.profile.tolerance.lower(), perf.profile.tolerance.upper()) } else { print(paste("varDS::perf::numberAndNA::0 ", format(.current.rate, digits = 8), ", ", format(100.0 * .current.rate / .reference.rate, digits = 4), "%", sep = '')) } From b3fcee9037946cd585bd356fad5ce529e61f29c5 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 27 Mar 2026 13:31:55 +0100 Subject: [PATCH 48/65] chore: comment out deprecated context calls --- tests/testthat/test-smk-asFactorSimpleDS.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index bafe51b3..7e871da3 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -12,7 +12,7 @@ # Set up # -context("asFactorSimpleDS::smk::setup") +# context("asFactorSimpleDS::smk::setup") set.standard.disclosure.settings() @@ -20,7 +20,7 @@ set.standard.disclosure.settings() # Tests # -context("asFactorSimpleDS::smk::simple") +# context("asFactorSimpleDS::smk::simple") test_that("simple asFactorSimpleDS", { input <- c(2.0, 1.0, 3.0, 3.0, 3.0, 1.0, 2.0, 2.0, 1.0, 2.0) @@ -52,6 +52,6 @@ test_that("simple asFactorSimpleDS", { # Done # -context("asFactorSimpleDS::smk::shutdown") +# context("asFactorSimpleDS::smk::shutdown") -context("asFactorSimpleDS::smk::done") +# context("asFactorSimpleDS::smk::done") From 5873240e641fb79ad21eb9b787351781d62a00d7 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Sat, 11 Apr 2026 11:37:01 +0200 Subject: [PATCH 49/65] docs: updated authorship for last PR --- R/absDS.R | 1 + R/asCharacterDS.R | 1 + R/asDataMatrixDS.R | 1 + R/asIntegerDS.R | 1 + R/asListDS.R | 1 + R/asLogicalDS.R | 1 + R/asMatrixDS.R | 1 + R/asNumericDS.R | 1 + R/expDS.R | 1 + R/logDS.R | 1 + R/sqrtDS.R | 1 + man/absDS.Rd | 2 ++ man/asCharacterDS.Rd | 2 ++ man/asDataMatrixDS.Rd | 2 ++ man/asIntegerDS.Rd | 2 ++ man/asListDS.Rd | 2 ++ man/asLogicalDS.Rd | 2 ++ man/asMatrixDS.Rd | 2 ++ man/asNumericDS.Rd | 2 ++ man/expDS.Rd | 2 ++ man/logDS.Rd | 2 ++ man/sqrtDS.Rd | 2 ++ 22 files changed, 33 insertions(+) diff --git a/R/absDS.R b/R/absDS.R index cd7c4312..7a6afb29 100644 --- a/R/absDS.R +++ b/R/absDS.R @@ -9,6 +9,7 @@ #' which is written to the serverside. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' absDS <- function(x) { diff --git a/R/asCharacterDS.R b/R/asCharacterDS.R index e12b8fe5..41313afa 100644 --- a/R/asCharacterDS.R +++ b/R/asCharacterDS.R @@ -10,6 +10,7 @@ #' "ascharacter.newobj") which is written to the serverside. For further #' details see help on the clientside function \code{ds.asCharacter} #' @author Amadou Gaye, Paul Burton, Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asCharacterDS <- function(x.name) { diff --git a/R/asDataMatrixDS.R b/R/asDataMatrixDS.R index 0e570778..a05b937f 100644 --- a/R/asDataMatrixDS.R +++ b/R/asDataMatrixDS.R @@ -15,6 +15,7 @@ #' "asdatamatrix.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, Genomics Coordination Centre, UMCG, Netherlands #' @export asDataMatrixDS <- function(x.name) { x <- .loadServersideObject(x.name) diff --git a/R/asIntegerDS.R b/R/asIntegerDS.R index b982ed88..476f1c9c 100644 --- a/R/asIntegerDS.R +++ b/R/asIntegerDS.R @@ -11,6 +11,7 @@ #' "asinteger.newobj") which is written to the serverside. For further #' details see help on the clientside function \code{ds.asInteger}. #' @author Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asIntegerDS <- function(x.name){ diff --git a/R/asListDS.R b/R/asListDS.R index 4d29fb72..f912594e 100644 --- a/R/asListDS.R +++ b/R/asListDS.R @@ -20,6 +20,7 @@ #' coerces objects to list depends on the class of the object, but in general #' the class of the output object should usually be 'list' #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asListDS <- function (x.name, newobj){ x <- .loadServersideObject(x.name) diff --git a/R/asLogicalDS.R b/R/asLogicalDS.R index ef40d402..18347d78 100644 --- a/R/asLogicalDS.R +++ b/R/asLogicalDS.R @@ -9,6 +9,7 @@ #' .logic) which is written to the serverside. For further #' details see help on the clientside function \code{ds.asLogical} #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asLogicalDS <- function (x.name){ x <- .loadServersideObject(x.name) diff --git a/R/asMatrixDS.R b/R/asMatrixDS.R index 33d1ba15..e14388d1 100644 --- a/R/asMatrixDS.R +++ b/R/asMatrixDS.R @@ -9,6 +9,7 @@ #' .mat) which is written to the serverside. For further #' details see help on the clientside function \code{ds.asMatrix} #' @author Amadou Gaye, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export asMatrixDS <- function (x.name){ x <- .loadServersideObject(x.name) diff --git a/R/asNumericDS.R b/R/asNumericDS.R index 17b9fd34..85a608af 100644 --- a/R/asNumericDS.R +++ b/R/asNumericDS.R @@ -11,6 +11,7 @@ #' .num) which is written to the serverside. For further #' details see help on the clientside function \code{ds.asNumeric}. #' @author Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asNumericDS <- function(x.name){ diff --git a/R/expDS.R b/R/expDS.R index 0590384e..3c6b53c3 100644 --- a/R/expDS.R +++ b/R/expDS.R @@ -8,6 +8,7 @@ #' of \code{ds.exp} (or default name \code{exp.newobj}) #' which is written to the serverside. The output object is of class numeric. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' expDS <- function(x) { diff --git a/R/logDS.R b/R/logDS.R index 13b3a367..6912f9dc 100644 --- a/R/logDS.R +++ b/R/logDS.R @@ -10,6 +10,7 @@ #' of \code{ds.log} (or default name \code{log.newobj}) #' which is written to the serverside. The output object is of class numeric. #' @author DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' logDS <- function(x, base=exp(1)) { diff --git a/R/sqrtDS.R b/R/sqrtDS.R index 7643a532..50e3c712 100644 --- a/R/sqrtDS.R +++ b/R/sqrtDS.R @@ -9,6 +9,7 @@ #' which is written to the server-side. The output object is of class numeric #' or integer. #' @author Demetris Avraam for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' sqrtDS <- function(x){ diff --git a/man/absDS.Rd b/man/absDS.Rd index 633845dc..ae347019 100644 --- a/man/absDS.Rd +++ b/man/absDS.Rd @@ -24,4 +24,6 @@ or integer vector. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asCharacterDS.Rd b/man/asCharacterDS.Rd index 67ac5bd8..5ad9b618 100644 --- a/man/asCharacterDS.Rd +++ b/man/asCharacterDS.Rd @@ -25,4 +25,6 @@ See help for function \code{as.character} in native R } \author{ Amadou Gaye, Paul Burton, Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asDataMatrixDS.Rd b/man/asDataMatrixDS.Rd index 3170e9af..65ab80e3 100644 --- a/man/asDataMatrixDS.Rd +++ b/man/asDataMatrixDS.Rd @@ -31,4 +31,6 @@ original class } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asIntegerDS.Rd b/man/asIntegerDS.Rd index d3ecf5b1..1c3b8b53 100644 --- a/man/asIntegerDS.Rd +++ b/man/asIntegerDS.Rd @@ -26,4 +26,6 @@ in the help file of the clientside function \code{ds.asInteger}. } \author{ Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asListDS.Rd b/man/asListDS.Rd index ff2fd7be..a2fc5a1c 100644 --- a/man/asListDS.Rd +++ b/man/asListDS.Rd @@ -37,4 +37,6 @@ and so additional information can be found in the help for \code{as.list} } \author{ Amadou Gaye, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asLogicalDS.Rd b/man/asLogicalDS.Rd index 3f5ea2d3..c107a6a3 100644 --- a/man/asLogicalDS.Rd +++ b/man/asLogicalDS.Rd @@ -25,4 +25,6 @@ See help for function \code{as.logical} in native R } \author{ Amadou Gaye, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asMatrixDS.Rd b/man/asMatrixDS.Rd index 833088d7..64146932 100644 --- a/man/asMatrixDS.Rd +++ b/man/asMatrixDS.Rd @@ -25,4 +25,6 @@ See help for function \code{as.matrix} in native R } \author{ Amadou Gaye, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/asNumericDS.Rd b/man/asNumericDS.Rd index 2467160c..06ca5da9 100644 --- a/man/asNumericDS.Rd +++ b/man/asNumericDS.Rd @@ -26,4 +26,6 @@ in the help file of the clientside function \code{ds.asNumeric}. } \author{ Amadou Gaye, Paul Burton, Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/expDS.Rd b/man/expDS.Rd index 87ce96c8..6ca53eea 100644 --- a/man/expDS.Rd +++ b/man/expDS.Rd @@ -23,4 +23,6 @@ or integer vector. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/logDS.Rd b/man/logDS.Rd index 5c8a8eb2..7c6d26d8 100644 --- a/man/logDS.Rd +++ b/man/logDS.Rd @@ -26,4 +26,6 @@ or integer vector. By default natural logarithms are computed. } \author{ DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/sqrtDS.Rd b/man/sqrtDS.Rd index 79f044a0..099b8dad 100644 --- a/man/sqrtDS.Rd +++ b/man/sqrtDS.Rd @@ -24,4 +24,6 @@ or integer vector. } \author{ Demetris Avraam for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From c72dc118cde3c57d48dfdf711adb91471ed49691 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 31 Mar 2026 13:40:39 +0200 Subject: [PATCH 50/65] refactor: replace eval(parse()) with .loadServersideObject() --- R/classDS.R | 8 +------- R/completeCasesDS.R | 5 ++--- R/namesDS.R | 12 ++++++------ R/uniqueDS.R | 17 +---------------- 4 files changed, 10 insertions(+), 32 deletions(-) diff --git a/R/classDS.R b/R/classDS.R index 16720b80..db8a907a 100644 --- a/R/classDS.R +++ b/R/classDS.R @@ -8,15 +8,9 @@ #' @export #' classDS <- function(x){ - - x.val <- eval(parse(text=x), envir = parent.frame()) - - # find the class of the input object + x.val <- .loadServersideObject(x) out <- class(x.val) - - # return the class return(out) - } #AGGREGATE FUNCTION # classDS diff --git a/R/completeCasesDS.R b/R/completeCasesDS.R index 6e1837f6..a85222cd 100644 --- a/R/completeCasesDS.R +++ b/R/completeCasesDS.R @@ -111,10 +111,9 @@ completeCasesDS <- function(x1.transmit){ } #Activate target object - #x1.transmit is the name of a serverside data.frame, matrix or vector - x1.use <- eval(parse(text=x1.transmit), envir = parent.frame()) + x1.use <- .loadServersideObject(x1.transmit) complete.rows <- stats::complete.cases(x1.use) - + if(is.matrix(x1.use) || is.data.frame(x1.use)){ output.object <- x1.use[complete.rows,] }else if(is.atomic(x1.use) || is.factor(x1.use)){ diff --git a/R/namesDS.R b/R/namesDS.R index 144c7270..6193817f 100644 --- a/R/namesDS.R +++ b/R/namesDS.R @@ -50,14 +50,14 @@ nfilter.stringShort<-as.numeric(thr$nfilter.stringShort) # stop(studysideMessage, call. = FALSE) } - list.obj<-eval(parse(text=xname.transmit), envir = parent.frame()) - - trace.message<-class(list.obj) - + list.obj <- .loadServersideObject(xname.transmit) if(!is.list(list.obj)){ - error.message <- "The input object is not of class " - stop(paste0(error.message,trace.message), call. = FALSE) + stop( + "The input object is not of class . '", xname.transmit, "' is type ", + paste(class(list.obj), collapse = ", "), + call. = FALSE + ) } diff --git a/R/uniqueDS.R b/R/uniqueDS.R index 6834ff8a..2b8f0095 100644 --- a/R/uniqueDS.R +++ b/R/uniqueDS.R @@ -9,23 +9,8 @@ #' @export #' uniqueDS <- function(x.name.transmit = NULL){ - # Check 'x.name.transmit' contains a name - if (is.null(x.name.transmit)) - stop("Variable's name can't be NULL", call. = FALSE) - - if ((! is.character(x.name.transmit)) || (length(x.name.transmit) != 1)) - stop("Variable's name isn't a single character vector", call. = FALSE) - - # Check object exists - x.value <- eval(parse(text=x.name.transmit), envir = parent.frame()) - - if (is.null(x.value)) - stop("Variable can't be NULL", call. = FALSE) - - # Compute the unique's value + x.value <- .loadServersideObject(x.name.transmit) out <- base::unique(x.value) - - # assign the outcome to the data servers return(out) } # ASSIGN FUNCTION From 4b67c4a746587311999e8f9d642f6b4f9594ccdd Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 31 Mar 2026 13:40:55 +0200 Subject: [PATCH 51/65] refactor: dimDS/lengthDS return class for client-side consistency check --- R/dimDS.R | 15 +++++---------- R/lengthDS.R | 16 ++++++---------- man/dimDS.Rd | 3 ++- man/lengthDS.Rd | 4 +++- 4 files changed, 16 insertions(+), 22 deletions(-) diff --git a/R/dimDS.R b/R/dimDS.R index 3b51ed49..74f16df4 100644 --- a/R/dimDS.R +++ b/R/dimDS.R @@ -3,20 +3,15 @@ #' @description This function is similar to R function \code{dim}. #' @details The function returns the dimension of the input dataframe or matrix #' @param x a string character, the name of a dataframe or matrix -#' @return the dimension of the input object +#' @return a list with two elements: \code{dim} (the dimension of the input object) +#' and \code{class} (the class of the input object, for client-side consistency checking) #' @author Demetris Avraam, for DataSHIELD Development Team #' @export #' dimDS <- function(x){ - - x.var <- eval(parse(text=x), envir = parent.frame()) - - # find the dim of the input dataframe or matrix - out <- dim(x.var) - - # return the dimension - return(out) - + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("data.frame", "matrix")) + list(dim = dim(x.val), class = class(x.val)) } #AGGREGATE FUNCTION # dimDS diff --git a/R/lengthDS.R b/R/lengthDS.R index 7e4b8997..fe1c22d6 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -3,20 +3,16 @@ #' @description This function is similar to R function \code{length}. #' @details The function returns the length of the input vector or list. #' @param x a string character, the name of a vector or list -#' @return a numeric, the number of elements of the input vector or list. +#' @return a list with two elements: \code{length} (the number of elements of the input +#' vector or list) and \code{class} (the class of the input object, for client-side +#' consistency checking) #' @author Demetris Avraam, for DataSHIELD Development Team #' @export #' lengthDS <- function(x){ - - x.var <- eval(parse(text=x), envir = parent.frame()) - - # find the length of the input vector or list - out <- length(x.var) - - # return output length - return(out) - + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list")) + list(length = length(x.val), class = class(x.val)) } #AGGREGATE FUNCTION # lengthDS diff --git a/man/dimDS.Rd b/man/dimDS.Rd index c14d82af..1fbac2bf 100644 --- a/man/dimDS.Rd +++ b/man/dimDS.Rd @@ -10,7 +10,8 @@ dimDS(x) \item{x}{a string character, the name of a dataframe or matrix} } \value{ -the dimension of the input object +a list with two elements: \code{dim} (the dimension of the input object) + and \code{class} (the class of the input object, for client-side consistency checking) } \description{ This function is similar to R function \code{dim}. diff --git a/man/lengthDS.Rd b/man/lengthDS.Rd index 75498994..bfadf14f 100644 --- a/man/lengthDS.Rd +++ b/man/lengthDS.Rd @@ -10,7 +10,9 @@ lengthDS(x) \item{x}{a string character, the name of a vector or list} } \value{ -a numeric, the number of elements of the input vector or list. +a list with two elements: \code{length} (the number of elements of the input + vector or list) and \code{class} (the class of the input object, for client-side + consistency checking) } \description{ This function is similar to R function \code{length}. From 2c2c9f52da9acc7b9dfc0bec489bbe2ad3fe72c4 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 31 Mar 2026 13:41:02 +0200 Subject: [PATCH 52/65] refactor: isNaDS/numNaDS/levelsDS accept string name via .loadServersideObject() --- R/isNaDS.R | 17 +++++++++-------- R/levelsDS.R | 21 ++++++++------------- R/numNaDS.R | 15 +++++++-------- man/isNaDS.Rd | 8 ++++---- man/numNaDS.Rd | 6 +++--- 5 files changed, 31 insertions(+), 36 deletions(-) diff --git a/R/isNaDS.R b/R/isNaDS.R index 917c420b..f1c2c461 100644 --- a/R/isNaDS.R +++ b/R/isNaDS.R @@ -1,17 +1,18 @@ -#' -#' @title Checks if a vector is empty -#' @description this function is similar to R function \code{is.na} but instead of a vector +#' +#' @title Checks if a vector is empty +#' @description this function is similar to R function \code{is.na} but instead of a vector #' of booleans it returns just one boolean to tell if all the element are missing values. -#' @param xvect a numerical or character vector -#' @return the integer '1' if the vector contains on NAs and '0' otherwise +#' @param x a character string, the name of a server-side vector +#' @return TRUE if the vector contains only NAs, FALSE otherwise #' @author Gaye, A. #' @export #' -isNaDS <- function(xvect){ - +isNaDS <- function(x){ + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix")) out <- is.na(xvect) total <- sum(out, na.rm=TRUE) - if(total==(1*length(out))){ + if(total == (1 * length(out))){ return(TRUE) }else{ return(FALSE) diff --git a/R/levelsDS.R b/R/levelsDS.R index bdb374d5..5e827f1e 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -8,27 +8,22 @@ #' @export #' levelsDS <- function(x){ - + + x.val <- .loadServersideObject(x) + .checkClass(obj = x.val, obj_name = x, permitted_classes = "factor") + # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) - + ################################################################## #MODULE 1: 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) # - #nfilter.noise <- as.numeric(thr$nfilter.noise) # nfilter.levels.density <- as.numeric(thr$nfilter.levels.density) # - #nfilter.levels.max <- as.numeric(thr$nfilter.levels.max) # ################################################################## - + # find the levels of the input vector - out <- levels(x) - input.length <- length(x) + out <- levels(x.val) + input.length <- length(x.val) output.length <- length(out) studysideMessage <- "VALID ANALYSIS" diff --git a/R/numNaDS.R b/R/numNaDS.R index 5f369b90..4c85c5bc 100644 --- a/R/numNaDS.R +++ b/R/numNaDS.R @@ -1,15 +1,14 @@ -#' +#' #' @title Counts the number of missing values -#' @description this function just counts the number of missing entries -#' in a vector. -#' @param xvect a vector +#' @description this function just counts the number of missing entries +#' in a vector. +#' @param x a character string, the name of a server-side vector #' @return an integer, the number of missing values #' @author Gaye, A. #' @export #' -numNaDS <- function(xvect){ - +numNaDS <- function(x){ + xvect <- .loadServersideObject(x) out <- length(which(is.na(xvect))) - return (out) - + return(out) } diff --git a/man/isNaDS.Rd b/man/isNaDS.Rd index b4954850..6ed52393 100644 --- a/man/isNaDS.Rd +++ b/man/isNaDS.Rd @@ -4,16 +4,16 @@ \alias{isNaDS} \title{Checks if a vector is empty} \usage{ -isNaDS(xvect) +isNaDS(x) } \arguments{ -\item{xvect}{a numerical or character vector} +\item{x}{a character string, the name of a server-side vector} } \value{ -the integer '1' if the vector contains on NAs and '0' otherwise +TRUE if the vector contains only NAs, FALSE otherwise } \description{ -this function is similar to R function \code{is.na} but instead of a vector +this function is similar to R function \code{is.na} but instead of a vector of booleans it returns just one boolean to tell if all the element are missing values. } \author{ diff --git a/man/numNaDS.Rd b/man/numNaDS.Rd index 0162a630..cc5256f3 100644 --- a/man/numNaDS.Rd +++ b/man/numNaDS.Rd @@ -4,16 +4,16 @@ \alias{numNaDS} \title{Counts the number of missing values} \usage{ -numNaDS(xvect) +numNaDS(x) } \arguments{ -\item{xvect}{a vector} +\item{x}{a character string, the name of a server-side vector} } \value{ an integer, the number of missing values } \description{ -this function just counts the number of missing entries +this function just counts the number of missing entries in a vector. } \author{ From ac3747ef577199059ffdb4eee5534c9ece058f01 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 31 Mar 2026 14:46:40 +0200 Subject: [PATCH 53/65] test: update batch 2 tests for refactored server functions --- tests/testthat/test-arg-uniqueDS.R | 20 ++++------ tests/testthat/test-smk-classDS.R | 7 ++++ tests/testthat/test-smk-completeCasesDS.R | 7 ++++ tests/testthat/test-smk-dimDS.R | 41 ++++++++++++++++---- tests/testthat/test-smk-isNaDS.R | 19 ++++++--- tests/testthat/test-smk-lengthDS.R | 47 +++++++++++++---------- tests/testthat/test-smk-levelsDS.R | 17 +++++++- tests/testthat/test-smk-namesDS.R | 15 ++++++++ tests/testthat/test-smk-numNaDS.R | 13 +++++-- 9 files changed, 135 insertions(+), 51 deletions(-) diff --git a/tests/testthat/test-arg-uniqueDS.R b/tests/testthat/test-arg-uniqueDS.R index 48d6bd48..bff02d5d 100644 --- a/tests/testthat/test-arg-uniqueDS.R +++ b/tests/testthat/test-arg-uniqueDS.R @@ -19,25 +19,19 @@ # Tests # -# 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") -test_that("simple uniqueDS for NULL", { - input <- NULL - expect_error(uniqueDS("input"), "Variable can't be NULL", fixed = TRUE) +# context("uniqueDS::arg::null argument") +test_that("uniqueDS errors for NULL argument", { + expect_error(uniqueDS(NULL), "must be a single character string", fixed = TRUE) }) # 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) +test_that("uniqueDS errors for non-character argument", { + expect_error(uniqueDS(17), "must be a single character string", fixed = TRUE) }) # context("uniqueDS::arg::missing value") -test_that("simple uniqueDS for NULL", { - expect_error(uniqueDS("input"), "object 'input' not found", fixed = TRUE) +test_that("uniqueDS errors for nonexistent object", { + expect_error(uniqueDS("nonexistent_object"), "does not exist") }) # diff --git a/tests/testthat/test-smk-classDS.R b/tests/testthat/test-smk-classDS.R index d2efcf40..a3eb79d3 100644 --- a/tests/testthat/test-smk-classDS.R +++ b/tests/testthat/test-smk-classDS.R @@ -230,6 +230,13 @@ test_that("special classDS, NULL", { expect_equal(res, "NULL") }) +test_that("classDS throws error when object does not exist", { + expect_error( + classDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-completeCasesDS.R b/tests/testthat/test-smk-completeCasesDS.R index 2ba7b913..81ca9e29 100644 --- a/tests/testthat/test-smk-completeCasesDS.R +++ b/tests/testthat/test-smk-completeCasesDS.R @@ -190,6 +190,13 @@ test_that("simple completeCasesDS, data.matrix, with NAs", { expect_equal(res.colnames[2], "v2") }) +test_that("completeCasesDS throws error when object does not exist", { + expect_error( + completeCasesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-dimDS.R b/tests/testthat/test-smk-dimDS.R index 7915e9a1..c45d07fb 100644 --- a/tests/testthat/test-smk-dimDS.R +++ b/tests/testthat/test-smk-dimDS.R @@ -25,10 +25,10 @@ test_that("numeric dimDS", { res <- dimDS("input") - expect_length(res, 2) - expect_equal(class(res), "integer") - expect_equal(res[1], 5) - expect_equal(res[2], 2) + expect_equal(class(res), "list") + expect_equal(res$dim[1], 5) + expect_equal(res$dim[2], 2) + expect_equal(res$class, "data.frame") }) # context("dimDS::smk::character") @@ -37,10 +37,35 @@ test_that("character dimDS", { res <- dimDS("input") - expect_length(res, 2) - expect_equal(class(res), "integer") - expect_equal(res[1], 5) - expect_equal(res[2], 2) + expect_equal(class(res), "list") + expect_equal(res$dim[1], 5) + expect_equal(res$dim[2], 2) + expect_equal(res$class, "data.frame") +}) + +test_that("dimDS with matrix", { + input <- matrix(1:6, nrow = 2, ncol = 3) + + res <- dimDS("input") + + expect_equal(res$dim[1], 2) + expect_equal(res$dim[2], 3) + expect_true("matrix" %in% res$class) +}) + +test_that("dimDS throws error when object does not exist", { + expect_error( + dimDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("dimDS throws error when object is not data.frame or matrix", { + bad_input <- c(1, 2, 3) + expect_error( + dimDS("bad_input"), + regexp = "must be of type data.frame or matrix" + ) }) # diff --git a/tests/testthat/test-smk-isNaDS.R b/tests/testthat/test-smk-isNaDS.R index 766d513c..0cbdecd8 100644 --- a/tests/testthat/test-smk-isNaDS.R +++ b/tests/testthat/test-smk-isNaDS.R @@ -23,7 +23,7 @@ test_that("numeric vector isNaDS", { input <- c(0.1, 1.1, 2.1, 3.1, 4.1) - res <- isNaDS(input) + res <- isNaDS("input") expect_length(res, 1) expect_equal(class(res), "logical") @@ -33,7 +33,7 @@ test_that("numeric vector isNaDS", { test_that("numeric vector isNaDS - with NA single", { input <- c(0.1, NA, 2.1, 3.1, 4.1) - res <- isNaDS(input) + res <- isNaDS("input") expect_length(res, 1) expect_equal(class(res), "logical") @@ -43,7 +43,7 @@ test_that("numeric vector isNaDS - with NA single", { test_that("numeric vector isNaDS - with NA all", { input <- c(NA, NA, NA, NA, NA) - res <- isNaDS(input) + res <- isNaDS("input") expect_length(res, 1) expect_equal(class(res), "logical") @@ -54,7 +54,7 @@ test_that("numeric vector isNaDS - with NA all", { test_that("character vector isNaDS", { input <- c("101", "202", "303", "404", "505") - res <- isNaDS(input) + res <- isNaDS("input") expect_length(res, 1) expect_equal(class(res), "logical") @@ -64,7 +64,7 @@ test_that("character vector isNaDS", { test_that("character vector isNaDS - with NA single", { input <- c("101", NA, "303", "404", "505") - res <- isNaDS(input) + res <- isNaDS("input") expect_length(res, 1) expect_equal(class(res), "logical") @@ -74,13 +74,20 @@ test_that("character vector isNaDS - with NA single", { test_that("character vector isNaDS - with NA all", { input <- c(NA, NA, NA, NA, NA) - res <- isNaDS(input) + res <- isNaDS("input") expect_length(res, 1) expect_equal(class(res), "logical") expect_equal(res, TRUE) }) +test_that("isNaDS throws error when object does not exist", { + expect_error( + isNaDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-lengthDS.R b/tests/testthat/test-smk-lengthDS.R index b5fad0e7..67454a8b 100644 --- a/tests/testthat/test-smk-lengthDS.R +++ b/tests/testthat/test-smk-lengthDS.R @@ -19,42 +19,49 @@ # Tests # -# context("lengthDS::smk::data.frame") -test_that("simple lengthDS, numeric data.frame", { - input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) +# context("lengthDS::smk::vector") +test_that("simple lengthDS, numeric vector", { + input <- c(0.0, 1.0, 2.0, 3.0, 4.0) res <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 2) + expect_equal(class(res), "list") + expect_equal(res$length, 5) + expect_equal(res$class, "numeric") }) -test_that("simple lengthDS, character data.frame", { - input <- data.frame(v1 = c("0.0", "1.0", "2.0", "3.0", "4.0"), v2 = c("4.0", "3.0", "2.0", "1.0", "0.0"), stringsAsFactors = FALSE) +test_that("simple lengthDS, character vector", { + input <- c("0.0", "1.0", "2.0", "3.0", "4.0") res <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 2) + expect_equal(class(res), "list") + expect_equal(res$length, 5) + expect_equal(res$class, "character") }) -# context("lengthDS::smk::vector") -test_that("simple lengthDS, numeric vector", { - input <- c(0.0, 1.0, 2.0, 3.0, 4.0) +test_that("simple lengthDS, list", { + input <- list(a = 1, b = 2, c = 3) res <- lengthDS("input") - expect_equal(class(res), "integer") - expect_equal(res, 5) + expect_equal(res$length, 3) + expect_equal(res$class, "list") }) -test_that("simple lengthDS, character vector", { - input <- c("0.0", "1.0", "2.0", "3.0", "4.0") - - res <- lengthDS("input") +test_that("lengthDS throws error when object does not exist", { + expect_error( + lengthDS("nonexistent_object"), + regexp = "does not exist" + ) +}) - expect_equal(class(res), "integer") - expect_equal(res, 5) +test_that("lengthDS throws error when object is not a permitted type", { + bad_input <- data.frame(a = 1:3) + expect_error( + lengthDS("bad_input"), + regexp = "must be of type" + ) }) # diff --git a/tests/testthat/test-smk-levelsDS.R b/tests/testthat/test-smk-levelsDS.R index 5ba10980..28949677 100644 --- a/tests/testthat/test-smk-levelsDS.R +++ b/tests/testthat/test-smk-levelsDS.R @@ -25,7 +25,7 @@ set.standard.disclosure.settings() test_that("numeric vector levelsDS", { input <- as.factor(c(0, 1, 2, 1, 2, 3, 1, 2, 1, 0, 1, 2, 0)) - res <- levelsDS(input) + res <- levelsDS("input") expect_length(res, 2) expect_equal(class(res), "list") @@ -39,6 +39,21 @@ test_that("numeric vector levelsDS", { expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) +test_that("levelsDS throws error when object does not exist", { + expect_error( + levelsDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("levelsDS throws error when object is not a factor", { + bad_input <- c(1, 2, 3) + expect_error( + levelsDS("bad_input"), + regexp = "must be of type factor" + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-namesDS.R b/tests/testthat/test-smk-namesDS.R index dbc5f3b1..fe1134d5 100644 --- a/tests/testthat/test-smk-namesDS.R +++ b/tests/testthat/test-smk-namesDS.R @@ -45,6 +45,21 @@ test_that("simple namesDS, data.matrix", { expect_true("v2" %in% res) }) +test_that("namesDS throws error when object does not exist", { + expect_error( + namesDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + +test_that("namesDS throws error when object is not a list", { + bad_input <- c(1, 2, 3) + expect_error( + namesDS("bad_input"), + regexp = "not of class " + ) +}) + # # Done # diff --git a/tests/testthat/test-smk-numNaDS.R b/tests/testthat/test-smk-numNaDS.R index c77db4ed..f050d3d8 100644 --- a/tests/testthat/test-smk-numNaDS.R +++ b/tests/testthat/test-smk-numNaDS.R @@ -23,23 +23,30 @@ test_that("simple numNaDS", { input <- c(NA, 1, NA, 2, NA) - res <- numNaDS(input) + res <- numNaDS("input") expect_equal(class(res), "integer") expect_length(res, 1) expect_equal(res, 3) }) -test_that("simple numNaDS", { +test_that("simple numNaDS, single NA", { input <- NA - res <- numNaDS(input) + res <- numNaDS("input") expect_equal(class(res), "integer") expect_length(res, 1) expect_equal(res, 1) }) +test_that("numNaDS throws error when object does not exist", { + expect_error( + numNaDS("nonexistent_object"), + regexp = "does not exist" + ) +}) + # # Done # From 48b374a79042011cd1bc11e9dd9ecdc6289d2a68 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 10:40:24 +0200 Subject: [PATCH 54/65] refactor: also return class for client-side consistency checks --- R/ihen_outcome.R | 64 ++++++++++++++++++++++++++++++++++++++++++++++++ R/isNaDS.R | 11 ++++----- R/levelsDS.R | 6 +++-- R/numNaDS.R | 6 +++-- 4 files changed, 77 insertions(+), 10 deletions(-) create mode 100644 R/ihen_outcome.R diff --git a/R/ihen_outcome.R b/R/ihen_outcome.R new file mode 100644 index 00000000..4af38652 --- /dev/null +++ b/R/ihen_outcome.R @@ -0,0 +1,64 @@ +library(dplyr) +library(tidyr) +library(ggplot2) + +# --- Simplified Web Table 7 (with INMA + EDEN collapsed) --- +bmi_data <- data.frame( + Cohort = c("RHEA","CHOP","SWS","GECKO","Raine","INMA","EDEN","GENR", + "ALSPAC","ABCD","NFBC66","NFBC86","BiB","ELFE","DNBC","MoBa"), + n0_1 = c(974,1668,2942,2738,2303,1910,1760,7230,1420,5669,7379,5141,12959,17795,56821,85079), + n2_3 = c(684,938,2701,2212,614,1177,1521,6466,1221,4763,5809,4739,6225,10773,0,45673), + n4_7 = c(887,1092,2166,2309,2088,1634,1278,6572,5682,4754,7268,7110,10539,10192,43164,49728), + n8_13 = c(334,755,1209,2180,1988,1043,904,5723,9585,3603,7239,4750,5592,3360,44177,33473), + n14_17= c(NA,NA,NA,NA,1623,NA,NA,NA,7675,NA,7035,5760,NA,NA,6508,NA) +) + +# --- Reshape --- +bmi_long <- bmi_data %>% + pivot_longer(cols = starts_with("n"), names_to = "Age_group", values_to = "n") %>% + mutate(Age_group = factor(Age_group, + levels = c("n0_1", "n2_3", "n4_7", "n8_13", "n14_17"), + labels = c("0–1 years", "2–3 years", "4–7 years", "8–13 years", "14–17 years"))) %>% + drop_na(n) + +# --- Order cohorts by total contribution --- +bmi_long <- bmi_long %>% + group_by(Cohort) %>% + mutate(total_n = sum(n, na.rm = TRUE)) %>% + ungroup() %>% + arrange(total_n) + +# --- Split into 5 cumulative stages --- +n_cohorts <- n_distinct(bmi_long$Cohort) +stage_breaks <- round(seq(1, n_cohorts, length.out = 5)) # 5 roughly equal steps + +# --- Fixed axis limits for identical scaling --- +ymax <- bmi_long %>% + group_by(Age_group) %>% + summarise(total = sum(n)) %>% + summarise(max_total = max(total)) %>% + pull(max_total) + +# --- Loop to create 5 plots --- +for (i in seq_along(stage_breaks)) { + + included <- unique(bmi_long$Cohort)[1:stage_breaks[i]] + plot_data <- bmi_long %>% filter(Cohort %in% included) + + p <- ggplot(plot_data, aes(x = Age_group, y = n, fill = Cohort)) + + geom_bar(stat = "identity", width = 0.7, color = "white") + + scale_y_continuous(labels = scales::comma, limits = c(0, ymax)) + + scale_fill_viridis_d(option = "turbo", direction = -1) + + labs( + x = "Child age group", + y = "Number of BMI z-score observations", + fill = "Cohort" + ) + + theme_minimal(base_size = 13) + + theme( + legend.position = "right", + plot.title = element_blank() + ) + + ggsave(sprintf("bmi_stacked_stage_%02d.png", i), p, width = 7, height = 5, dpi = 300) +} diff --git a/R/isNaDS.R b/R/isNaDS.R index f1c2c461..6fc25940 100644 --- a/R/isNaDS.R +++ b/R/isNaDS.R @@ -3,7 +3,9 @@ #' @description this function is similar to R function \code{is.na} but instead of a vector #' of booleans it returns just one boolean to tell if all the element are missing values. #' @param x a character string, the name of a server-side vector -#' @return TRUE if the vector contains only NAs, FALSE otherwise +#' @return a list with two elements: \code{is.na} (TRUE if the vector contains +#' only NAs, FALSE otherwise) and \code{class} (the class of the input object, +#' for client-side consistency checking) #' @author Gaye, A. #' @export #' @@ -12,9 +14,6 @@ isNaDS <- function(x){ .checkClass(obj = xvect, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "data.frame", "matrix")) out <- is.na(xvect) total <- sum(out, na.rm=TRUE) - if(total == (1 * length(out))){ - return(TRUE) - }else{ - return(FALSE) - } + is_na <- total == (1 * length(out)) + list(is.na = is_na, class = class(xvect)) } diff --git a/R/levelsDS.R b/R/levelsDS.R index 5e827f1e..6874ad1d 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -3,7 +3,9 @@ #' @description This function is similar to R function \code{levels}. #' @details The function returns the levels of the input vector or list. #' @param x a factor vector -#' @return a list, the factor levels present in the vector +#' @return a list with three elements: \code{Levels} (the factor levels present +#' in the vector), \code{ValidityMessage}, and \code{class} (the class of the +#' input object, for client-side consistency checking) #' @author Alex Westerberg, for DataSHIELD Development Team #' @export #' @@ -33,7 +35,7 @@ levelsDS <- function(x){ stop(studysideMessage, call. = FALSE) } - out.obj <- list(Levels=out,ValidityMessage=studysideMessage) + out.obj <- list(Levels=out, ValidityMessage=studysideMessage, class=class(x.val)) return(out.obj) } #AGGREGATE FUNCTION diff --git a/R/numNaDS.R b/R/numNaDS.R index 4c85c5bc..334bf49f 100644 --- a/R/numNaDS.R +++ b/R/numNaDS.R @@ -3,12 +3,14 @@ #' @description this function just counts the number of missing entries #' in a vector. #' @param x a character string, the name of a server-side vector -#' @return an integer, the number of missing values +#' @return a list with two elements: \code{numNA} (an integer, the number of +#' missing values) and \code{class} (the class of the input object, for +#' client-side consistency checking) #' @author Gaye, A. #' @export #' numNaDS <- function(x){ xvect <- .loadServersideObject(x) out <- length(which(is.na(xvect))) - return(out) + list(numNA = out, class = class(xvect)) } From fa49156b652f992d368206f4001d139f1111682c Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 10:48:09 +0200 Subject: [PATCH 55/65] refactor: remove validity message as inconsistent with other functions --- R/levelsDS.R | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/R/levelsDS.R b/R/levelsDS.R index 6874ad1d..4b62978f 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -3,9 +3,9 @@ #' @description This function is similar to R function \code{levels}. #' @details The function returns the levels of the input vector or list. #' @param x a factor vector -#' @return a list with three elements: \code{Levels} (the factor levels present -#' in the vector), \code{ValidityMessage}, and \code{class} (the class of the -#' input object, for client-side consistency checking) +#' @return a list with two elements: \code{Levels} (the factor levels present +#' in the vector) and \code{class} (the class of the input object, for +#' client-side consistency checking) #' @author Alex Westerberg, for DataSHIELD Development Team #' @export #' @@ -27,15 +27,12 @@ levelsDS <- function(x){ out <- levels(x.val) input.length <- length(x.val) output.length <- length(out) - studysideMessage <- "VALID ANALYSIS" if((input.length * nfilter.levels.density) < output.length) { - out <- NA - studysideMessage <- "FAILED: Result length less than nfilter.levels.density of input length." - stop(studysideMessage, call. = FALSE) + stop("FAILED: Result length less than nfilter.levels.density of input length.", call. = FALSE) } - - out.obj <- list(Levels=out, ValidityMessage=studysideMessage, class=class(x.val)) + + out.obj <- list(Levels=out, class=class(x.val)) return(out.obj) } #AGGREGATE FUNCTION From 97e2687468b08f802d869ad8b2bcdbd2f20a66d4 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 10:48:19 +0200 Subject: [PATCH 56/65] docs: redocumented --- man/isNaDS.Rd | 4 +++- man/levelsDS.Rd | 4 +++- man/numNaDS.Rd | 4 +++- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/man/isNaDS.Rd b/man/isNaDS.Rd index 6ed52393..13fe1d25 100644 --- a/man/isNaDS.Rd +++ b/man/isNaDS.Rd @@ -10,7 +10,9 @@ isNaDS(x) \item{x}{a character string, the name of a server-side vector} } \value{ -TRUE if the vector contains only NAs, FALSE otherwise +a list with two elements: \code{is.na} (TRUE if the vector contains + only NAs, FALSE otherwise) and \code{class} (the class of the input object, + for client-side consistency checking) } \description{ this function is similar to R function \code{is.na} but instead of a vector diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index 7046a117..87ab11a1 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,7 +10,9 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list, the factor levels present in the vector +a list with two elements: \code{Levels} (the factor levels present + in the vector) and \code{class} (the class of the input object, for + client-side consistency checking) } \description{ This function is similar to R function \code{levels}. diff --git a/man/numNaDS.Rd b/man/numNaDS.Rd index cc5256f3..0d213261 100644 --- a/man/numNaDS.Rd +++ b/man/numNaDS.Rd @@ -10,7 +10,9 @@ numNaDS(x) \item{x}{a character string, the name of a server-side vector} } \value{ -an integer, the number of missing values +a list with two elements: \code{numNA} (an integer, the number of + missing values) and \code{class} (the class of the input object, for + client-side consistency checking) } \description{ this function just counts the number of missing entries From 0f5814a23bf0fed4bcd7e86626838150a56644df Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 10:54:44 +0200 Subject: [PATCH 57/65] docs: updated authorship --- R/classDS.R | 1 + R/completeCasesDS.R | 1 + R/dimDS.R | 1 + R/isNaDS.R | 1 + R/lengthDS.R | 1 + R/levelsDS.R | 1 + R/namesDS.R | 1 + R/numNaDS.R | 1 + R/uniqueDS.R | 1 + man/classDS.Rd | 2 ++ man/completeCasesDS.Rd | 2 ++ man/dimDS.Rd | 2 ++ man/isNaDS.Rd | 2 ++ man/lengthDS.Rd | 2 ++ man/levelsDS.Rd | 2 ++ man/namesDS.Rd | 2 ++ man/numNaDS.Rd | 2 ++ man/uniqueDS.Rd | 2 ++ 18 files changed, 27 insertions(+) diff --git a/R/classDS.R b/R/classDS.R index db8a907a..a33e49a3 100644 --- a/R/classDS.R +++ b/R/classDS.R @@ -5,6 +5,7 @@ #' @param x a string character, the name of an object #' @return the class of the input object #' @author Stuart Wheater, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' classDS <- function(x){ diff --git a/R/completeCasesDS.R b/R/completeCasesDS.R index a85222cd..25e6e1b5 100644 --- a/R/completeCasesDS.R +++ b/R/completeCasesDS.R @@ -31,6 +31,7 @@ #' without problems no studysideMessage will have been saved and ds.message("newobj") #' will return the message: "ALL OK: there are no studysideMessage(s) on this datasource". #' @author Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' completeCasesDS <- function(x1.transmit){ diff --git a/R/dimDS.R b/R/dimDS.R index 74f16df4..c27db5b5 100644 --- a/R/dimDS.R +++ b/R/dimDS.R @@ -6,6 +6,7 @@ #' @return a list with two elements: \code{dim} (the dimension of the input object) #' and \code{class} (the class of the input object, for client-side consistency checking) #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' dimDS <- function(x){ diff --git a/R/isNaDS.R b/R/isNaDS.R index 6fc25940..3c73f019 100644 --- a/R/isNaDS.R +++ b/R/isNaDS.R @@ -7,6 +7,7 @@ #' only NAs, FALSE otherwise) and \code{class} (the class of the input object, #' for client-side consistency checking) #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' isNaDS <- function(x){ diff --git a/R/lengthDS.R b/R/lengthDS.R index fe1c22d6..5aefca58 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -7,6 +7,7 @@ #' vector or list) and \code{class} (the class of the input object, for client-side #' consistency checking) #' @author Demetris Avraam, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' lengthDS <- function(x){ diff --git a/R/levelsDS.R b/R/levelsDS.R index 4b62978f..6fca2b14 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -7,6 +7,7 @@ #' in the vector) and \code{class} (the class of the input object, for #' client-side consistency checking) #' @author Alex Westerberg, for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' levelsDS <- function(x){ diff --git a/R/namesDS.R b/R/namesDS.R index 6193817f..a32aa916 100644 --- a/R/namesDS.R +++ b/R/namesDS.R @@ -16,6 +16,7 @@ #' @return \code{namesDS} returns to the client-side the names #' of a list object stored on the server-side. #' @author Amadou Gaye, updated by Paul Burton 25/06/2020 +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' namesDS <- function(xname.transmit){ diff --git a/R/numNaDS.R b/R/numNaDS.R index 334bf49f..95011e25 100644 --- a/R/numNaDS.R +++ b/R/numNaDS.R @@ -7,6 +7,7 @@ #' missing values) and \code{class} (the class of the input object, for #' client-side consistency checking) #' @author Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' numNaDS <- function(x){ diff --git a/R/uniqueDS.R b/R/uniqueDS.R index 2b8f0095..23290d3b 100644 --- a/R/uniqueDS.R +++ b/R/uniqueDS.R @@ -6,6 +6,7 @@ #' @return the object specified by the \code{newobj} argument #' which is written to the server-side. #' @author Stuart Wheater for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' uniqueDS <- function(x.name.transmit = NULL){ diff --git a/man/classDS.Rd b/man/classDS.Rd index c1a51f83..030958cf 100644 --- a/man/classDS.Rd +++ b/man/classDS.Rd @@ -20,4 +20,6 @@ The function returns the class of an object } \author{ Stuart Wheater, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/completeCasesDS.Rd b/man/completeCasesDS.Rd index 792c73a0..8bc0ed08 100644 --- a/man/completeCasesDS.Rd +++ b/man/completeCasesDS.Rd @@ -47,4 +47,6 @@ under help("complete.cases") in native R. } \author{ Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/dimDS.Rd b/man/dimDS.Rd index 1fbac2bf..f7119f68 100644 --- a/man/dimDS.Rd +++ b/man/dimDS.Rd @@ -21,4 +21,6 @@ The function returns the dimension of the input dataframe or matrix } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/isNaDS.Rd b/man/isNaDS.Rd index 13fe1d25..faae7cfb 100644 --- a/man/isNaDS.Rd +++ b/man/isNaDS.Rd @@ -20,4 +20,6 @@ of booleans it returns just one boolean to tell if all the element are missing v } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/lengthDS.Rd b/man/lengthDS.Rd index bfadf14f..18a6a32e 100644 --- a/man/lengthDS.Rd +++ b/man/lengthDS.Rd @@ -22,4 +22,6 @@ The function returns the length of the input vector or list. } \author{ Demetris Avraam, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index 87ab11a1..c54b7d13 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -22,4 +22,6 @@ The function returns the levels of the input vector or list. } \author{ Alex Westerberg, for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/namesDS.Rd b/man/namesDS.Rd index 951bfdd0..8eb4ad0c 100644 --- a/man/namesDS.Rd +++ b/man/namesDS.Rd @@ -31,4 +31,6 @@ is formally of double class "glm" and "ls" but responds TRUE to is.list(), } \author{ Amadou Gaye, updated by Paul Burton 25/06/2020 + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/numNaDS.Rd b/man/numNaDS.Rd index 0d213261..572507fa 100644 --- a/man/numNaDS.Rd +++ b/man/numNaDS.Rd @@ -20,4 +20,6 @@ in a vector. } \author{ Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/man/uniqueDS.Rd b/man/uniqueDS.Rd index 4168fd1b..4efedf80 100644 --- a/man/uniqueDS.Rd +++ b/man/uniqueDS.Rd @@ -21,4 +21,6 @@ The function computes the uniques values of a variable. } \author{ Stuart Wheater for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } From b3f190ca0e6e612e8b49852a7859b9db190523d6 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 11:05:28 +0200 Subject: [PATCH 58/65] test: updated expectations now some functions return a list --- tests/testthat/test-smk-isNaDS.R | 36 +++++++++++++++--------------- tests/testthat/test-smk-levelsDS.R | 2 -- tests/testthat/test-smk-numNaDS.R | 12 +++++----- 3 files changed, 24 insertions(+), 26 deletions(-) diff --git a/tests/testthat/test-smk-isNaDS.R b/tests/testthat/test-smk-isNaDS.R index 0cbdecd8..33012766 100644 --- a/tests/testthat/test-smk-isNaDS.R +++ b/tests/testthat/test-smk-isNaDS.R @@ -25,9 +25,9 @@ test_that("numeric vector isNaDS", { res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("numeric vector isNaDS - with NA single", { @@ -35,9 +35,9 @@ test_that("numeric vector isNaDS - with NA single", { res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("numeric vector isNaDS - with NA all", { @@ -45,9 +45,9 @@ test_that("numeric vector isNaDS - with NA all", { res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, TRUE) }) # context("isNaDS::smk::character vector") @@ -56,9 +56,9 @@ test_that("character vector isNaDS", { res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("character vector isNaDS - with NA single", { @@ -66,9 +66,9 @@ test_that("character vector isNaDS - with NA single", { res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, FALSE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, FALSE) }) test_that("character vector isNaDS - with NA all", { @@ -76,9 +76,9 @@ test_that("character vector isNaDS - with NA all", { res <- isNaDS("input") - expect_length(res, 1) - expect_equal(class(res), "logical") - expect_equal(res, TRUE) + expect_length(res$is.na, 1) + expect_equal(class(res$is.na), "logical") + expect_equal(res$is.na, TRUE) }) test_that("isNaDS throws error when object does not exist", { diff --git a/tests/testthat/test-smk-levelsDS.R b/tests/testthat/test-smk-levelsDS.R index 28949677..3059e003 100644 --- a/tests/testthat/test-smk-levelsDS.R +++ b/tests/testthat/test-smk-levelsDS.R @@ -35,8 +35,6 @@ test_that("numeric vector levelsDS", { expect_equal(res$Levels[2], "1") expect_equal(res$Levels[3], "2") expect_equal(res$Levels[4], "3") - expect_equal(class(res$ValidityMessage), "character") - expect_equal(res$ValidityMessage, "VALID ANALYSIS") }) test_that("levelsDS throws error when object does not exist", { diff --git a/tests/testthat/test-smk-numNaDS.R b/tests/testthat/test-smk-numNaDS.R index f050d3d8..5040c94c 100644 --- a/tests/testthat/test-smk-numNaDS.R +++ b/tests/testthat/test-smk-numNaDS.R @@ -25,9 +25,9 @@ test_that("simple numNaDS", { res <- numNaDS("input") - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 3) + expect_equal(class(res$numNA), "integer") + expect_length(res$numNA, 1) + expect_equal(res$numNA, 3) }) test_that("simple numNaDS, single NA", { @@ -35,9 +35,9 @@ test_that("simple numNaDS, single NA", { res <- numNaDS("input") - expect_equal(class(res), "integer") - expect_length(res, 1) - expect_equal(res, 1) + expect_equal(class(res$numNA), "integer") + expect_length(res$numNA, 1) + expect_equal(res$numNA, 1) }) test_that("numNaDS throws error when object does not exist", { From 48b6a4eaf57fdf6f2695ce9f983f42944a2c7863 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 11:24:23 +0200 Subject: [PATCH 59/65] revert: delete mistakenly committed file --- R/ihen_outcome.R | 64 ------------------------------------------------ 1 file changed, 64 deletions(-) delete mode 100644 R/ihen_outcome.R diff --git a/R/ihen_outcome.R b/R/ihen_outcome.R deleted file mode 100644 index 4af38652..00000000 --- a/R/ihen_outcome.R +++ /dev/null @@ -1,64 +0,0 @@ -library(dplyr) -library(tidyr) -library(ggplot2) - -# --- Simplified Web Table 7 (with INMA + EDEN collapsed) --- -bmi_data <- data.frame( - Cohort = c("RHEA","CHOP","SWS","GECKO","Raine","INMA","EDEN","GENR", - "ALSPAC","ABCD","NFBC66","NFBC86","BiB","ELFE","DNBC","MoBa"), - n0_1 = c(974,1668,2942,2738,2303,1910,1760,7230,1420,5669,7379,5141,12959,17795,56821,85079), - n2_3 = c(684,938,2701,2212,614,1177,1521,6466,1221,4763,5809,4739,6225,10773,0,45673), - n4_7 = c(887,1092,2166,2309,2088,1634,1278,6572,5682,4754,7268,7110,10539,10192,43164,49728), - n8_13 = c(334,755,1209,2180,1988,1043,904,5723,9585,3603,7239,4750,5592,3360,44177,33473), - n14_17= c(NA,NA,NA,NA,1623,NA,NA,NA,7675,NA,7035,5760,NA,NA,6508,NA) -) - -# --- Reshape --- -bmi_long <- bmi_data %>% - pivot_longer(cols = starts_with("n"), names_to = "Age_group", values_to = "n") %>% - mutate(Age_group = factor(Age_group, - levels = c("n0_1", "n2_3", "n4_7", "n8_13", "n14_17"), - labels = c("0–1 years", "2–3 years", "4–7 years", "8–13 years", "14–17 years"))) %>% - drop_na(n) - -# --- Order cohorts by total contribution --- -bmi_long <- bmi_long %>% - group_by(Cohort) %>% - mutate(total_n = sum(n, na.rm = TRUE)) %>% - ungroup() %>% - arrange(total_n) - -# --- Split into 5 cumulative stages --- -n_cohorts <- n_distinct(bmi_long$Cohort) -stage_breaks <- round(seq(1, n_cohorts, length.out = 5)) # 5 roughly equal steps - -# --- Fixed axis limits for identical scaling --- -ymax <- bmi_long %>% - group_by(Age_group) %>% - summarise(total = sum(n)) %>% - summarise(max_total = max(total)) %>% - pull(max_total) - -# --- Loop to create 5 plots --- -for (i in seq_along(stage_breaks)) { - - included <- unique(bmi_long$Cohort)[1:stage_breaks[i]] - plot_data <- bmi_long %>% filter(Cohort %in% included) - - p <- ggplot(plot_data, aes(x = Age_group, y = n, fill = Cohort)) + - geom_bar(stat = "identity", width = 0.7, color = "white") + - scale_y_continuous(labels = scales::comma, limits = c(0, ymax)) + - scale_fill_viridis_d(option = "turbo", direction = -1) + - labs( - x = "Child age group", - y = "Number of BMI z-score observations", - fill = "Cohort" - ) + - theme_minimal(base_size = 13) + - theme( - legend.position = "right", - plot.title = element_blank() - ) - - ggsave(sprintf("bmi_stacked_stage_%02d.png", i), p, width = 7, height = 5, dpi = 300) -} From 885f61f176a53d8a21f70b1f0320afaef29a08d4 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 11:35:38 +0200 Subject: [PATCH 60/65] revert: allow data frames to pass class check and update tests --- R/lengthDS.R | 2 +- tests/testthat/test-smk-lengthDS.R | 24 ++++++++++++++++++------ 2 files changed, 19 insertions(+), 7 deletions(-) diff --git a/R/lengthDS.R b/R/lengthDS.R index 5aefca58..1c793aa0 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -12,7 +12,7 @@ #' lengthDS <- function(x){ x.val <- .loadServersideObject(x) - .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list")) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list", "data.frame")) list(length = length(x.val), class = class(x.val)) } #AGGREGATE FUNCTION diff --git a/tests/testthat/test-smk-lengthDS.R b/tests/testthat/test-smk-lengthDS.R index 67454a8b..b410915d 100644 --- a/tests/testthat/test-smk-lengthDS.R +++ b/tests/testthat/test-smk-lengthDS.R @@ -56,12 +56,24 @@ test_that("lengthDS throws error when object does not exist", { ) }) -test_that("lengthDS throws error when object is not a permitted type", { - bad_input <- data.frame(a = 1:3) - expect_error( - lengthDS("bad_input"), - regexp = "must be of type" - ) +test_that("simple lengthDS, numeric data.frame", { + input <- data.frame(v1 = c(0.0, 1.0, 2.0, 3.0, 4.0), v2 = c(4.0, 3.0, 2.0, 1.0, 0.0)) + + res <- lengthDS("input") + + expect_equal(class(res), "list") + expect_equal(res$length, 2) + expect_equal(res$class, "data.frame") +}) + +test_that("simple lengthDS, character data.frame", { + input <- data.frame(v1 = c("0.0", "1.0", "2.0", "3.0", "4.0"), v2 = c("4.0", "3.0", "2.0", "1.0", "0.0"), stringsAsFactors = FALSE) + + res <- lengthDS("input") + + expect_equal(class(res), "list") + expect_equal(res$length, 2) + expect_equal(res$class, "data.frame") }) # From c74488d8371462afb0dfc28d4a7aeb01bec391a8 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 13 Apr 2026 14:25:05 +0200 Subject: [PATCH 61/65] refactor: remove class from levelsDS return, update test --- R/levelsDS.R | 7 +++---- tests/testthat/test-smk-levelsDS.R | 2 +- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/R/levelsDS.R b/R/levelsDS.R index 6fca2b14..33c33ec6 100644 --- a/R/levelsDS.R +++ b/R/levelsDS.R @@ -3,9 +3,8 @@ #' @description This function is similar to R function \code{levels}. #' @details The function returns the levels of the input vector or list. #' @param x a factor vector -#' @return a list with two elements: \code{Levels} (the factor levels present -#' in the vector) and \code{class} (the class of the input object, for -#' client-side consistency checking) +#' @return a list with one element: \code{Levels} (the factor levels present +#' in the vector) #' @author Alex Westerberg, for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export @@ -33,7 +32,7 @@ levelsDS <- function(x){ stop("FAILED: Result length less than nfilter.levels.density of input length.", call. = FALSE) } - out.obj <- list(Levels=out, class=class(x.val)) + out.obj <- list(Levels=out) return(out.obj) } #AGGREGATE FUNCTION diff --git a/tests/testthat/test-smk-levelsDS.R b/tests/testthat/test-smk-levelsDS.R index 3059e003..2c313e1a 100644 --- a/tests/testthat/test-smk-levelsDS.R +++ b/tests/testthat/test-smk-levelsDS.R @@ -27,7 +27,7 @@ test_that("numeric vector levelsDS", { res <- levelsDS("input") - expect_length(res, 2) + expect_length(res, 1) expect_equal(class(res), "list") expect_equal(class(res$Levels), "character") expect_length(res$Levels, 4) From bb3054c21dd10ad68aaf0e0f6d9f2c31da905351 Mon Sep 17 00:00:00 2001 From: Stuart Wheater Date: Thu, 14 May 2026 13:36:54 +0100 Subject: [PATCH 62/65] Added 'libuv1-dev' dependency --- azure-pipelines.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index abbcc444..a0e6a96c 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -104,7 +104,7 @@ jobs: sudo apt-get install -qq pkg-config -y sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgit2-dev libharfbuzz-dev libfribidi-dev libfontconfig1-dev -y - sudo apt-get install -qq libfreetype6-dev libpng-dev libtiff5-dev libjpeg-dev -y + sudo apt-get install -qq libfreetype6-dev libpng-dev libtiff5-dev libjpeg-dev libuv1-dev -y sudo apt-get install -qq r-base -y sudo R -e "install.packages('devtools', dependencies=TRUE)" sudo R -e "install.packages('RANN', dependencies=TRUE)" From 5f650657f02e651220515240f6ce4c2321d6edfa Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Mon, 1 Jun 2026 14:24:53 +0200 Subject: [PATCH 63/65] Add array and matrix to lengthDS permitted classes --- R/lengthDS.R | 2 +- tests/testthat/test-smk-lengthDS.R | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/R/lengthDS.R b/R/lengthDS.R index 1c793aa0..0441e67c 100644 --- a/R/lengthDS.R +++ b/R/lengthDS.R @@ -12,7 +12,7 @@ #' lengthDS <- function(x){ x.val <- .loadServersideObject(x) - .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list", "data.frame")) + .checkClass(obj = x.val, obj_name = x, permitted_classes = c("character", "factor", "integer", "logical", "numeric", "list", "data.frame", "array", "matrix")) list(length = length(x.val), class = class(x.val)) } #AGGREGATE FUNCTION diff --git a/tests/testthat/test-smk-lengthDS.R b/tests/testthat/test-smk-lengthDS.R index b410915d..d91fafd9 100644 --- a/tests/testthat/test-smk-lengthDS.R +++ b/tests/testthat/test-smk-lengthDS.R @@ -76,6 +76,26 @@ test_that("simple lengthDS, character data.frame", { expect_equal(res$class, "data.frame") }) +test_that("simple lengthDS, matrix", { + input <- matrix(1:6, nrow = 2, ncol = 3) + + res <- lengthDS("input") + + expect_equal(class(res), "list") + expect_equal(res$length, 6) + expect_equal(res$class, c("matrix", "array")) +}) + +test_that("simple lengthDS, array", { + input <- array(1:24, dim = c(2, 3, 4)) + + res <- lengthDS("input") + + expect_equal(class(res), "list") + expect_equal(res$length, 24) + expect_equal(res$class, "array") +}) + # # Done # From 2e6b5f40d9f48fd6bdc6b9a8bade0d0cb39cb744 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 2 Jun 2026 08:39:14 +0200 Subject: [PATCH 64/65] bumped roxygen to version 8 --- DESCRIPTION | 2 +- man/levelsDS.Rd | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a6737e2e..52c47835 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -76,7 +76,7 @@ Imports: Suggests: spelling, testthat (>= 3.0.0) -RoxygenNote: 7.3.3 +RoxygenNote: 8.0.0 Encoding: UTF-8 Language: en-GB Config/testthat/edition: 3 diff --git a/man/levelsDS.Rd b/man/levelsDS.Rd index c54b7d13..4002c73c 100644 --- a/man/levelsDS.Rd +++ b/man/levelsDS.Rd @@ -10,9 +10,8 @@ levelsDS(x) \item{x}{a factor vector} } \value{ -a list with two elements: \code{Levels} (the factor levels present - in the vector) and \code{class} (the class of the input object, for - client-side consistency checking) +a list with one element: \code{Levels} (the factor levels present + in the vector) } \description{ This function is similar to R function \code{levels}. From c56e03c9c892d74c60e18e9d429349b7e67e7753 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Tue, 2 Jun 2026 08:39:27 +0200 Subject: [PATCH 65/65] test: add density test for levels --- tests/testthat/test-smk-levelsDS.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/testthat/test-smk-levelsDS.R b/tests/testthat/test-smk-levelsDS.R index 2c313e1a..43fd7658 100644 --- a/tests/testthat/test-smk-levelsDS.R +++ b/tests/testthat/test-smk-levelsDS.R @@ -52,6 +52,15 @@ test_that("levelsDS throws error when object is not a factor", { ) }) +test_that("levelsDS blocks when levels density exceeds threshold", { + input <- factor(1:10, levels = 1:10) + + expect_error( + levelsDS("input"), + regexp = "nfilter.levels.density" + ) +}) + # # Done #