diff --git a/R/CST_MergeDims.R b/R/CST_MergeDims.R new file mode 100644 index 0000000000000000000000000000000000000000..560f6c97b56e651e7cee345d0fdfe7218827c426 --- /dev/null +++ b/R/CST_MergeDims.R @@ -0,0 +1,127 @@ +#'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] + } 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] + } + 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 (length(pos1) == 0 | length(pos2) == 0) { + stop("Parameter 'merge_dims' must match with dimension ", + "names in parameter 'data'.") + } + 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 (!is.null(rename_dim)) { + names(dim(data))[pos1] <- rename_dim + } + if (na.rm) { + nas <- which(is.na(Subset(data, along = -pos1, indices = 1))) + 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 0000000000000000000000000000000000000000..45bcd8e960248b8f3168047786c780dfe9f1b7cd --- /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) +})