tests/testthat/test-collapse.R

In filearray: File-Backed Array for Out-of-Memory Computation

# Testing collapse is time consuming, skip if ran
skip_collapse <- Sys.getenv("FILEARRAY_SKIP_COLLAPSE", unset = "") == "TRUE"
testthat::skip_if(skip_collapse)

collapse_real <- function(y, keep, transform = c("asis", "10log10", "square", "sqrt", "normalize")){
    re <- switch (
        transform,
        'asis' = {
            apply(y, keep, function(x){
                mean(x)
            })
        },
        '10log10' = {
            apply(y, keep, function(x){
                mean(10* log10(x))
            })
        },
        'square' = {
            apply(y, keep, function(x){
                mean(x^2)
            })
        },
        'sqrt' = {
            apply(y, keep, function(x){
                mean(sqrt(x))
            })
        }, {
            stop("wrong transform")
        }
    )
    # if(storage.mode(re) != "double"){
    #     storage.mode(re) <- 'double'
    # }
    re
}

collapse_cplx <- function(y, keep, transform = c("asis", "10log10", "square", "sqrt", "normalize")){
    re <- switch (
        transform,
        'asis' = {
            apply(y, keep, mean)
        },
        '10log10' = {
            apply(y, keep, function(x){
                mean(20 * log10(Mod(x)))
            })
        },
        'square' = {
            apply(y, keep, function(x){
                mean(Mod(x)^2)
            })
        },
        'sqrt' = {
            apply(y, keep, function(x){
                mean(Mod(x))
            })
        },
        'normalize' = {
            apply(y, keep, function(x){
                mean(x / Mod(x))
            })
        },
        {
            stop("wrong transform")
        }
    )
    # if(storage.mode(re) != "double"){
    #     storage.mode(re) <- 'double'
    # }
    re
}

expect_equivalent_cplx <- function(x, y, eps = 1e-6){
    expect_equal(is.na(x), is.na(y))
    if(is.complex(x)){
        expect_lte(max(abs(Re(x - y)), na.rm = TRUE), eps)
        expect_lte(max(abs(Im(x - y)), na.rm = TRUE), eps)
    } else {
        expect_lte(max(abs(x - y), na.rm = TRUE), eps)
    }
}

test_that("R/C++ - Collapse", {
    testthat::skip_on_cran()
    bsz <- get_buffer_size()
    on.exit({
        set_buffer_size(bsz)
        max_buffer_size(2097152)
    })
    set_buffer_size(16L)
    max_buffer_size(64L)

    # dim <- c(287, 100, 301, 7)
    dim <- c(33:36)
    set.seed(5)
    file <- tempfile()
    unlink(file, recursive = TRUE)
    x <- filearray_create(file, dim, type = "integer", partition_size = 2, initialize = FALSE)
    y <- array(1:(prod(dim)), dim)
    y[[20, 3, 3, 3]] <- NA
    storage.mode(y) <- "integer"
    x[] <- y

    # make sure x[] == y
    expect_equal(x[], y)



    # collapse
    keep <- c(1,2,3,4)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }

    keep <- c(1,4,3,2)
    expect_equal(
        x$collapse(keep = keep, transform = 'asis', method = 'mean'),
        collapse_real(y, keep, transform = 'asis')
    )

    keep <- c(4,2,3,1)
    expect_equal(
        x$collapse(keep = keep, transform = 'asis', method = 'mean'),
        collapse_real(y, keep, transform = 'asis')
    )

    keep <- c(3,1)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }

    keep <- c(4,1)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }

    keep <- c(4,2)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }
    keep <- c(4,3)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }
    keep <- c(4)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        k <- x$collapse(keep = keep, transform = transform, method = 'mean')
        s <- collapse_real(y, keep, transform = transform)
        diff <- max(abs(1-s / k), na.rm = TRUE)
        # cat(transform, diff, "\n")
        expect_lt(diff, 1e-6)
    }
    keep <- c(4,1,3)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }
    keep <- c(3)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        k <- x$collapse(keep = keep, transform = transform, method = 'mean')
        s <- collapse_real(y, keep, transform = transform)
        diff <- max(abs(1-s / k), na.rm = TRUE)
        # cat(transform, diff, "\n")
        expect_lt(diff, 1e-6)
    }
    keep <- c(1)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        k <- x$collapse(keep = keep, transform = transform, method = 'mean')
        s <- collapse_real(y, keep, transform = transform)
        diff <- max(abs(1-s / k), na.rm = TRUE)
        # cat(transform, diff, "\n")
        expect_lt(diff, 1e-6)
    }

})

test_that("R/C++ - Float", {
    testthat::skip_on_cran()
    bsz <- get_buffer_size()
    on.exit({
        set_buffer_size(bsz)
        max_buffer_size(2097152)
    })
    set_buffer_size(16L)
    max_buffer_size(64L)

    # dim <- c(287, 100, 301, 7)
    dim <- c(33:36)
    set.seed(5)
    file <- tempfile()
    unlink(file, recursive = TRUE)
    x <- filearray_create(file, dim, type = "float", partition_size = 2, initialize = FALSE)
    y <- array(rnorm(length(x))^2, dim)
    y[[20, 3, 3, 3]] <- NA
    x[] <- y

    # make sure x[] == y
    eps <- 10^(ceiling(log10(max(abs(y), na.rm = TRUE))) - 7)
    expect_equal(x[], y, tolerance = eps)
    y <- x[]



    # collapse
    keep <- c(1,2,3,4)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }

    keep <- c(1,4,3,2)
    expect_equal(
        x$collapse(keep = keep, transform = 'asis', method = 'mean'),
        collapse_real(y, keep, transform = 'asis')
    )

    keep <- c(4,2,3,1)
    expect_equal(
        x$collapse(keep = keep, transform = 'asis', method = 'mean'),
        collapse_real(y, keep, transform = 'asis')
    )

    keep <- c(3,1)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }

    keep <- c(4,1)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }

    keep <- c(4,2)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }
    keep <- c(4,3)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }
    keep <- c(4)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        k <- x$collapse(keep = keep, transform = transform, method = 'mean')
        s <- collapse_real(y, keep, transform = transform)
        diff <- max(abs(1-s / k), na.rm = TRUE)
        # cat(transform, diff, "\n")
        expect_lt(diff, 1e-6)
    }
    keep <- c(4,1,3)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_real(y, keep, transform = transform)
        )
    }
    keep <- c(3)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        k <- x$collapse(keep = keep, transform = transform, method = 'mean')
        s <- collapse_real(y, keep, transform = transform)
        diff <- max(abs(1-s / k), na.rm = TRUE)
        # cat(transform, diff, "\n")
        expect_lt(diff, 1e-6)
    }
    keep <- c(1)
    for(transform in c("asis", "10log10", "square", "sqrt")){
        k <- x$collapse(keep = keep, transform = transform, method = 'mean')
        s <- collapse_real(y, keep, transform = transform)
        diff <- max(abs(1-s / k), na.rm = TRUE)
        # cat(transform, diff, "\n")
        expect_lt(diff, 1e-6)
    }

})

test_that("R/C++ - Collapse (complex)", {
    testthat::skip_on_cran()
    bsz <- get_buffer_size()
    on.exit({
        set_buffer_size(bsz)
        max_buffer_size(2097152)
    })
    set_buffer_size(16L)
    max_buffer_size(64L)

    # dim <- c(287, 100, 301, 7)
    dim <- c(33:36)
    set.seed(5)
    file <- tempfile()
    unlink(file, recursive = TRUE)
    x <- filearray_create(file, dim, type = "complex", partition_size = 2, initialize = FALSE)
    y <- array(rnorm(length(x)) + rnorm(length(x)) * 1i, dim)
    y[[20, 3, 3, 3]] <- NA
    x[] <- y

    # make sure x[] == y
    expect_equivalent_cplx(x[], y)

    y <- x[]

    # collapse
    keep <- c(1,2,3,4)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_cplx(y, keep, transform = transform)
        )
    }

    keep <- c(1,4,3,2)
    expect_equal(
        x$collapse(keep = keep, transform = 'asis', method = 'mean'),
        collapse_cplx(y, keep, transform = 'asis')
    )

    keep <- c(4,2,3,1)
    expect_equal(
        x$collapse(keep = keep, transform = 'asis', method = 'mean'),
        collapse_cplx(y, keep, transform = 'asis')
    )

    keep <- c(3,1)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_cplx(y, keep, transform = transform)
        )
    }

    keep <- c(4,1)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_cplx(y, keep, transform = transform)
        )
    }

    keep <- c(4,2)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_cplx(y, keep, transform = transform)
        )
    }
    keep <- c(4,3)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_cplx(y, keep, transform = transform)
        )
    }
    keep <- c(4)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            max(abs(x$collapse(keep = keep, transform = transform, method = 'mean')-
                        collapse_cplx(y, keep, transform = transform)), na.rm = TRUE),
            0
        )
    }
    keep <- c(4,1,3)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            x$collapse(keep = keep, transform = transform, method = 'mean'),
            collapse_cplx(y, keep, transform = transform)
        )
    }
    keep <- c(3)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            max(abs(x$collapse(keep = keep, transform = transform, method = 'mean')-
                        collapse_cplx(y, keep, transform = transform)), na.rm = TRUE),
            0
        )
    }
    keep <- c(1)
    for(transform in c("asis", "10log10", "square", "sqrt", "normalize")){
        expect_equal(
            max(abs(x$collapse(keep = keep, transform = transform, method = 'mean')-
                        collapse_cplx(y, keep, transform = transform)), na.rm = TRUE),
            0
        )
    }

})


Sys.setenv("FILEARRAY_SKIP_COLLAPSE" = "TRUE")