From 0e5a8e7ff95a3afe94a69bc234196cd700f0dc0f Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Wed, 15 Apr 2026 15:22:27 +0200 Subject: [PATCH 1/3] refactor: batch-6 factor and recoding server functions --- R/asFactorDS1.R | 3 +- R/asFactorDS2.R | 3 +- R/asFactorSimpleDS.R | 3 +- R/changeRefGroupDS.R | 16 ++-- R/reShapeDS.R | 5 +- man/asFactorDS1.Rd | 3 + man/asFactorDS2.Rd | 3 + man/asFactorSimpleDS.Rd | 3 + man/changeRefGroupDS.Rd | 8 +- man/levelsDS.Rd | 5 +- man/reShapeDS.Rd | 2 + tests/testthat/test-smk-asFactorDS1.R | 11 +-- tests/testthat/test-smk-asFactorDS2.R | 96 ++------------------- tests/testthat/test-smk-asFactorSimpleDS.R | 33 ++------ tests/testthat/test-smk-changeRefGroupDS.R | 98 ++++------------------ tests/testthat/test-smk-dmtC2SDS.R | 40 +++++++++ tests/testthat/test-smk-reShapeDS.R | 46 ++++++++++ 17 files changed, 153 insertions(+), 225 deletions(-) create mode 100644 tests/testthat/test-smk-dmtC2SDS.R create mode 100644 tests/testthat/test-smk-reShapeDS.R diff --git a/R/asFactorDS1.R b/R/asFactorDS1.R index 6d4f0507..c6c0445a 100644 --- a/R/asFactorDS1.R +++ b/R/asFactorDS1.R @@ -7,6 +7,7 @@ #' are of type character. #' @param input.var.name the name of the variable that is to be converted to a factor. #' @return the levels of the input variable. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asFactorDS1 <- function(input.var.name=NULL){ @@ -24,7 +25,7 @@ asFactorDS1 <- function(input.var.name=NULL){ nfilter.levels.max <- as.numeric(thr$nfilter.levels.max) # ################################################################## - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) factor.levels.present.in.source <- levels(factor(input.var)) num.levels<-length(factor.levels.present.in.source) diff --git a/R/asFactorDS2.R b/R/asFactorDS2.R index 74af1d67..af45a47f 100644 --- a/R/asFactorDS2.R +++ b/R/asFactorDS2.R @@ -15,11 +15,12 @@ #' @param baseline.level a number indicating the baseline level to be used in the creation of the #' matrix of dummy variables. #' @return an object of class factor +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asFactorDS2 <- function(input.var.name=NULL, all.unique.levels.transmit=NULL, fixed.dummy.vars=NULL, baseline.level=NULL){ - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) code.input <- all.unique.levels.transmit code.c <- unlist(strsplit(code.input, split=",")) diff --git a/R/asFactorSimpleDS.R b/R/asFactorSimpleDS.R index 80a14b27..b23c8244 100644 --- a/R/asFactorSimpleDS.R +++ b/R/asFactorSimpleDS.R @@ -12,11 +12,12 @@ #' of these things you will have to use the ds.asFactor function. #' @param input.var.name the name of the variable that is to be converted to a factor. #' @return an object of class factor +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' asFactorSimpleDS <- function(input.var.name=NULL){ - input.var <- eval(parse(text=input.var.name), envir = parent.frame()) + input.var <- .loadServersideObject(input.var.name) factor.obj <- factor(input.var) diff --git a/R/changeRefGroupDS.R b/R/changeRefGroupDS.R index b99cc0ee..6b1aae3a 100644 --- a/R/changeRefGroupDS.R +++ b/R/changeRefGroupDS.R @@ -7,16 +7,20 @@ #' as this can introduce a mismatch of values if the vector is put back #' into a table that is not reordered in the same way. Such mismatch #' can render the results of operations on that table invalid. -#' @param xvect a factor vector +#' @param x a character string, the name of a factor vector. #' @param ref a character, the reference level -#' @param reorderByRef a boolean that tells whether or not the new +#' @param reorderByRef a boolean that tells whether or not the new #' vector should be ordered by the reference group. #' @return a factor of the same length as xvect #' @author Isaeva, J., Gaye, A. +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export #' -changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){ - +changeRefGroupDS <- function(x, ref=NULL, reorderByRef=NULL){ + + xvect <- .loadServersideObject(x) + .checkClass(obj = xvect, obj_name = x, permitted_classes = "factor") + if(reorderByRef){ temp_xvect = stats::relevel(xvect, ref) # now reorder puting the ref group first @@ -26,7 +30,7 @@ changeRefGroupDS <- function(xvect, ref=NULL, reorderByRef=NULL){ }else{ new_xvect <- stats::relevel(xvect, ref) } - + return(new_xvect) - + } diff --git a/R/reShapeDS.R b/R/reShapeDS.R index 2ec368a5..524a346d 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -39,14 +39,15 @@ #' indicating whether has been created in each data source and if so whether #' it is in a valid form (see header for \code{ds.reShape}. #' @author Demetris Avraam, Paul Burton for DataSHIELD Development Team +#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export reShapeDS <- function(data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep){ # Check Permissive Privacy Control Level. dsBase::checkPermissivePrivacyControlLevel(c('permissive', 'banana', 'carrot')) - datatext <- paste0("data.frame(",data.name,")") - data <- eval(parse(text=datatext), envir = parent.frame()) + data <- .loadServersideObject(data.name) + data <- data.frame(data) timevar <- timevar.name idvar <- idvar.name diff --git a/man/asFactorDS1.Rd b/man/asFactorDS1.Rd index f337a23e..69d8ca34 100644 --- a/man/asFactorDS1.Rd +++ b/man/asFactorDS1.Rd @@ -21,3 +21,6 @@ The function encodes the input vector as factor and returns its levels in ascending order if the levels are numerical or in alphabetical order if the levels are of type character. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/asFactorDS2.Rd b/man/asFactorDS2.Rd index 16b4a50f..006e2bac 100644 --- a/man/asFactorDS2.Rd +++ b/man/asFactorDS2.Rd @@ -37,3 +37,6 @@ The functions converts the input variable into a factor which is presented as a if the \code{fixed.dummy.vars} is set to FALSE or as a matrix with dummy variables if the \code{fixed.dummy.vars} is set to TRUE (see the help file of ds.asFactor.b for more details). } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/asFactorSimpleDS.Rd b/man/asFactorSimpleDS.Rd index d0916749..2b234c9a 100644 --- a/man/asFactorSimpleDS.Rd +++ b/man/asFactorSimpleDS.Rd @@ -26,3 +26,6 @@ In addition, it does not allow you to create an array of binary dummy variables that is equivalent to a factor. If you need to do any of these things you will have to use the ds.asFactor function. } +\author{ +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands +} diff --git a/man/changeRefGroupDS.Rd b/man/changeRefGroupDS.Rd index 05fe80cf..b48be075 100644 --- a/man/changeRefGroupDS.Rd +++ b/man/changeRefGroupDS.Rd @@ -4,14 +4,14 @@ \alias{changeRefGroupDS} \title{Changes a reference level of a factor} \usage{ -changeRefGroupDS(xvect, ref = NULL, reorderByRef = NULL) +changeRefGroupDS(x, ref = NULL, reorderByRef = NULL) } \arguments{ -\item{xvect}{a factor vector} +\item{x}{a character string, the name of a factor vector.} \item{ref}{a character, the reference level} -\item{reorderByRef}{a boolean that tells whether or not the new +\item{reorderByRef}{a boolean that tells whether or not the new vector should be ordered by the reference group.} } \value{ @@ -30,4 +30,6 @@ can render the results of operations on that table invalid. } \author{ Isaeva, J., Gaye, A. + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } 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}. diff --git a/man/reShapeDS.Rd b/man/reShapeDS.Rd index 2a0ace77..70515104 100644 --- a/man/reShapeDS.Rd +++ b/man/reShapeDS.Rd @@ -71,4 +71,6 @@ measurements in separate records. The reshaping can be in either direction } \author{ Demetris Avraam, Paul Burton for DataSHIELD Development Team + +Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands } diff --git a/tests/testthat/test-smk-asFactorDS1.R b/tests/testthat/test-smk-asFactorDS1.R index a990d4ff..e7f0abb8 100644 --- a/tests/testthat/test-smk-asFactorDS1.R +++ b/tests/testthat/test-smk-asFactorDS1.R @@ -21,7 +21,6 @@ set.standard.disclosure.settings() # Tests # -# 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) @@ -34,10 +33,6 @@ test_that("simple asFactorDS1", { expect_equal(res[3], "3") }) -# -# Done -# - -# context("asFactorDS1::smk::shutdown") - -# context("asFactorDS1::smk::done") +test_that("asFactorDS1 errors when serverside object does not exist", { + expect_error(asFactorDS1("nonexistent_object"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index 1c761d4d..1e842328 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.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. @@ -20,99 +21,16 @@ set.standard.disclosure.settings() # Tests # -# 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" - fixed.dummy.vars <- FALSE - baseline.level <- NULL +test_that("simple asFactorDS2", { + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level) + res <- asFactorDS2("input", "1,2,3,4", FALSE, NULL) expect_equal(class(res), "factor") expect_length(res, 10) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 4) - - expect_equal(res.levels[1], "1") - expect_equal(res.levels[2], "2") - expect_equal(res.levels[3], "3") - expect_equal(res.levels[4], "4") + expect_equal(levels(res), c("1", "2", "3", "4")) }) -test_that("simple asFactorDS2, fixed.dummy.vars is TRUE", { - input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) - all.unique.levels.transmit <- "1,2,3,4" - fixed.dummy.vars <- TRUE - baseline.level <- 1.0 - - res <- asFactorDS2("input", all.unique.levels.transmit, fixed.dummy.vars, baseline.level) - - expect_length(res, 30) - - 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_equal(res[1], 1) - expect_equal(res[2], 0) - expect_equal(res[3], 0) - expect_equal(res[4], 0) - expect_equal(res[5], 0) - expect_equal(res[6], 0) - expect_equal(res[7], 1) - expect_equal(res[8], 1) - expect_equal(res[9], 0) - expect_equal(res[10], 1) - expect_equal(res[11], 0) - expect_equal(res[12], 0) - expect_equal(res[13], 1) - expect_equal(res[14], 1) - expect_equal(res[15], 1) - expect_equal(res[16], 0) - expect_equal(res[17], 0) - expect_equal(res[18], 0) - expect_equal(res[19], 0) - expect_equal(res[20], 0) - expect_equal(res[21], 0) - expect_equal(res[22], 0) - expect_equal(res[23], 0) - expect_equal(res[24], 0) - expect_equal(res[25], 0) - expect_equal(res[26], 0) - expect_equal(res[27], 0) - expect_equal(res[28], 0) - expect_equal(res[29], 0) - expect_equal(res[30], 0) - - - res.colnames <- colnames(res) - - expect_equal(class(res.colnames), "character") - expect_length(res.colnames, 3) - - expect_equal(res.colnames[1], "DV2") - expect_equal(res.colnames[2], "DV3") - expect_equal(res.colnames[3], "DV4") +test_that("asFactorDS2 errors when serverside object does not exist", { + expect_error(asFactorDS2("nonexistent_object", "1,2", FALSE, NULL), regexp = "does not exist") }) - -# -# Done -# - -# context("asFactorDS2::smk::shutdown") - -# context("asFactorDS2::smk::done") diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index 7e871da3..a12df35b 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. @@ -20,38 +21,16 @@ set.standard.disclosure.settings() # Tests # -# 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) + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) res <- asFactorSimpleDS("input") expect_equal(class(res), "factor") expect_length(res, 10) - expect_true(res[1] == "2") - expect_true(res[2] == "1") - expect_true(res[3] == "3") - expect_true(res[4] == "3") - expect_true(res[5] == "3") - expect_true(res[6] == "1") - expect_true(res[7] == "2") - expect_true(res[8] == "2") - expect_true(res[9] == "1") - expect_true(res[10] == "2") - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 3) - expect_equal(res.levels[1], "1") - expect_equal(res.levels[2], "2") - expect_equal(res.levels[3], "3") + expect_equal(levels(res), c("1", "2", "3")) }) -# -# Done -# - -# context("asFactorSimpleDS::smk::shutdown") - -# context("asFactorSimpleDS::smk::done") +test_that("asFactorSimpleDS errors when serverside object does not exist", { + expect_error(asFactorSimpleDS("nonexistent_object"), regexp = "does not exist") +}) diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index 3d94fde7..e6a8a4c0 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.R @@ -15,99 +15,29 @@ # context("changeRefGroupDS::smk::setup") +set.standard.disclosure.settings() + # # Tests # -# context("changeRefGroupDS::smk") -test_that("simple changeRefGroupDS, reorderByRef is FALSE", { - x <- c(8, 1, 6, 1, 4, 1, 2, 1) - xf <- as.factor(x) - ref <- 2 - reorderByRef <- FALSE +test_that("simple changeRefGroupDS", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) - res <- changeRefGroupDS(xf, ref, reorderByRef) + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = FALSE) expect_equal(class(res), "factor") expect_length(res, 8) - - res.num <- as.numeric(res) - - expect_equal(class(res.num), "numeric") - expect_length(res.num, 8) - - expect_equal(res.num[1], 5) - expect_equal(res.num[2], 2) - expect_equal(res.num[3], 4) - expect_equal(res.num[4], 2) - expect_equal(res.num[5], 3) - expect_equal(res.num[6], 2) - expect_equal(res.num[7], 1) - expect_equal(res.num[8], 2) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 5) - expect_equal(res.levels[1], "2") - expect_equal(res.levels[2], "1") - expect_equal(res.levels[3], "4") - expect_equal(res.levels[4], "6") - expect_equal(res.levels[5], "8") + expect_equal(levels(res)[1], "2") }) -test_that("simple changeRefGroupDS, reorderByRef is TRUE", { - x <- rep(8, 1, 6, 1, 4, 1, 2, 1) - xf <- as.factor(x) - ref <- 1 - reorderByRef <- TRUE - - res <- changeRefGroupDS(xf, ref, reorderByRef) - - if (base::getRversion() < '4.1.0') - { - expect_equal(class(res), "integer") - expect_length(res, 6) - expect_equal(res[1], 1) - expect_equal(res[2], 1) - expect_equal(res[3], 1) - expect_equal(res[4], 1) - expect_equal(res[5], 1) - expect_equal(res[6], 1) - - res.levels <- levels(res) - - expect_true(is.null(res.levels)) - } - else - { - expect_equal(class(res), "factor") - expect_length(res, 6) - - res.num <- as.numeric(res) - - expect_equal(class(res.num), "numeric") - expect_length(res.num, 6) - - expect_equal(res.num[1], 1) - expect_equal(res.num[2], 1) - expect_equal(res.num[3], 1) - expect_equal(res.num[4], 1) - expect_equal(res.num[5], 1) - expect_equal(res.num[6], 1) - - res.levels <- levels(res) - - expect_equal(class(res.levels), "character") - expect_length(res.levels, 1) - expect_equal(res.levels[1], "8") - } +test_that("changeRefGroupDS errors when serverside object does not exist", { + expect_error(changeRefGroupDS("nonexistent_object", ref = 1, reorderByRef = FALSE), + regexp = "does not exist") }) -# -# Done -# - -# context("changeRefGroupDS::smk::shutdown") - -# context("changeRefGroupDS::smk::done") +test_that("changeRefGroupDS errors when object is not a factor", { + bad_input <- c(1, 2, 3) + expect_error(changeRefGroupDS("bad_input", ref = 1, reorderByRef = FALSE), + regexp = "must be of type") +}) diff --git a/tests/testthat/test-smk-dmtC2SDS.R b/tests/testthat/test-smk-dmtC2SDS.R new file mode 100644 index 00000000..c3f30f7d --- /dev/null +++ b/tests/testthat/test-smk-dmtC2SDS.R @@ -0,0 +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 . +#------------------------------------------------------------------------------- + +# +# Set up +# + +# context("dmtC2SDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple dmtC2SDS returns matrix", { + res <- dmtC2SDS( + dfdata.mat.transmit = "1,2,3,4", + inout.object.transmit = "MAT", + from = "clientside.matdftbl", + nrows.transmit = "2", + ncols.transmit = "2", + colnames.transmit = "a,b", + colclass.transmit = "numeric,numeric", + byrow = FALSE + ) + + expect_true(is.matrix(res)) + expect_equal(nrow(res), 2) + expect_equal(ncol(res), 2) + expect_equal(colnames(res), c("a", "b")) +}) diff --git a/tests/testthat/test-smk-reShapeDS.R b/tests/testthat/test-smk-reShapeDS.R new file mode 100644 index 00000000..ffb1091f --- /dev/null +++ b/tests/testthat/test-smk-reShapeDS.R @@ -0,0 +1,46 @@ +#------------------------------------------------------------------------------- +# 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("reShapeDS::smk::setup") + +set.standard.disclosure.settings() + +# +# Tests +# + +test_that("simple reShapeDS wide to long", { + wide_df <- data.frame( + id = 1:3, + sbp.1 = c(120, 130, 125), + sbp.2 = c(122, 135, 128) + ) + + res <- reShapeDS( + data.name = "wide_df", + varying.transmit = "sbp.1,sbp.2", + v.names.transmit = "sbp", + timevar.name = "time", + idvar.name = "id", + drop.transmit = NULL, + direction = "long", + sep = "." + ) + + expect_s3_class(res, "data.frame") + expect_equal(nrow(res), 6) + expect_true("sbp" %in% colnames(res)) + expect_true("time" %in% colnames(res)) +}) From 7df33f49ce82cf65b7b3906bca5d35e874e64501 Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 17 Jul 2026 16:02:12 +0200 Subject: [PATCH 2/3] restored lost test coverage --- tests/testthat/test-smk-asFactorDS2.R | 14 ++++++++++++- tests/testthat/test-smk-asFactorSimpleDS.R | 2 +- tests/testthat/test-smk-changeRefGroupDS.R | 15 ++++++++++++-- tests/testthat/test-smk-dmtC2SDS.R | 10 ---------- tests/testthat/test-smk-reShapeDS.R | 23 ++++++++++++---------- 5 files changed, 40 insertions(+), 24 deletions(-) diff --git a/tests/testthat/test-smk-asFactorDS2.R b/tests/testthat/test-smk-asFactorDS2.R index 1e842328..d9f2ae83 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.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. @@ -31,6 +30,19 @@ test_that("simple asFactorDS2", { expect_equal(levels(res), c("1", "2", "3", "4")) }) +test_that("asFactorDS2 with fixed dummy variables", { + input <- c(2, 1, 3, 3, 3, 1, 2, 2, 1, 2) + + res <- asFactorDS2("input", "1,2,3,4", TRUE, 1) + + expect_true(is.matrix(res)) + expect_equal(dim(res), c(10L, 3L)) + expect_equal(colnames(res), c("DV2", "DV3", "DV4")) + expect_equal(unname(res[, "DV2"]), c(1, 0, 0, 0, 0, 0, 1, 1, 0, 1)) + expect_equal(unname(res[, "DV3"]), c(0, 0, 1, 1, 1, 0, 0, 0, 0, 0)) + expect_equal(unname(res[, "DV4"]), rep(0, 10)) +}) + test_that("asFactorDS2 errors when serverside object does not exist", { expect_error(asFactorDS2("nonexistent_object", "1,2", FALSE, NULL), regexp = "does not exist") }) diff --git a/tests/testthat/test-smk-asFactorSimpleDS.R b/tests/testthat/test-smk-asFactorSimpleDS.R index a12df35b..97a3e36f 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. @@ -29,6 +28,7 @@ test_that("simple asFactorSimpleDS", { expect_equal(class(res), "factor") expect_length(res, 10) expect_equal(levels(res), c("1", "2", "3")) + expect_equal(as.character(res), as.character(input)) }) test_that("asFactorSimpleDS errors when serverside object does not exist", { diff --git a/tests/testthat/test-smk-changeRefGroupDS.R b/tests/testthat/test-smk-changeRefGroupDS.R index e6a8a4c0..3a3283ad 100644 --- a/tests/testthat/test-smk-changeRefGroupDS.R +++ b/tests/testthat/test-smk-changeRefGroupDS.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. @@ -28,7 +27,19 @@ test_that("simple changeRefGroupDS", { expect_equal(class(res), "factor") expect_length(res, 8) - expect_equal(levels(res)[1], "2") + expect_equal(levels(res), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("8", "1", "6", "1", "4", "1", "2", "1")) +}) + +test_that("changeRefGroupDS with reorderByRef", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) + + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = TRUE) + + expect_equal(class(res), "factor") + expect_length(res, 8) + expect_equal(levels(res), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("2", "8", "1", "6", "1", "4", "1", "1")) }) test_that("changeRefGroupDS errors when serverside object does not exist", { diff --git a/tests/testthat/test-smk-dmtC2SDS.R b/tests/testthat/test-smk-dmtC2SDS.R index c3f30f7d..8021bae1 100644 --- a/tests/testthat/test-smk-dmtC2SDS.R +++ b/tests/testthat/test-smk-dmtC2SDS.R @@ -1,13 +1,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 . -#------------------------------------------------------------------------------- # # Set up diff --git a/tests/testthat/test-smk-reShapeDS.R b/tests/testthat/test-smk-reShapeDS.R index ffb1091f..c75d78db 100644 --- a/tests/testthat/test-smk-reShapeDS.R +++ b/tests/testthat/test-smk-reShapeDS.R @@ -1,13 +1,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 . -#------------------------------------------------------------------------------- # # Set up @@ -44,3 +34,16 @@ test_that("simple reShapeDS wide to long", { expect_true("sbp" %in% colnames(res)) expect_true("time" %in% colnames(res)) }) + +test_that("reShapeDS errors when serverside object does not exist", { + expect_error(reShapeDS( + data.name = "nonexistent_object", + varying.transmit = "sbp.1,sbp.2", + v.names.transmit = "sbp", + timevar.name = "time", + idvar.name = "id", + drop.transmit = NULL, + direction = "long", + sep = "." + ), regexp = "does not exist") +}) From 55bed4e7fedde9d897f8190c4d29920a39700f3e Mon Sep 17 00:00:00 2001 From: Tim Cadman <41470917+timcadman@users.noreply.github.com> Date: Fri, 17 Jul 2026 16:02:31 +0200 Subject: [PATCH 3/3] fixed mistaken copywright addition --- R/changeRefGroupDS.R | 2 +- R/reShapeDS.R | 3 --- man/changeRefGroupDS.Rd | 2 +- man/reShapeDS.Rd | 3 --- 4 files changed, 2 insertions(+), 8 deletions(-) diff --git a/R/changeRefGroupDS.R b/R/changeRefGroupDS.R index 6b1aae3a..4be99bf7 100644 --- a/R/changeRefGroupDS.R +++ b/R/changeRefGroupDS.R @@ -11,7 +11,7 @@ #' @param ref a character, the reference level #' @param reorderByRef a boolean that tells whether or not the new #' vector should be ordered by the reference group. -#' @return a factor of the same length as xvect +#' @return a factor of the same length as the input vector #' @author Isaeva, J., Gaye, A. #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/R/reShapeDS.R b/R/reShapeDS.R index 524a346d..64acb279 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -35,9 +35,6 @@ #' @return a reshaped data.frame converted from long to wide format or from wide to #' long format which is written to the serverside and given the name provided as the #' argument of \code{ds.reShape} or 'newObject' if no name is specified. -#' In addition, two validity messages are returned to the clientside -#' indicating whether has been created in each data source and if so whether -#' it is in a valid form (see header for \code{ds.reShape}. #' @author Demetris Avraam, Paul Burton for DataSHIELD Development Team #' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands #' @export diff --git a/man/changeRefGroupDS.Rd b/man/changeRefGroupDS.Rd index b48be075..7183edc9 100644 --- a/man/changeRefGroupDS.Rd +++ b/man/changeRefGroupDS.Rd @@ -15,7 +15,7 @@ changeRefGroupDS(x, ref = NULL, reorderByRef = NULL) vector should be ordered by the reference group.} } \value{ -a factor of the same length as xvect +a factor of the same length as the input vector } \description{ This function is similar to R function \code{relevel}, diff --git a/man/reShapeDS.Rd b/man/reShapeDS.Rd index 70515104..d61b9f54 100644 --- a/man/reShapeDS.Rd +++ b/man/reShapeDS.Rd @@ -54,9 +54,6 @@ via argument of \code{ds.reShape} function} a reshaped data.frame converted from long to wide format or from wide to long format which is written to the serverside and given the name provided as the argument of \code{ds.reShape} or 'newObject' if no name is specified. -In addition, two validity messages are returned to the clientside -indicating whether has been created in each data source and if so whether -it is in a valid form (see header for \code{ds.reShape}. } \description{ Reshapes a data frame containing longitudinal or