tests/testthat/test-removeat.R

In Displayr/flipU: Utilities Used In flip Packages

context("RemoveAt")

# This is also tested extensively in flipTables:RemoveAtRowsAndOrColumns
test_that("RemoveAt: Invalid 'at'", {
    expect_error(RemoveAt(1:5, NA),
                 "'at' must contain character (string) or integer values.",
                 fixed = TRUE)
    expect_error(RemoveAt(1:5, c(3, NA)),
                 "'at' must contain character (string) or integer values.",
                 fixed = TRUE)
    expect_error(RemoveAt(1:5, c(3, -1)),
                 "'at' must contain positive integers.",
                 fixed = TRUE)
    expect_error(RemoveAt(1:5, c(3, 10)),
                 "'at' contains a value of 10 which is bigger than the length of 'x'.",
                 fixed = TRUE)
    expect_equal(RemoveAt(1:5, c(3, 1)), c(2, 4, 5))
    expect_error(RemoveAt(1:5, 1.3, NA),
                 "'at' must contain character (string) or integer values.",
                 fixed = TRUE)
})


test_that("RemoveAt.default: Un-named vector with character 'at'", {
    z <- 1:5
    expect_equal(RemoveAt(z, "A"), z)
    expect_equal(length(RemoveAt(z, names(z))), 5)
    expect_equal(RemoveAt(z, "2,3", split = ","), z[-(2:3)])
})


test_that("RemoveAt.default: Un-named vector with integer 'at'", {
    z <- 1:5
    expect_equal(RemoveAt(z, 1), z[-1])
    expect_equal(length(RemoveAt(z, 1:5)), 0)
})


test_that("RemoveAt.default: Named vector", {
    z <- 1:5
    names(z) <- LETTERS[1:5]
    expect_equal(RemoveAt(z, "A"), z[-1])
    expect_equal(length(RemoveAt(z, names(z))), 0)
    expect_equal(RemoveAt(z, "2,3", split = ","), z[-(2:3)])
})

test_that("RemoveAt.default: list", {
    z <- as.list(1:5)
    names(z) <- LETTERS[1:5]
    expect_equal(RemoveAt(z, "A"), z[-1])
    expect_equal(length(RemoveAt(z, names(z))), 0)
    expect_equal(RemoveAt(z, "2,3", split = ","), as.list(z[-(2:3)]))

    x <- list(1:10, 1:10)
    expect_equal(RemoveAt(x[[1]], at = "sdfds"), x[[1]])
})


test_that("RemoveAt.default: array", {
    z <- array(1:8, dim = c(2, 2, 2),
               dimnames = list(LETTERS[1:2], LETTERS[3:4], LETTERS[5:6]))
    expect_equal(RemoveAt(z, "A"), z[-1, , , drop = FALSE])
    expect_equal(RemoveAt(z, "C"), z[, -1, , drop = FALSE])
    expect_equal(RemoveAt(z, MARGIN = 1, "C"), z)
    expect_equal(RemoveAt(z, MARGIN = 2, "C"), z[, -1, , drop = FALSE])
    expect_equal(RemoveAt(z, MARGIN = 2, "1"), z[, -1, , drop = FALSE])

    z <- array(1:8, dim = c(2, 2, 2),
               dimnames = list(LETTERS[1:2], LETTERS[3:4], NULL))
    expect_equal(RemoveAt(z, "A"), z[-1, , , drop = FALSE])
    expect_equal(RemoveAt(z, "C"), z[, -1, , drop = FALSE])
    expect_equal(RemoveAt(z, MARGIN = 1, "C"), z)
    expect_equal(RemoveAt(z, MARGIN = 2, "C"), z[, -1, , drop = FALSE])

    z <- array(1:8, dim = c(2, 2, 2),
               dimnames = list(NULL, LETTERS[3:4], NULL))
    expect_equal(RemoveAt(z, "A"), z)
    expect_equal(RemoveAt(z, "C"), z[, -1, , drop = FALSE])
    expect_equal(RemoveAt(z, "C", MARGIN = 1), z)
    expect_equal(RemoveAt(z, MARGIN = 2, "C"), z[, -1, , drop = FALSE])

})

test_that("RemoveAt: matrix", {
    z <- matrix(1:4, 2, dimnames = list(LETTERS[1:2], LETTERS[3:4]))
    expect_equal(RemoveAt(z, "A"), z[-1, , drop = FALSE])
    expect_equal(RemoveAt(z, "A", MARGIN = 1), z[-1, , drop = FALSE])
    expect_equal(RemoveAt(z, "A", MARGIN = 2), z)


    x <- matrix(NA, 3, 3, dimnames = list(LETTERS[1:3], LETTERS[1:3]))
    z <- RemoveAt(x, list("A", c("C", "A")))
    expect_equal(z, x[2:3, 2, drop = FALSE])
    z <- RemoveAt(x, list("A", c("C", "A")), MARGIN = 1:2)
    expect_equal(z, x[2:3, 2, drop = FALSE])

    dat <- structure(c(39.9, 45.9, 43.1, 54.2, 43.8, 42, 40.3, 44.7, 42.3),
                     dim = c(9L, 1L),
                     dimnames = list(c("Coca Cola ", "Diet Coke", "Coke Zero",
                                       "Pepsi Light ", "Pepsi Max", "Pepsi ",
                                       "NET Sugarred", "NET Sugarless", "NET"),
                                     "Age in years"),
                     statistic = "Average",
                     name = "Q3. Age in years by Preferred cola",
                     questions = c("Q3. Age in years", "Preferred cola"))
    expect_equal(dim(dat), c(9L, 1L))
    z <- RemoveAt(dat, at = list("Pepsi", c("SUM", "NET")))
    expect_equal(dim(z), c(8L, 1L))
    expect_equal(rownames(z), setdiff(rownames(dat), "Pepsi "))
})

test_that("RemoveAt: data.frame", {
    z <- data.frame(C = 1:2, D = 3:4)
    rownames(z) <- LETTERS[1:2]
    expect_equal(RemoveAt(z, "C"), z[, -1, drop = FALSE])
    expect_equal(RemoveAt(z, "A", MARGIN = 1), z[-1, ])
    expect_equal(RemoveAt(z, "A", MARGIN = 2), z)
    expect_equal(RemoveAt(z, list(NULL, 2)), z[, -2, drop = FALSE])
    expect_equal(RemoveAt(z, list(NULL, "1"), split = TRUE), z[, -1, drop = FALSE])

    x <- matrix(NA, 3, 3, dimnames = list(LETTERS[1:3], LETTERS[1:3]))
    z <- RemoveAt(x, list("A", c("C", "A")))
    expect_equal(z, x[2:3, 2, drop = FALSE])
    z <- RemoveAt(x, list("A", c("C", "A")), MARGIN = 1:2)
    expect_equal(z, x[2:3, 2, drop = FALSE])
    z <- RemoveAt(x, list(c(1, 3), 2))
    expect_equal(z, structure(c(NA, NA), .Dim = 1:2, .Dimnames = list("B", c("A", "C"))))
    questions <- list(
        Q6_A = structure(c(3, 5, 5, 6, 4, 1, 3, 6, 5, 6, 6, 5, 5, 4, 3, 6, 6, 5, 5, 4),
                         .Label = c("Don t Know", "Hate", "Dislike",
                                    "Neither like nor dislike", "Like", "Love"),
                         class = "factor", label = c("Q6_A" = "Q6. Coca Cola")),
        Q6_B = structure(c(5, 2, 6, 3, 6, 1, 4, 3, 5, 6, 2, 3, 3, 3, 6, 5, 5, 3, 3, 4),
                         .Label = c("Don t Know", "Hate", "Dislike",
                                    "Neither like nor dislike", "Like", "Love"),
                         class = "factor", label = c("Q6_B" = "Q6. Diet Coke")),
        Q6_C = structure(c(3, 5, 3, 3, 4, 1, 5, 5, 1, 6, 2, 3, 3, 5, 3, 5, 5, 3, 5, 6),
                         .Label = c("Don t Know", "Hate", "Dislike",
                                    "Neither like nor dislike", "Like", "Love"),
                         class = "factor", label = c("Q6_C" = "Q6. Coke Zero")),
        Q6_D = structure(c(4, 5, 4, 3, 4, 1, 3, 4, 5, 5, 6, 5, 4, 4, 5, 5, 3, 5, 4, 4),
                         .Label = c("Don t Know", "Hate", "Dislike",
                                    "Neither like nor dislike", "Like", "Love"),
                         class = "factor", label = c("Q6_D" = "Q6. Pepsi")),
        Q6_E = structure(c(2, 4, 2, 3, 6, 6, 3, 3, 5, 5, 2, 3, 3, 4, 6, 1, 2, 3, 4, 4),
                         .Label = c("Don t Know", "Hate", "Dislike",
                                    "Neither like nor dislike", "Like", "Love"),
                         class = "factor", label = c("Q6_E" = "Q6. Pepsi Light")),
        Q6_F = structure(c(6, 6, 2, 3, 3, 6, 3, 5, 4, 4, 2, 3, 3, 5, 3, 1, 2, 3, 4, 4),
                         .Label = c("Don t Know", "Hate", "Dislike",
                                    "Neither like nor dislike", "Like", "Love"),
                         class = "factor", label = c("Q6_F" = "Q6. Pepsi Max")))
    dat <- as.data.frame(questions)
    attr(dat, "statistic") <- "means"

    out <- RemoveAt(dat, at = list(NULL, c("Q6_B", "Q6_F", "Q6_C", "Q6_D", "Q6_A")))
    expect_equal(as.vector(attributes(out[[1]])$label), "Q6. Pepsi Light")
    expect_equal(dim(out), c(nrow(dat), 1L))
    expect_equal(attr(out, "statistic"), attr(dat, "statistic"))

    dat2 <- structure(list(Income = structure(c(6L, 6L, 2L, 3L, 3L, 6L, 6L),
                           .Label = c("Less than $15,000", "$15,001 to $30,000",
                                      "$30,001 to $45,000", "$60,001 to $90,000",
                                      "$90,001 to $120,000", "$120,001 to $150,000",
                                      "$150,001 to $200,000", "$200,001 or more"),
                           class = "factor", label = c("d2" = "Income"))),
                      .Names = "Income",
                      row.names = sprintf("Num %d", 1:7),
                      class = "data.frame",
                      scatter.variable.indices = structure(c(NA, 1, NA, NA),
                      .Names = c("x", "y", "sizes", "colors")))
    out2 <- RemoveAt(dat2, list(c("NET", "SUM"), c("NET")), 1:2)
    expect_true(is.data.frame(out2))
})

test_that("RemoveAt: another vector and a list",
{
    dat <- structure(c(39.9, 45.9, 43.1, 54.2, 43.8, 42, 40.3, 44.7, 42.3),
                     .Dim = c(9L, 1L),
                     .Dimnames = list(c("Coca Cola ", "Diet Coke", "a", "Pepsi Light ",
                                        "Pepsi Max", "Pepsi ", "NET Sugarred",
                                         "NET Sugarless", "NET"),
                                      "Age in years"),
                     statistic = "Average",
                     name = "Q3. Age in years by Preferred cola",
                     questions = c("Q3. Age in years", "Preferred cola"))

    x <- list(dat, c(a = 1, aa = 2, aaa = 3))

    expect_equal(dim(RemoveAt(x[[1]], at = "a; aa ", split = "[;,]")), dim(dat) - c(1, 0))
    expect_equal(RemoveAt(x[[2]], at = "a; aa ", split = "[;,]"), x[[2L]][3])

    res <- RemoveAt(dat, at = list(1:3, NULL))
    expect_equal(dimnames(res),
                 list(c("Pepsi Light ", "Pepsi Max", "Pepsi ",
                        "NET Sugarred", "NET Sugarless", "NET"),
                "Age in years"))
})

test_that("DS-3889 Standard ftable behaviour", {
    arr.dimnames <- list(letters[1:4],
                         c("foo", "bar", "baz"),
                         1:2)
    input.arr <- array(24:1, dim = 4:2, dimnames = arr.dimnames)

    ftbl <- ftable(input.arr)
    expect_true(is.null(dimnames(ftbl)))
    expect_equal(RemoveAt(ftbl, as.character(1:2), 2), ftbl)
    expect_equal(RemoveAt(ftbl, 1:3, 1), ftbl[-(1:3), ])
})

# Check flattened tables are filtered correctly

tbls <- readRDS("tbls.rds")

ftbls <- lapply(tbls, ftable)

default.string <- "NET, SUM, NET - SUM"
all.str <- c("NET", "SUM", "NET - SUM")
ftbl.names <- names(ftbls)

deriveDimnames <- function(input.names) {
    if (is.character(input.names)) return(input.names)
    if (!is.list(input.names)) return(NULL)
    constructed.names <- rev(expand.grid(rev(input.names)))
    apply(constructed.names, 1L, paste0, collapse = " - ")
}

addBasicDimnames <- function(tbl) {
    granular.dimnames <- unname(attributes(tbl)[c("row.vars", "col.vars")])
    new.dimnames <- lapply(granular.dimnames, deriveDimnames)
    dimnames(tbl) <- new.dimnames
    tbl
}

ftbls <- lapply(ftbls, addBasicDimnames)

for (i in seq_along(ftbls)) {
    ftbl <- ftbls[[i]]
    ftbl.name <- ftbl.names[[i]]
    row.match <- rownames(ftbl) %in% all.str
    if (any(row.match)) {
        requested.row <- all.str[which(all.str %in% rownames(ftbl))]
        test_that(paste0("Only ", requested.row, " row removed in ", ftbl.name), {
            expected.tbl <- ftbl[!row.match, ]
            expect_equal(RemoveAt(ftbl, requested.row, 1, split = NULL, ignore.case = FALSE), expected.tbl)
            expect_equal(RemoveAt(ftbl, tolower(requested.row), 1, split = NULL, ignore.case = TRUE), expected.tbl)
            expect_equal(RemoveAt(ftbl, default.string, MARGIN = 1, split = "[;,]"), expected.tbl)
            # Check col removed tools
            col.to.remove <- sample.int(ncol(ftbl), size = 1)
            expected.tbl <- ftbl[!row.match, -col.to.remove]
            expect_equal(RemoveAt(ftbl, list(requested.row, col.to.remove), 1:2, split = NULL, ignore.case = FALSE),
                         expected.tbl)
            expect_equal(RemoveAt(ftbl, list(default.string, col.to.remove), 1:2, split = "[;,]"),
                         expected.tbl)
        })
    }
    col.match <- colnames(ftbl) %in% all.str
    if (any(col.match)) {
        requested.col <- all.str[which(all.str %in% colnames(ftbl))]
        test_that(paste0("Only ", requested.col, " col removed in ", ftbl.name), {
            expected.tbl <- ftbl[, !col.match]
            expect_equal(RemoveAt(ftbl, requested.col, 2, split = NULL, ignore.case = FALSE), expected.tbl)
            expect_equal(RemoveAt(ftbl, tolower(requested.col), 2, split = NULL, ignore.case = TRUE), expected.tbl)
            expect_equal(RemoveAt(ftbl, default.string, MARGIN = 2, split = "[;,]"), expected.tbl)
            # Check col removed tools
            row.to.remove <- sample.int(nrow(ftbl), size = 1)
            expected.tbl <- ftbl[-row.to.remove, !col.match]
            expect_equal(RemoveAt(ftbl, list(row.to.remove, requested.col), 1:2, split = NULL, ignore.case = FALSE),
                         expected.tbl)
            expect_equal(RemoveAt(ftbl, list(row.to.remove, default.string), 1:2, split = "[;,]"),
                         expected.tbl)
        })
    }
    if (any(row.match) && any(col.match)) {
        requested.row <- all.str[all.str %in% rownames(ftbl)]
        requested.col <- all.str[all.str %in% colnames(ftbl)]
        int.row <- which(rownames(ftbl) %in% all.str)
        int.col <- which(colnames(ftbl) %in% all.str)
        test_that(paste0("Both rows and cols removed in ", ftbl.name), {
            expected.tbl <- ftbl[!row.match, !col.match]
            expect_equal(RemoveAt(ftbl, list(requested.row, requested.col), 1:2, split = "[;,]"),
                         expected.tbl)
            expect_equal(RemoveAt(ftbl, list(requested.row, int.col), 1:2, split = "[;,]"),
                         expected.tbl)
            expect_equal(RemoveAt(ftbl, list(int.row, requested.col), 1:2, split = "[;,]"),
                         expected.tbl)
        })
    }
}