tests/testthat/test-FilterStates.R

In teal.slice: Filter Module for 'teal' Applications

# initialize ----
testthat::test_that("constructor accepts only a string as dataname", {
  testthat::expect_no_error(FilterStates$new(data = NULL, dataname = "string"))
  testthat::expect_error(FilterStates$new(data = NULL, dataname = quote(name)), "Assertion on 'dataname' failed")
  testthat::expect_error(FilterStates$new(data = NULL, dataname = call("call")), "Assertion on 'dataname' failed")
})

# filter states api -----
testthat::test_that("get_filter_state returns default count_type = 'none'", {
  filter_states <- FilterStates$new(data = NULL, dataname = "test")
  testthat::expect_identical(
    shiny::isolate(filter_states$get_filter_state()),
    teal_slices(count_type = "none")
  )
})

testthat::test_that("set_filter_state sets include_variables by excluding unsupported cols from inputed list", {
  test <- iris
  test$col <- as.complex(1:150)
  test$col2 <- as.list(1:150)
  filter_states <- FilterStates$new(data = test, dataname = "test")
  teal_slices <- teal_slices(
    include_varnames = list(test = c("Species", "Sepal.Length", "non-existent", "col", "col2"))
  )
  filter_states$set_filter_state(teal_slices)
  testthat::expect_identical(
    shiny::isolate(filter_states$get_filter_state()),
    teal_slices(
      include_varnames = list(test = c("Species", "Sepal.Length")),
      count_type = "none"
    )
  )
})

testthat::test_that("set_filter_state sets count_type", {
  filter_states <- FilterStates$new(data = NULL, dataname = "test")
  filter_states$set_filter_state(teal_slices(count_type = "none"))
  testthat::expect_identical(
    shiny::isolate(filter_states$get_filter_state()),
    teal_slices(count_type = "none")
  )
})

testthat::test_that("set_filter_state ignores teal_slice for non-existent variables with log warning", {
  filter_states <- FilterStates$new(data = data.frame(a = 1), dataname = "test")
  testthat::expect_warning(
    filter_states$set_filter_state(teal_slices(teal_slice(dataname = "test", varname = "non-existent"))),
    "non-existent excluded from test"
  )
})

testthat::test_that("set_filter_state and get_filter_state, sets and returns the same fully specified teal_slices", {
  filter_states <- FilterStates$new(data = data.frame(a = 1:10), dataname = "test")
  fs <- teal_slices(
    teal_slice(
      dataname = "test", varname = "a", choices = c(1, 5), selected = c(1, 4), keep_na = FALSE, keep_inf = FALSE,
      fixed = FALSE, any_attribute = "a", another_attribute = "b"
    ),
    count_type = "none"
  )
  filter_states$set_filter_state(fs)
  expect_identical_slices(filter_states$get_filter_state(), fs)
})

testthat::test_that(
  paste(
    "set_filter_state",
    "updates FilterState when dataname and varname are matched between teal_slice and existing filter"
  ),
  {
    filter_states <- FilterStates$new(data = data.frame(a = 1:10), dataname = "test")
    fs <- teal_slices(
      teal_slice(
        dataname = "test", varname = "a", choices = c(1, 5), selected = c(1, 4), keep_na = FALSE, keep_inf = FALSE,
        fixed = FALSE, anchored = FALSE, any_attribute = "a", another_attribute = "b"
      ),
      count_type = "none"
    )
    filter_states$set_filter_state(fs)
    fs[[1]]$selected <- c(1, 5)
    filter_states$set_filter_state(fs)
    expect_identical_slices(filter_states$get_filter_state(), fs)
  }
)

testthat::test_that(
  paste(
    "set_filter_state",
    "allows to create two filters on the same variable if combination of their",
    "fields (dataname, varname, varlabel, arg, id) differ"
  ),
  {
    filter_states <- FilterStates$new(data = data.frame(a = 1:10), dataname = "a")
    fs <- teal_slices(
      teal_slice(dataname = "a", varname = "a"),
      teal_slice(dataname = "a", varname = "a", experiment = "a"),
      teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a"),
      teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a", id = "a"),
      count_type = "none"
    )
    filter_states$set_filter_state(fs)
    testthat::expect_length(shiny::isolate(filter_states$get_filter_state()), 4)
  }
)


testthat::test_that("set_filter_state creates a new FilterStateExpr", {
  filter_states <- FilterStates$new(data = data.frame(a = 1:5, b = 6:10), dataname = "test")
  fs <- teal_slices(
    teal_slice(id = "test", dataname = "test", title = "expression", expr = "a > 1 & b < 10"),
    count_type = "none"
  )
  filter_states$set_filter_state(fs)
  expect_identical_slices(filter_states$get_filter_state(), fs)
})


testthat::test_that("set_filter_state doesn't set slices listed in exclude_varnames", {
  filter_states <- FilterStates$new(data = mtcars, dataname = "mtcars")
  tss <- teal_slices(
    teal_slice(dataname = "mtcars", varname = "cyl"),
    teal_slice(dataname = "mtcars", expr = "qsec > 17", id = "high quartermile time", title = "QH"),
    teal_slice(dataname = "mtcars", expr = "disp < 120", id = "low displacememt", title = "LD"),
    exclude_varnames = list("mtcars" = c("cyl", "disp"))
  )
  expect_warning(
    filter_states$set_filter_state(tss),
    "filters for columns.*excluded from.*"
  )

  expected <- tss[-1]
  attributes(expected) <- attributes(shiny::isolate(filter_states$get_filter_state()))
  expect_identical_slices(filter_states$get_filter_state(), expected)
})

testthat::test_that("set_filter_state set only slices listed in include_varnames and teal_slice_expr", {
  filter_states <- FilterStates$new(data = mtcars, dataname = "mtcars")
  tss <- teal_slices(
    teal_slice(dataname = "mtcars", varname = "cyl"),
    teal_slice(dataname = "mtcars", varname = "mpg"),
    teal_slice(dataname = "mtcars", expr = "qsec > 17", id = "high quartermile time", title = "QH"),
    teal_slice(dataname = "mtcars", expr = "disp < 120", id = "low displacememt", title = "LD"),
    include_varnames = list("mtcars" = c("cyl", "disp"))
  )
  expect_warning(
    filter_states$set_filter_state(tss),
    "filters for columns.*excluded from.*"
  )

  expected <- tss[-2]
  attributes(expected) <- attributes(shiny::isolate(filter_states$get_filter_state()))
  expect_identical_slices(filter_states$get_filter_state(), expected)
})


testthat::test_that("remove_filter_state of inexistent FilterState raiser warning", {
  filter_states <- FilterStates$new(data = data.frame(a = 1:5), dataname = "a")
  testthat::expect_warning(
    filter_states$remove_filter_state(teal_slices(teal_slice(dataname = "a", varname = "a"))),
    "not found in state list"
  )
})

testthat::test_that(
  paste(
    "remove_filter_state",
    "removes FilterState objects identified by 'dataname', 'experiment', 'varname', 'arg' and/or 'id'"
  ),
  {
    filter_states <- FilterStates$new(data = data.frame(a = 1:5), dataname = "a")
    fs <- teal_slices(
      teal_slice(dataname = "a", varname = "a"),
      teal_slice(dataname = "a", varname = "a", experiment = "a"),
      teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a"),
      teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a", id = "a"),
      count_type = "none"
    )
    filter_states$set_filter_state(fs)

    filter_states$remove_filter_state(teal_slices(teal_slice(dataname = "a", varname = "a")))
    testthat::expect_length(shiny::isolate(filter_states$get_filter_state()), 3)

    filter_states$remove_filter_state(teal_slices(
      teal_slice(dataname = "a", varname = "a", experiment = "a")
    ))
    testthat::expect_length(shiny::isolate(filter_states$get_filter_state()), 2)

    filter_states$remove_filter_state(teal_slices(
      teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a")
    ))
    testthat::expect_length(shiny::isolate(filter_states$get_filter_state()), 1)

    filter_states$remove_filter_state(teal_slices(
      teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a", id = "a")
    ))
    testthat::expect_length(shiny::isolate(filter_states$get_filter_state()), 0)
  }
)

testthat::test_that("clearing empty `FilterStates` does not raise errors", {
  filter_states <- FilterStates$new(data = NULL, dataname = "test")
  testthat::expect_no_error(filter_states$clear_filter_states())
})


testthat::test_that("clear_filter_state empties the state_list", {
  filter_states <- FilterStates$new(data = data.frame(a = 1:5), dataname = "a")
  fs <- teal_slices(
    teal_slice(dataname = "a", varname = "a"),
    teal_slice(dataname = "a", varname = "a", experiment = "a"),
    teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a"),
    teal_slice(dataname = "a", varname = "a", experiment = "a", arg = "a", id = "a"),
    count_type = "none"
  )
  filter_states$set_filter_state(fs)
  filter_states$clear_filter_states()
  testthat::expect_length(shiny::isolate(filter_states$get_filter_state()), 0)
})


# get_call ----
testthat::test_that("get_call returns NULL after initialization if no filter applied", {
  filter_states <- FilterStates$new(data = NULL, dataname = "test")
  testthat::expect_null(shiny::isolate(filter_states$get_call()))
})

testthat::test_that("get_call returns subset call with dataname and logical expressions by default", {
  fs <- FilterStates$new(data = data.frame(a = 1:10), dataname = "test", datalabel = "1")
  fs$set_filter_state(teal_slices(
    teal_slice(dataname = "test", varname = "a", experiment = "1", selected = c(1, 9))
  ))
  testthat::expect_identical(
    shiny::isolate(fs$get_call()),
    quote(test <- subset(test, a >= 1 & a <= 9))
  )
})

testthat::test_that("get_call returns custom fun call", {
  test <- R6::R6Class(
    "test",
    inherit = FilterStates,
    private = list(
      fun = quote(fun)
    )
  )
  fs <- test$new(data = data.frame(a = 1:10), dataname = "test", datalabel = "1")
  fs$set_filter_state(teal_slices(
    teal_slice(dataname = "test", varname = "a", experiment = "1", selected = c(1, 9))
  ))

  testthat::expect_identical(
    shiny::isolate(fs$get_call()),
    quote(test <- fun(test, a >= 1 & a <= 9))
  )
})

testthat::test_that("get_call returns subset call on custom dataname_prefixed", {
  test <- R6::R6Class(
    "test",
    inherit = FilterStates,
    public = list(
      initialize = function(data, dataname) {
        super$initialize(data = data, dataname = dataname)
        private$dataname_prefixed <- 'dataname[["slot"]]'
      }
    )
  )
  fs <- test$new(data = data.frame(a = 1:10), dataname = "test")
  fs$set_filter_state(teal_slices(
    teal_slice(dataname = "test", varname = "a", experiment = "1", selected = c(1, 9))
  ))

  testthat::expect_identical(
    shiny::isolate(fs$get_call()),
    quote(dataname[["slot"]] <- subset(dataname[["slot"]], a >= 1 & a <= 9))
  )
})

testthat::test_that("get_call returns subset with varnames prefixed depending on a extract_type", {
  test <- R6::R6Class(
    "test",
    inherit = FilterStates,
    private = list(
      extract_type = "list"
    )
  )
  fs <- test$new(data = data.frame(a = 1:10), dataname = "test")
  fs$set_filter_state(teal_slices(
    teal_slice(dataname = "test", varname = "a", experiment = "1", selected = c(1, 9))
  ))

  testthat::expect_identical(
    shiny::isolate(fs$get_call()),
    quote(test <- subset(test, test$a >= 1 & test$a <= 9))
  )
})

testthat::test_that("get_call returns subset with multiple filter expressions combined by '&' operator", {
  fs <- FilterStates$new(data = data.frame(a = 1:10, b = 1:10, c = 1:10), dataname = "test")
  fs$set_filter_state(teal_slices(
    teal_slice(dataname = "test", varname = "a", experiment = "1", selected = c(1, 9)),
    teal_slice(id = "a", dataname = "test", title = "a", expr = "b > 5 | a > 5")
  ))

  testthat::expect_equal(
    shiny::isolate(fs$get_call()),
    quote(test <- subset(test, a >= 1 & a <= 9 & (b > 5 | a > 5)))
  )
})


testthat::test_that("get_call skips conditions form FilterState which are identified by sid", {
  shiny::reactiveConsole(TRUE)
  on.exit(shiny::reactiveConsole(FALSE))
  test_class <- R6::R6Class(
    classname = "test_class",
    inherit = FilterStates,
    public = list(
      get_filter_states_sid = function() {
        names(private$state_list())
      }
    )
  )
  filter_states <- test_class$new(data = iris, dataname = "iris")
  filter_states$set_filter_state(
    teal_slices(
      teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4)),
      teal_slice(dataname = "iris", varname = "Petal.Length", selected = c(1.5, 6.9)),
      teal_slice(dataname = "iris", varname = "Species", selected = "setosa")
    )
  )
  sid_attrs <- unname(filter_states$get_filter_states_sid())
  testthat::expect_equal(
    filter_states$get_call(sid = sid_attrs[1]),
    quote(
      iris <- subset(iris, Petal.Length >= 1.5 & Petal.Length <= 6.9 & Species == "setosa")
    )
  )
  testthat::expect_equal(
    filter_states$get_call(sid = sid_attrs[2]),
    quote(
      iris <- subset(iris, Sepal.Length >= 5.1 & Sepal.Length <= 6.4 & Species == "setosa")
    )
  )
  testthat::expect_equal(
    filter_states$get_call(sid = sid_attrs[3]),
    quote(
      iris <- subset(
        iris,
        Sepal.Length >= 5.1 & Sepal.Length <= 6.4 & (Petal.Length >= 1.5 & Petal.Length <= 6.9)
      )
    )
  )
  testthat::expect_null(
    filter_states$get_call(sid = sid_attrs)
  )
})

# todo: test srv_active - we probably need shinytest2
# todo: format

# allow_add ----
testthat::test_that("ui_add returns a message inside a div when data has no columns or no rows", {
  filter_states <- FilterStates$new(data = data.frame(), dataname = "iris")
  testthat::expect_identical(
    filter_states$ui_add("id"),
    shiny::div("no sample variables available")
  )
})

testthat::test_that("Selecting a new variable initializes a new filter state with default states", {
  filter_states <- FilterStates$new(data = iris, dataname = "iris")
  shiny::testServer(
    filter_states$srv_add,
    expr = {
      session$setInputs(var_to_add = "Sepal.Length")
    }
  )
  expect_identical_slices(
    filter_states$get_filter_state(),
    teal_slices(
      teal_slice(
        dataname = "iris",
        varname = "Sepal.Length",
        choices = c(4.3, 7.9),
        selected = c(4.3, 7.9)
      ),
      count_type = "none"
    )
  )
})

testthat::test_that("Adding 'var_to_add' adds another filter state", {
  filter_states <- FilterStates$new(data = iris, dataname = "iris")

  fs <- teal_slices(
    teal_slice(dataname = "iris", varname = "Sepal.Length", selected = c(5.1, 6.4), keep_na = FALSE, keep_inf = FALSE)
  )
  filter_states$set_filter_state(state = fs)
  shiny::testServer(
    filter_states$srv_add,
    expr = {
      session$setInputs(var_to_add = "Petal.Length")
    }
  )
  shiny::testServer(
    filter_states$srv_add,
    expr = {
      session$setInputs(var_to_add = "Species")
    }
  )

  expect_identical_slices(
    shiny::isolate(filter_states$get_filter_state()),
    teal_slices(
      teal_slice(
        dataname = "iris", varname = "Sepal.Length", choices = c(4.3, 7.9), selected = c(5.1, 6.4),
        keep_na = FALSE, keep_inf = FALSE, fixed = FALSE, anchored = FALSE
      ),
      teal_slice(
        dataname = "iris", varname = "Petal.Length", choices = c(1.0, 6.9), selected = c(1.0, 6.9),
        keep_na = NULL, keep_inf = NULL, fixed = FALSE, anchored = FALSE
      ),
      teal_slice(
        dataname = "iris", varname = "Species", choices = c("setosa", "versicolor", "virginica"),
        multiple = TRUE, selected = c("setosa", "versicolor", "virginica"), keep_na = NULL, keep_inf = NULL,
        fixed = FALSE, anchored = FALSE
      ),
      count_type = "none"
    )
  )
})

testthat::test_that("srv_add determines labels for the choices based on the column attribute", {
  data <- iris[c("Sepal.Length", "Species")]
  colnames(data) <- tolower(colnames(data))
  attr(data[["sepal.length"]], "label") <- "Sepal length"
  attr(data[["species"]], "label") <- "Species"
  filter_states <- FilterStates$new(data = data, dataname = "test")

  shiny::testServer(
    filter_states$srv_add,
    expr = {
      testthat::expect_identical(
        avail_column_choices(),
        structure(
          c(`sepal.length: Sepal length` = "sepal.length", `species: Species` = "species"),
          raw_labels = c("Sepal length", "Species"),
          combined_labels = c("sepal.length: Sepal length", "species: Species"),
          class = c("choices_labeled", "character"),
          types = c(sepal.length = "numeric", species = "factor")
        )
      )
    }
  )
})

testthat::test_that("srv_add limits choices to the include_varnames", {
  data <- iris
  colnames(data) <- tolower(colnames(data))
  filter_states <- FilterStates$new(data = data, dataname = "test")
  filter_states$set_filter_state(state = teal_slices(
    include_varnames = list(test = c("sepal.length", "species"))
  ))

  shiny::testServer(
    filter_states$srv_add,
    expr = {
      testthat::expect_identical(
        avail_column_choices(),
        structure(
          c(`sepal.length: sepal.length` = "sepal.length", `species: species` = "species"),
          raw_labels = c("sepal.length", "species"),
          combined_labels = c("sepal.length: sepal.length", "species: species"),
          class = c("choices_labeled", "character"),
          types = c(sepal.length = "numeric", species = "factor")
        )
      )
    }
  )
})

testthat::test_that("srv_add flags keys as primary_key", {
  data <- iris
  colnames(data) <- tolower(colnames(data))
  testfs <- R6::R6Class(
    "testfs",
    inherit = FilterStates,
    public = list(
      initialize = function(data, dataname, keys) {
        super$initialize(data = data, dataname = dataname)
        private$keys <- keys
      }
    )
  )
  filter_states <- testfs$new(data = data, dataname = "test", keys = "species")
  filter_states$set_filter_state(state = teal_slices(
    include_varnames = list(test = c("sepal.length", "species"))
  ))

  shiny::testServer(
    filter_states$srv_add,
    expr = {
      testthat::expect_identical(
        avail_column_choices(),
        structure(
          c(`sepal.length: sepal.length` = "sepal.length", `species: species` = "species"),
          raw_labels = c("sepal.length", "species"),
          combined_labels = c("sepal.length: sepal.length", "species: species"),
          class = c("choices_labeled", "character"),
          types = c(sepal.length = "numeric", species = "primary_key")
        )
      )
    }
  )
})