test-use-cases.R

                   dim = c(d = 4, a = 10, c = 3)),
         b = array(sapply(c(10, 20, 30), function(x) {
                     1:10 + x
                   }),
                   dim = c(a = 10, c = 3)),
         c = array(sapply(c(10, 20, 30), function(x) {
                     sapply(1:10, function(y) {
                       rep(rep(y, 4) + x - 1, 30)
                     })
                   }),
                   dim = c(b = 4, e = 5, f = 6, a = 10, c = 3)))
  )
###second in first dim as target
  # unnamed input dim
  # unnamed output
  # unnamed output dim
  f <- function(x, y) {
    list(array(rev(y)),
         mean(x) + mean(y),
         array(rep(x + y - 1, 30), dim = c(3, 5, 6)))
  }
  expect_equal(
    Apply(list(array(1:10, dim = c(10, 4)), 
               array(1:3 * 10, dim = c(3))),
          list(NULL, 1), f),
    list(output1 = array(rep(sapply(1:10, 
                               function(x) {
                                 c(30, 20, 10)
                               }), 4),
                         dim = c(3, 10, 4)),
         output2 = array(rep(sapply(1:10, 
                               function(x) {
                                 20 + x
                               }), 4),
                         dim = c(10, 4)),
         output3 = array(rep(sapply(1:10, 
                               function(x) {
                                 rep(c(10, 20, 30) + x - 1, 30)
                               }), 4),
                         dim = c(3, 5, 6, 10, 4)))
  )
  # named input dim
  # named output
  # named output dim
  f <- function(x, y) {
    list(a = array(rev(y), dim = c(d = 3)),
         b = mean(x) + mean(y),
         c = array(rep(x + y - 1, 30), dim = c(c = 3, e = 5, f = 6)))
  }
  expect_equal(
    Apply(list(array(1:10, dim = c(a = 10, b = 4)), 
               array(1:3 * 10, dim = c(c = 3))),
          list(NULL, 'c'), f),
    list(a = array(rep(sapply(1:10, 
                         function(x) {
                           c(30, 20, 10)
                         }), 4),
                   dim = c(d = 3, a = 10, b = 4)),
         b = array(rep(sapply(1:10, 
                         function(x) {
                           20 + x
                         }), 4),
                   dim = c(a = 10, b = 4)),
         c = array(rep(sapply(1:10, 
                         function(x) {
                           rep(c(10, 20, 30) + x - 1, 30)
                         }), 4),
                   dim = c(c = 3, e = 5, f = 6, a = 10, b = 4)))
  )
##one shared margin. the remaining dim in first in is the target
  # named input dim
  # named output
  # named output dim
  f <- function(x, y) {
    list(a = array(x[1]:(x[1] + length(x) - 1), dim = c(d = 4)),
         b = mean(x) + mean(y),
         c = array(rep(x + y - 1, 30), dim = c(b = 4, e = 5, f = 6)))
  }
  expect_equal(
    Apply(list(array(1:3, dim = c(a = 3, b = 4)), 
               array(1:3 * 10, dim = c(a = 3))),
          list('b', NULL), f),
    list(a = array(sapply(c(10, 20, 30), function(x) {
                     sapply(1:4, function(y) {
                       y[1]:(y[1] + 3)
                     })
                   }), 
                   dim = c(d = 4, a = 3)),
         b = array(sapply(c(1:3), function(x) {
                     x + x * 10
                   }),
                   dim = c(a = 3)),
         c = array(sapply(c(1:3), function(x) {
                     rep(x * 10 + rep(x, 4) - 1, 30)
                   }),
                   dim = c(b = 4, e = 5, f = 6, a = 3)))
  )

#one target dim from each in
##no shared target
##shared target

#two target dims first in, no target dim second in

#all target dims
##no shared target
  # unnamed input dim
  # unnamed output
  # unnamed output dim
  f <- function(x, y) {
    list(array(rowMeans(x)),
         mean(x) + mean(y),
         array(sapply(y, function(z) z + x - 1), dim = c(10, 4, 3)))
  }
  expect_equal(
    Apply(list(array(1:10, dim = c(10, 4)), 
               array(1:3 * 10, dim = c(3))),
          list(c(1, 2), 1), f),
    list(output1 = array(1:10),
         output2 = 25.5,
         output3 = array(sapply(c(10, 20, 30), 
                           function(x) {
                             rep(1:10, 4) + x - 1
                           }),
                         dim = c(10, 4, 3)))
  )
  # named input dim
  # named output
  # named output dim
  f <- function(x, y) {
    list(a = array(rowMeans(x), c(a = 10)),
         b = mean(x) + mean(y),
         c = array(sapply(y, function(z) z + x - 1), 
                   dim = c(a = 10, b = 4, c = 3)))
  }
  expect_equal(
    Apply(list(array(1:10, dim = c(a = 10, b = 4)), 
               array(1:3 * 10, dim = c(c = 3))),
          list(c('a', 'b'), 'c'), f),
    list(a = array(1:10, dim = c(a = 10)),
         b = 25.5,
         c = array(sapply(c(10, 20, 30), 
                     function(x) {
                       rep(1:10, 4) + x - 1
                     }),
                   dim = c(a = 10, b = 4, c = 3)))
  )
##shared target
  # named input dim
  # named output
  # named output dim
  f <- function(x, y) {
    list(a = array(rowMeans(x), c(a = 10)),
         b = mean(x) + mean(y),
         c = array(rep(t(apply(x, 1, function(z) z * y)), 3),
                   dim = c(a = 10, b = 4, c = 3)))
  }
  expect_equal(
    Apply(list(array(1:10, dim = c(a = 10, b = 4)), 
               array(1:4 * 10, dim = c(b = 4))),
          list(c('a', 'b'), 'b'), f),
    list(a = array(1:10, dim = c(a = 10)),
         b = 30.5,
         c = array(rep(sapply(c(10, 20, 30, 40), 
                         function(x) {
                           1:10 * x
                         }), 
                       3),
                   dim = c(a = 10, b = 4, c = 3)))
  )
})

##test_that("in1: 2 dim; in2: 3 dim; targ. dims: 0-2, 0-3; out1: 2 dim", {
### shared first target dim
### shared second target dim
### shared two target dims (first two in second in)
### shared two target dims (last two in second in)
### shared two target dims (extreme two in second in)
### not shared target dims
##})
#
#test_that("in1: 2 dim; in2: 3 dim; targ. dims: 0-2, 0-3; out1: 1 dim; out2: 1 val; out3: 3 dim", {
## shared first target dim
## shared second target dim
## shared two target dims (first two in second in)
## shared two target dims (last two in second in)
## shared two target dims (extreme two in second in)
## not shared target dims
#})
#
#test_that("in1: 2 dim; in2: 3 dim; in3: 1 dim; targ. dims: 0-2, 0-3, 0-1; out1: 2 dim", {
## shared first target dim
## shared second target dim
## shared two target dims (first two in second in)
## shared two target dims (last two in second in)
## shared two target dims (extreme two in second in)
## not shared target dims
#})

# Real cases
test_that("real use case - standardization", {
  standardization <- function(x, mean, deviation){
    r <- (x - mean) / deviation
    names(dim(r)) <- NULL
    r
  }

  x <- array(1:(2*3*4), dim = c(mod = 2, lon = 3, lat = 4))
  y <- array(1:12, dim = c(lon = 3, lat = 4))
  z <- array(1:12, dim = c(lon = 3, lat = 4))

  expected_result <- array(c(0:11 / z, rep(1, 3 * 4)), dim = c(3, 4, mod = 2))

  expect_equal(
    Apply(data = list(x,y,z), 
          target_dims = list(c('lon', 'lat'),
                             c('lon', 'lat'),
                             c('lon', 'lat')), 
          fun = standardization)$output1,
    expected_result
  )

  names(dim(expected_result)) <- c('lon', 'lat', 'mod')

  expect_equal(
    Apply(data = list(x,y,z), 
          margins = list('mod', NULL, NULL), 
          fun = standardization,
          output_dims = c('lon', 'lat')
         )$output1,
    expected_result
  )

  expect_equal(
    Apply(data = list(x,y,z), 
          margins = list(c('mod', 'lat'), 'lat', 'lat'), 
          fun = standardization,
          output_dims = c('lon')
         )$output1,
    multiApply:::.aperm2(expected_result, c(1, 3, 2))
  )

  x <- multiApply:::.aperm2(x, c(3, 2, 1))

  expect_equal(
    Apply(data = list(x,y,z), 
          target_dims = list(c('lon', 'lat'),
                             c('lon', 'lat'),
                             c('lon', 'lat')), 
          fun = standardization,
          output_dims = c('lon', 'lat')
         )$output1,
    expected_result
  )

})

# Test margin indices and extra info
test_that("Margin indices and extra info are provided correctly.", {
  a <- array(1:prod(1:6), dim = c(a = 1, b = 2, c = 3, d = 4, e = 5, f = 6))
  b <- array(1:prod(c(1, 2, 3, 5, 6)), dim = c(a = 1, b = 2, c = 3, e = 5, f = 6))

  attr(a, 'test_attr_a') <- 'test_a'
  attr(b, 'test_attr_b') <- list(x = 1, z = 2)

  f <- function(a, b) {
    stopifnot(length(.margin_indices) == 3)
    stopifnot(identical(names(.margin_indices), c('a', 'e', 'f')))
    stopifnot(all(is.integer(.margin_indices)))
    stopifnot(identical(.test_info, 'test'))
    stopifnot(!is.null(attr(a, 'test_attr_a')))
    stopifnot(identical(attr(a, 'test_attr_a'), 'test_a'))
    stopifnot(!is.null(attr(b, 'test_attr_b')))
    stopifnot(identical(attr(b, 'test_attr_b'), list(x = 1, z = 2)))
  }

  r <- multiApply::Apply(list(a, b), 
                         list(c('b', 'c', 'd'), 
                              c('b', 'c')),
                         extra_info = list(test_info = 'test'),
                         use_attributes = list(a = 'test_attr_a',
                                               b = 'test_attr_b'),
                         f)

  r <- multiApply::Apply(list(a = a, b = b), 
                         list(c('b', 'c', 'd'), 
                              c('b', 'c')),
                         extra_info = list(test_info = 'test'),
                         use_attributes = list(a = 'test_attr_a',
                                               b = 'test_attr_b'),
                         f)

  r <- multiApply::Apply(list(a = a, b = b), 
                         list(c('b', 'c', 'd'), 
                              c('b', 'c')),
                         extra_info = list(test_info = 'test'),
                         use_attributes = list(b = 'test_attr_b',
                                               a = 'test_attr_a'),
                         f)

  attr(b, 'test_attr_b') <- list(x = 1, z = 2)
  attr(b, 'z') <- 3

  f <- function(a, b) {
    stopifnot(identical(attr(b, 'test_attr_b')$z, 2))
    stopifnot(identical(attr(b, 'z'), 3))
  }

  r <- multiApply::Apply(list(a = a, b = b), 
                         list(c('b', 'c', 'd'), 
                              c('b', 'c')),
                         extra_info = list(test_info = 'test'),
                         use_attributes = list(b = c('test_attr_b', 'z'),
                                               a = 'test_attr_a'),
                         f)

  f <- function(a, b) {
    stopifnot(identical(attr(b, 'test_attr_b')$z, 2))
    stopifnot(is.null(attr(b, 'test_attr_b')$x))
    stopifnot(is.null(attr(b, 'z')))
  }

  r <- multiApply::Apply(list(a = a, b = b), 
                         list(c('b', 'c', 'd'), 
                              c('b', 'c')),
                         extra_info = list(test_info = 'test'),
                         use_attributes = list(b = list(c('test_attr_b', 'z')),
                                               a = 'test_attr_a'),
                         f)
})

# Test .aperm2
test_that(".aperm2", {
  data <- seq(as.POSIXct('1990-11-01'), 
              length.out = 6,
              by = as.difftime(1, units = 'days'))
  dim(data) <- c(3, 2)
  expect_equal(
    class(multiApply:::.aperm2(data, c(2, 1))),
    c('POSIXct', 'POSIXt')
  )
})

# Test dim names passed on properly
test_that("Dimension names are propagated correctly.", {
  a <- array(1:prod(1:6), dim = c(a = 1, b = 2, c = 3, d = 4, e = 5, f = 6))
  b <- array(1:prod(c(1, 2, 3, 5, 6)), dim = c(a = 1, b = 2, c = 3, e = 5, f = 6))

  f <- function(a, b) {
    stopifnot(identical(names(dim(a)), c('b', 'c', 'd')))
    stopifnot(identical(names(dim(b)), c('b', 'c')))
  }

  r <- multiApply::Apply(list(a, b), 
                         list(c('b', 'c', 'd'), 
                              c('b', 'c')), 
                         f)
})

# Test nested environments are linked properly
test_that("Nested environments are linked properly.", {
  #create input
  forecast <- array(dim = c('31', '12', '4'), 
                    rnorm(31 * 12 * 4))
  names(dim(forecast)) <- c('sday', 'syear', 'ensemble')

  anomaly_simple <- function(data) {
    avg <- Apply(data, c('syear', 'ensemble'), mean)[[1]]
    anom <- Apply(data, c('sday'), function(x) x - avg)[[1]]
    return(anom)
  }

  anomaly <- anomaly_simple(forecast)
})

# TODOS:
# TESTS FOR MARGINS
# TESTS FOR DISORDERED TARGET_DIMS
# TESTS FOR FUN WITH TARGET_DIMS AND OUTPUT_DIMS ATTACHED
# TESTS FOR FUNCTIONS RECEIVING ADDITIONAL PARAMETERS
# TESTS FOR SPLIT FACTOR
# TESTS FOR NCORES
# TESTS OF WALLCLOCK TIME
# TESTS OF MEMORY FOOTPRINT