tests/testthat/test.shift_array.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

context("shift_array")


f <- function(...){
  dim <- c(10,12,30,1)
  x <- array(rnorm(prod(dim)), dim)

  shifts <- sample(dim[3], dim[1])
  shifts[1] <- NA
  f1 <- function(){
    dipsaus::shift_array(x, 3, 1, shifts)
  }
  f2 <- function(){
    tm <- seq_len(dim[3])
    re <- sapply(seq_len(dim[1]), function(ii){
      shift <- shifts[ii]
      new_idx <- tm + shift
      new_idx[new_idx > dim[3]] <- NA
      x[ii,,new_idx,]
    })
    dim(re) <- c(dim(x)[-1], dim[1])
    re <- aperm(re, c(4,1,2,3))
    re
  }

  rg <- range(f2()-f1(), na.rm = TRUE)
  expect_equivalent(rg, c(0,0))


}

test_that('testing shift_array correctness', {

  capture_output({
    lapply(1:5, f)

    dim <- c(10,12,30,1)
    x <- array(rnorm(prod(dim)), dim)

    shifts <- sample(dim[3], dim[1])
    shifts[1] <- NA
    expect_error({
      dipsaus::shift_array(x, 3, 3, shifts)
    })

    expect_error({
      dipsaus::shift_array(x, 3, 0, shifts)
    })

    expect_error({
      dipsaus::shift_array(x, 3, -1, shifts)
    })

    expect_error({
      dipsaus::shift_array(x, 3, 5, shifts)
    })

    expect_error({
      dipsaus::shift_array(x, 0, 1, shifts)
    })
    expect_error({
      dipsaus::shift_array(x, -1, 1, shifts)
    })
    expect_error({
      dipsaus::shift_array(x, 5, 1, shifts)
    })
  })
})