tests/testthat/test-square_bracket.R

In safeframe: Generic Data Tagging and Validation Tool

library(dplyr)

test_that("tests for [ operator", {
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  on.exit(lost_tags_action())

  # errors
  lost_tags_action("warning", quiet = TRUE)
  msg <- "The following tagged variables are lost:\n dist - distance"
  expect_warning(x[, 1], msg, fixed = TRUE)

  lost_tags_action("error", quiet = TRUE)
  msg <- "The following tagged variables are lost:\n dist - distance"
  expect_error(x[, 1], msg)

  lost_tags_action("warning", quiet = TRUE)
  msg <- "The following tagged variables are lost:\n speed - mph\n dist - distance"
  expect_warning(x[, NULL], msg)

  # functionalities
  expect_identical(x, x[])
  expect_identical(x, x[, ])
  expect_null(ncol(x[, 1, drop = TRUE]))
  expect_identical(x[, 1, drop = TRUE], cars[, 1])

  lost_tags_action("none", quiet = TRUE)
  expect_identical(x[, 1], make_safeframe(cars[, 1, drop = FALSE], mph = "speed"))

  # [ behaves exactly as in the simple data.frame case, including when subset
  # only cols. https://github.com/epiverse-trace/linelist/issues/51
  expect_identical(
    cars[1],
    x[1],
    ignore_attr = TRUE
  )
  expect_identical(
    dplyr::as_tibble(cars)[1],
    x[1],
    ignore_attr = TRUE
  )

  # Warning about drop is surfaced to the user in this situation *iff* not our
  # default
  expect_no_warning(
    x[1]
  )
  expect_warning(
    x[1, drop = FALSE],
    "'drop' argument will be ignored"
  )
  expect_warning(
    dplyr::as_tibble(x)[1, drop = FALSE],
    "`drop` argument ignored"
  )
})

test_that("tests for [<- operator", {
  on.exit(lost_tags_action())

  # errors
  lost_tags_action("warning", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  msg <- "The following tagged variables are lost:\n speed - mph"
  expect_warning(x[, 1] <- NULL, msg)

  lost_tags_action("error", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  msg <- "The following tagged variables are lost:\n speed - mph"
  expect_error(x[, 1] <- NULL, msg)

  # functionalities
  x[1:3, 1] <- 1L
  expect_identical(x$speed[1:3], rep(1, 3))

  lost_tags_action("none", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  x[, 1:2] <- NULL
  expect_identical(ncol(x), 0L)
})

test_that("tests for [[<- operator", {
  on.exit(lost_tags_action())

  # errors
  lost_tags_action("warning", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  msg <- "The following tagged variables are lost:\n speed - mph"
  expect_warning(x[[1]] <- NULL, msg)

  lost_tags_action("error", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  expect_error(x[[1]] <- NULL, msg)

  # functionalities
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  x[[1]] <- 1L
  y <- rep(1L, nrow(x))
  attr(y, "label") <- "mph"
  expect_identical(x$speed, y)

  lost_tags_action("none", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  x[[2]] <- NULL
  x[[1]] <- NULL
  expect_identical(ncol(x), 0L)
})

test_that("$<- operator detects tag loss", {
  on.exit(lost_tags_action())

  # errors
  lost_tags_action("warning", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  msg <- "The following tagged variables are lost:\n speed - mph"
  expect_warning(x$speed <- NULL, msg)

  lost_tags_action("error", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  msg <- "The following tagged variables are lost:\n speed - mph"
  expect_error(x$speed <- NULL, msg)

  lost_tags_action("none", quiet = TRUE)
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  x$speed <- NULL
  x$dist <- NULL
  expect_identical(ncol(x), 0L)
})

test_that("$<- allows innocuous tag modification", {
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  expect_no_condition(x$speed <- 1L)
  y <- rep(1L, nrow(x))
  attr(y, "label") <- "mph"
  expect_identical(x$speed, y)
})

test_that("no warnings when untagged columns are dropped - #55", {
  x <- make_safeframe(cars,
    mph = "speed"
  )

  expect_silent(x[, "speed"])
})

test_that("improve class retention - #56", {
  x <- make_safeframe(cars, mph = "speed", distance = "dist")
  class(x) <- c("linelist", class(x))
  y <- suppressWarnings(x[, 1])
  expect_identical(class(x), class(y))
  
  y <- x
  y[, 1] <- suppressWarnings(2 * y[, 1])
  expect_identical(class(x), class(y))
  
  y <- x
  y$speed <- 2*y$speed
  expect_identical(class(x), class(y))
})

test_that("removing tags in subset is informative - #76", {
  on.exit(lost_tags_action())

  # errors
  lost_tags_action("warning", quiet = TRUE)
  x <- make_safeframe(mtcars, consumption = "mpg", power = "hp")

  expect_snapshot_warning(x[, c("cyl", "disp")])
})