From d828a767c1012e8143e36bb5e24205f9d7ac5cf0 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 9 Mar 2023 13:30:26 +0100 Subject: [PATCH] Reorder attribute 'dimensions' along --- R/Reorder.R | 48 +++++++++++++++++++++++++++++------ man/Reorder.Rd | 15 ++++++++--- tests/testthat/test-Reorder.R | 46 +++++++++++++++++++++++++++++++++ 3 files changed, 98 insertions(+), 11 deletions(-) diff --git a/R/Reorder.R b/R/Reorder.R index 0431207..71a22e3 100644 --- a/R/Reorder.R +++ b/R/Reorder.R @@ -1,10 +1,14 @@ #'Reorder the dimension of an array #' -#'Reorder the dimension order of a multi-dimensional array +#'Reorder the dimensions of a multi-dimensional array. The order can be provided +#'either as indices or the dimension names. If the order is dimension name, +#'the function looks for names(dim(x)). If it doesn't exist, the function checks +#' if attributes "dimensions" exists; this attribute is in the objects generated +#' by Load(). #' -#'@param data An array of which the dimension to be reordered. +#'@param data An array of which the dimensions to be reordered. #'@param order A vector of indices or character strings indicating the new -#' order of the dimension. +#' order of the dimensions. #' #'@return An array which has the same values as parameter 'data' but with #' different dimension order. @@ -15,6 +19,11 @@ #' print(dim(Reorder(dat1, c('sdate', 'dat', 'lon', 'ftime')))) #' dat2 <- array(c(1:10), dim = c(2, 1, 5)) #' print(dim(Reorder(dat2, c(2, 1, 3)))) +#' attr(dat2, 'dimensions') <- c('sdate', 'time', 'region') +#' dat2_reorder <- Reorder(dat2, c('time', 'sdate', 'region')) +#' # A character array +#' dat3 <- array(paste0('a', 1:24), dim = c(b = 2, c = 3, d = 4)) +#' dat3_reorder <- Reorder(dat3, c('d', 'c', 'b')) #'@export Reorder <- function(data, order) { @@ -27,6 +36,9 @@ Reorder <- function(data, order) { stop("Parameter 'data' must be an array.") } + ## If attribute "dimensions" exists + attr.dim.reorder <- ifelse(!is.null(attributes(data)$dimensions), TRUE, FALSE) + ## order if (is.null(order)) { stop("Parameter 'order' cannot be NULL.") @@ -42,7 +54,23 @@ Reorder <- function(data, order) { } } if (is.character(order)) { - if (!all(order %in% names(dim(data)))) { + if (is.null(names(dim(data)))) { + if (attr.dim.reorder) { + warning("Found dimension names in attributes. Use them to reorder.") + dim_names <- attributes(data)$dimensions + } else { + stop("The array doesn't have dimension names.") + } + } else { + dim_names <- names(dim(data)) + if (attr.dim.reorder) { + if (any(attributes(data)$dimensions != dim_names)) { + warning("Found attribute 'dimensions' has different names from ", + "names(dim(x)). Use the latter one to reorder.") + } + } + } + if (!all(order %in% dim_names)) { stop("Parameter 'order' do not match the dimension names of parameter 'data'.") } } @@ -52,13 +80,12 @@ Reorder <- function(data, order) { } - ############################### # Reorder ## If order is character string, find the indices if (is.character(order)) { - order <- match(order, names(dim(data))) + order <- match(order, dim_names) } ## reorder @@ -73,10 +100,15 @@ Reorder <- function(data, order) { y <- array(1:length(data), dim = dim(data)) y <- aperm(y, order) data <- data[as.vector(y)] + dim(data) <- old_dims[order] } - dim(data) <- old_dims[order] + if (attr.dim.reorder) { + attr_bk$dimensions <- attr_bk$dimensions[order] + } + attributes(data) <- c(attributes(data), attr_bk) - data + + return(data) } diff --git a/man/Reorder.Rd b/man/Reorder.Rd index 8748aaf..c4e4a23 100644 --- a/man/Reorder.Rd +++ b/man/Reorder.Rd @@ -7,17 +7,21 @@ Reorder(data, order) } \arguments{ -\item{data}{An array of which the dimension to be reordered.} +\item{data}{An array of which the dimensions to be reordered.} \item{order}{A vector of indices or character strings indicating the new -order of the dimension.} +order of the dimensions.} } \value{ An array which has the same values as parameter 'data' but with different dimension order. } \description{ -Reorder the dimension order of a multi-dimensional array +Reorder the dimensions of a multi-dimensional array. The order can be provided +either as indices or the dimension names. If the order is dimension name, +the function looks for names(dim(x)). If it doesn't exist, the function checks +if attributes "dimensions" exists; this attribute is in the objects generated +by Load(). } \examples{ dat1 <- array(c(1:30), dim = c(dat = 1, sdate = 3, ftime = 2, lon = 5)) @@ -25,4 +29,9 @@ Reorder the dimension order of a multi-dimensional array print(dim(Reorder(dat1, c('sdate', 'dat', 'lon', 'ftime')))) dat2 <- array(c(1:10), dim = c(2, 1, 5)) print(dim(Reorder(dat2, c(2, 1, 3)))) + attr(dat2, 'dimensions') <- c('sdate', 'time', 'region') + dat2_reorder <- Reorder(dat2, c('time', 'sdate', 'region')) + # A character array + dat3 <- array(paste0('a', 1:24), dim = c(b = 2, c = 3, d = 4)) + dat3_reorder <- Reorder(dat3, c('d', 'c', 'b')) } diff --git a/tests/testthat/test-Reorder.R b/tests/testthat/test-Reorder.R index 0e8e5b5..b17259e 100644 --- a/tests/testthat/test-Reorder.R +++ b/tests/testthat/test-Reorder.R @@ -7,10 +7,15 @@ context("s2dv::Reorder tests") # dat2 set.seed(10) dat2 <- array(rnorm(10), dim = c(2, 1, 5)) + dat2_1 <- dat2 + attr(dat2_1, 'dimensions') <- c('sdate', 'time', 'region') # dat3 dat3 <- array(c(1:30), dim = c(dat = 1, 3, ftime = 2, 5)) + # dat4: A character array + dat4 <- array(paste0('a', 1:24), dim = c(b = 2, c = 3, d = 4)) + ############################################## test_that("1. Input checks", { @@ -66,10 +71,18 @@ test_that("2. Output checks: dat1", { dim(Reorder(dat1, c(2,1,4,3))), c(sdate = 3, dat = 1, lon = 5, ftime = 2) ) + expect_equal( + c(Reorder(dat1, c(2,1,4,3))[2,1,,1]), + c(2, 8, 14, 20, 26) + ) expect_equal( dim(Reorder(dat1, c('sdate', 'dat', 'lon', 'ftime'))), c(sdate = 3, dat = 1, lon = 5, ftime = 2) ) + expect_equal( + c(Reorder(dat1, c('sdate', 'dat', 'lon', 'ftime'))[2,1,,1]), + c(2, 8, 14, 20, 26) + ) expect_equal( max(Reorder(dat1, c(2, 1, 4, 3)), na.rm = TRUE), 30 @@ -85,6 +98,26 @@ test_that("3. Output checks: dat2", { dim(Reorder(dat2, c(2, 1, 3))), c(1, 2, 5) ) + expect_equal( + c(Reorder(dat2, c(2, 1, 3))[1, , 3]), + c(0.2945451, 0.3897943), + tolerance = 0.0001 + ) + expect_equal( + suppressWarnings(dim(Reorder(dat2_1, c('time', 'sdate', 'region')))), + c(1, 2, 5) + ) + expect_equal( + suppressWarnings(c(Reorder(dat2_1, c('time', 'sdate', 'region'))[1, , 3])), + c(0.2945451, 0.3897943), + tolerance = 0.0001 + ) + expect_equal( + suppressWarnings( + attributes(Reorder(dat2_1, c('time', 'sdate', 'region')))$dimensions + ), + c('time', 'sdate', 'region') + ) }) @@ -100,3 +133,16 @@ test_that("4. Output checks: dat3", { }) ############################################## +test_that("5. Output checks: dat4", { + res <- Reorder(dat4, c('d', 'c', 'b')) + expect_equal( + dim(res), + c(d = 4, c = 3, b = 2) + ) + expect_equal( + c(res[1, 1, ]), + c("a1", "a2") + ) + +}) + -- GitLab