From 99638d245c401e2dcbc40d3f8a1e0982ef980fe1 Mon Sep 17 00:00:00 2001 From: nperez Date: Mon, 2 Dec 2019 12:30:09 +0100 Subject: [PATCH 1/2] Function MergeDimsand CST_MergeDims --- R/CST_MergeDims.R | 116 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 R/CST_MergeDims.R diff --git a/R/CST_MergeDims.R b/R/CST_MergeDims.R new file mode 100644 index 00000000..d258ac85 --- /dev/null +++ b/R/CST_MergeDims.R @@ -0,0 +1,116 @@ +#'Function to Merge Dimensions +#' +#'@author Nuria Perez-Zanon, \email{nuria.perez@bsc.es} +#' +#'@description This function merges two dimensions of the array \code{data} in a 's2dv_cube' object into one. The user can select the dimensions to merge and provide the final name of the dimension. The user can select to remove NA values or keep them. +#' +#'@param data a 's2dv_cube' object +#'@param merge_dims a character vector indicating the names of the dimensions to merge +#'@param remane_dim a character string indicating the name of the output dimension. If left at NULL, the first dimension name provided in parameter \code{merge_dims} will be used. +#'@param na.rm a logical indicating if the NA values should be removed or not. +#' +#'@import abind +#'@import s2dverification +#'@examples +#' +#'data <- 1 : c(2 * 3 * 4 * 5 * 6 * 7) +#'dim(data) <- c(time = 7, lat = 2, lon = 3, monthly = 4, member = 6, +#' dataset = 5, var = 1) +#'data[2,,,,,,] <- NA +#'data[c(3,27)] <- NA +#'data <-list(data = data) +#'class(data) <- 's2dv_cube' +#'new_data <- CST_MergeDims(data, merge_dims = c('time', 'monthly')) +#'dim(new_data$data) +#'new_data <- CST_MergeDims(data, merge_dims = c('lon', 'lat'), rename_dim = 'grid') +#'dim(new_data$data) +#'new_data <- CST_MergeDims(data, merge_dims = c('time', 'monthly'), na.rm = TRUE) +#'dim(new_data$data) +#'@export +CST_MergeDims <- function(data, merge_dims = c('ftime', 'monthly'), rename_dim = NULL, + na.rm = FALSE) { + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.") + } + data$data <- MergeDims(data$data, merge_dims = merge_dims, + rename_dim = rename_dim, na.rm = na.rm) + return(data) +} +#'Function to Split Dimension +#' +#'@author Nuria Perez-Zanon, \email{nuria.perez@bsc.es} +#' +#'@description This function merges two dimensions of an array into one. The user can select the dimensions to merge and provide the final name of the dimension. The user can select to remove NA values or keep them. +#' +#'@param data an n-dimensional array with named dimensions +#'@param merge_dims a character vector indicating the names of the dimensions to merge +#'@param remane_dim a character string indicating the name of the output dimension. If left at NULL, the first dimension name provided in parameter \code{merge_dims} will be used. +#'@param na.rm a logical indicating if the NA values should be removed or not. +#' +#'@import abind +#'@import s2dverification +#'@examples +#' +#'data <- 1 : 20 +#'dim(data) <- c(time = 10, lat = 2) +#'new_data <- MergeDims(data, merge_dims = c('time', 'lat')) +#'@export +MergeDims <- function(data, merge_dims = c('time', 'monthly'), rename_dim = NULL, + na.rm = FALSE) { + # check data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (is.null(dim(data))) { + stop("Parameter 'data' must have dimensions.") + } + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have dimension names.") + } + dims <- dim(data) + # check merge_dims + if (is.null(merge_dims)) { + stop("Parameter 'merge_dims' cannot be NULL.") + } + if (!is.character(merge_dims)) { + stop("Parameter 'merge_dims' must be a character vector ", + "indicating the names of the dimensions to be merged.") + } + if (length(merge_dims) > 2) { + warning("Only two dimensions can be merge, only the first two ", + "dimension will be used. To merge further dimensions ", + "consider to use this function multiple times.") + merge_dims <- merge_dims[1 : 2] + } + if (is.null(rename_dim)) { + rename_dim <- merge_dims[1] + } + if (length(rename_dim) > 1) { + warning("Parameter 'rename_dim' has length greater than 1 ", + "and only the first element will be used.") + rename_dim <- as.character(rename_dim[1]) + } + if (!any(names(dims) %in% merge_dims)) { + stop("Parameter 'merge_dims' must match with dimension ", + "names in parameter 'data'.") + } + pos1 <- which(names(dims) == merge_dims[1]) + pos2 <- which(names(dims) == merge_dims[2]) + if (pos1 > pos2) { + pos1 <- pos1 - 1 + } + data <- lapply(1 : dims[pos2], function(x) {Subset(data, along = pos2, + indices = x, drop = 'selected')}) + data <- abind(data, along = pos1) + names(dim(data)) <- names(dims)[-pos2] + if (na.rm) { + nas <- which(is.na(Subset(data, along = -pos1, indices = 1))) + nas <- unlist(lapply(nas, function(x) { + if(all(is.na(Subset(data, along = pos1, + indices = x)))) { + return(x)}})) + data <- Subset(data, along = pos1, indices = -nas) + } +return(data) +} -- GitLab From 4e069b47b30b9cc2829f09020a42810a98ea42c9 Mon Sep 17 00:00:00 2001 From: nperez Date: Mon, 9 Dec 2019 11:15:07 +0100 Subject: [PATCH 2/2] unit tests for CST_MergeDims --- R/CST_MergeDims.R | 21 +++++++--- tests/testthat/test-CST_MergeDims.R | 65 +++++++++++++++++++++++++++++ 2 files changed, 81 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/test-CST_MergeDims.R diff --git a/R/CST_MergeDims.R b/R/CST_MergeDims.R index d258ac85..560f6c97 100644 --- a/R/CST_MergeDims.R +++ b/R/CST_MergeDims.R @@ -82,6 +82,8 @@ MergeDims <- function(data, merge_dims = c('time', 'monthly'), rename_dim = NULL "dimension will be used. To merge further dimensions ", "consider to use this function multiple times.") merge_dims <- merge_dims[1 : 2] + } else if (length(merge_dims) < 2) { + stop("Parameter 'merge_dims' must be of length two.") } if (is.null(rename_dim)) { rename_dim <- merge_dims[1] @@ -97,6 +99,10 @@ MergeDims <- function(data, merge_dims = c('time', 'monthly'), rename_dim = NULL } pos1 <- which(names(dims) == merge_dims[1]) pos2 <- which(names(dims) == merge_dims[2]) + if (length(pos1) == 0 | length(pos2) == 0) { + stop("Parameter 'merge_dims' must match with dimension ", + "names in parameter 'data'.") + } if (pos1 > pos2) { pos1 <- pos1 - 1 } @@ -104,13 +110,18 @@ MergeDims <- function(data, merge_dims = c('time', 'monthly'), rename_dim = NULL indices = x, drop = 'selected')}) data <- abind(data, along = pos1) names(dim(data)) <- names(dims)[-pos2] + if (!is.null(rename_dim)) { + names(dim(data))[pos1] <- rename_dim + } if (na.rm) { nas <- which(is.na(Subset(data, along = -pos1, indices = 1))) - nas <- unlist(lapply(nas, function(x) { - if(all(is.na(Subset(data, along = pos1, - indices = x)))) { - return(x)}})) - data <- Subset(data, along = pos1, indices = -nas) + if (length(nas) != 0) { + nas <- unlist(lapply(nas, function(x) { + if(all(is.na(Subset(data, along = pos1, + indices = x)))) { + return(x)}})) + data <- Subset(data, along = pos1, indices = -nas) + } } return(data) } diff --git a/tests/testthat/test-CST_MergeDims.R b/tests/testthat/test-CST_MergeDims.R new file mode 100644 index 00000000..45bcd8e9 --- /dev/null +++ b/tests/testthat/test-CST_MergeDims.R @@ -0,0 +1,65 @@ +context("Generic tests") +test_that("Sanity checks", { + expect_error( + CST_MergeDims(data = 1), + paste0("Parameter 'data' must be of the class 's2dv_cube', ", + "as output by CSTools::CST_Load.")) +data <- list(data = 1:10) +class(data) <- 's2dv_cube' + expect_error( + CST_MergeDims(data = data), + paste0("Parameter 'data' must have dimensions.")) + + data <- 1 : 20 + dim(data) <- c(time = 20) + data <- list(data = data) + class(data) <- 's2dv_cube' + expect_error( + CST_MergeDims(data = data), + "Parameter 'merge_dims' must match with dimension names in parameter 'data'.") + expect_error( + CST_MergeDims(data = data, merge_dims = 1), + paste0("Parameter 'merge_dims' must be a character vector indicating the names", + " of the dimensions to be merged.")) + expect_error( + CST_MergeDims(data = data, merge_dims = 'time'), + "Parameter 'merge_dims' must be of length two.") + expect_error( + CST_MergeDims(data = data, merge_dims = c('time', 'sdates')), + paste0("Parameter 'merge_dims' must match with dimension ", + "names in parameter 'data'.")) + + exp <- 1 : 20 + dim(exp) <- c(time = 10, lat = 2) + exp <- list(data = exp) + class(exp) <- 's2dv_cube' + expect_equal( + CST_MergeDims(data = exp, merge_dims = c('time', 'lat')), data) + + expect_warning( + CST_MergeDims(data = exp, merge_dims = c('time', 'lat', 'lon')), + paste0("Only two dimensions can be merge, only the first two dimension", + " will be used. To merge further dimensions consider to use this ", + "function multiple times.")) + expect_warning( + CST_MergeDims(data = exp, merge_dims = c('time', 'lat'), rename_dim = c('lat', 'lon')), + paste0("Parameter 'rename_dim' has length greater than 1 and only the ", + "first element will be used.")) + names(dim(data$data)) <- 'Dim1' + expect_equal( + CST_MergeDims(data = exp, merge_dims = c('time', 'lat'), rename_dim = 'Dim1'), + data) + + expect_equal( + CST_MergeDims(data = exp, merge_dims = c('time', 'lat'), + rename_dim = 'Dim1', na.rm = TRUE), data) + + exp$data[1,] <- NA + data <- c(2 : 10, 12 : 20) + dim(data) <- c(Dim1 = 18) + data <- list(data = data) + class(data) <- 's2dv_cube' + expect_equal( + CST_MergeDims(data = exp, merge_dims = c('time', 'lat'), + rename_dim = 'Dim1', na.rm = TRUE), data) +}) -- GitLab