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..4be99bf7 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 +#' @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 #' -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..64acb279 100644 --- a/R/reShapeDS.R +++ b/R/reShapeDS.R @@ -35,18 +35,16 @@ #' @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 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..7183edc9 100644 --- a/man/changeRefGroupDS.Rd +++ b/man/changeRefGroupDS.Rd @@ -4,18 +4,18 @@ \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{ -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}, @@ -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/reShapeDS.Rd b/man/reShapeDS.Rd index 2a0ace77..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 @@ -71,4 +68,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..d9f2ae83 100644 --- a/tests/testthat/test-smk-asFactorDS2.R +++ b/tests/testthat/test-smk-asFactorDS2.R @@ -20,99 +20,29 @@ 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) +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) - 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") + 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)) }) -# -# Done -# - -# context("asFactorDS2::smk::shutdown") - -# context("asFactorDS2::smk::done") +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 7e871da3..97a3e36f 100644 --- a/tests/testthat/test-smk-asFactorSimpleDS.R +++ b/tests/testthat/test-smk-asFactorSimpleDS.R @@ -20,38 +20,17 @@ 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")) + expect_equal(as.character(res), as.character(input)) }) -# -# 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..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. @@ -15,99 +14,41 @@ # 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), c("2", "1", "4", "6", "8")) + expect_equal(as.character(res), c("8", "1", "6", "1", "4", "1", "2", "1")) }) -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) +test_that("changeRefGroupDS with reorderByRef", { + xf <- as.factor(c(8, 1, 6, 1, 4, 1, 2, 1)) - res.num <- as.numeric(res) + res <- changeRefGroupDS("xf", ref = 2, reorderByRef = TRUE) - 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") - } + 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")) }) -# -# Done -# - -# context("changeRefGroupDS::smk::shutdown") +test_that("changeRefGroupDS errors when serverside object does not exist", { + expect_error(changeRefGroupDS("nonexistent_object", ref = 1, reorderByRef = FALSE), + regexp = "does not exist") +}) -# 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..8021bae1 --- /dev/null +++ b/tests/testthat/test-smk-dmtC2SDS.R @@ -0,0 +1,30 @@ + +# +# 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..c75d78db --- /dev/null +++ b/tests/testthat/test-smk-reShapeDS.R @@ -0,0 +1,49 @@ + +# +# 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)) +}) + +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") +})