tests/testthat/test-mild_df.R

In mildsvm: Multiple-Instance Learning with Support Vector Machines

x_main <- data.frame("bag_label" = factor(c(1, 1, 0)),
                     "bag_name" = c(rep("bag_1", 2), "bag_2"),
                     'instance_name' = c('bag_1_inst_1', 'bag_1_inst_2', 'bag_2_inst_1'),
                     "instance_label" = c(0, 1, 0))
x_main <- rbind(x_main, x_main) %>% dplyr::arrange(bag_name, instance_name)
x_main$X1 <- c(-0.4, -0.35, 0.4, 0.5, 2, 2.1)

test_that("`as_mild_df()` works for several data.frames.", {
  x <- x_main
  df <- as_mild_df(x)
  expect_s3_class(df, "mild_df")
  expect(is.vector(attr(df, "instance_label")), "`df` does not have attribute instance_label")
  expect_equal(df, x[, -4], ignore_attr = TRUE)

  colnames(x)[1] <- "bag_LABEL"
  expect_warning(df <- as_mild_df(x))
  expect_equal(df, x[, -4], ignore_attr = TRUE)

  x$instance_label <- NULL
  colnames(x)[1:4] <- c("a", "b", "c", "d")
  expect_message(df <- as_mild_df(x)) %>%
    expect_warning() %>%
    expect_warning() %>%
    expect_warning()
  expect_equal(df, x, ignore_attr = TRUE)

  x <- x_main[c(2, 3, 5, 4, 1)]
  df <- as_mild_df(x)
  expect_equal(colnames(df), c("bag_label", "bag_name", "instance_name", "X1"))
})


test_that("`mild_df()` works for typical input", {
  df <- mild_df(
    'bag_label' = factor(c(1, 1, 0)),
    'bag_name' = c(rep('bag_1', 2), 'bag_2'),
    'instance_name' = c('bag_1_inst_1', 'bag_1_inst_2', 'bag_2_inst_1'),
    'X1' = c(-0.4, 0.5, 2),
    'instance_label' = c(0, 1, 0)
  )

  expect_s3_class(df, "mild_df")
  expect(is.vector(attr(df, "instance_label")), "`df` does not have attribute instance_label")


  expect_warning(df <- mild_df())
  expect_s3_class(df, "mild_df")
  expect_null(attr(df, "instance_label"))
})

test_that("`as_mild_df()` retains tibble typing", {
  x <- tibble::as_tibble(x_main)

  expect_s3_class(as_mild_df(x), "mild_df")
  expect_s3_class(as_mild_df(x), "tbl")
  expect_s3_class(as_mild_df(x), "tbl_df")
})

test_that("`as_mi_df()` converts data.frame to tibble", {
  expect_s3_class(as_mild_df(x_main), "mild_df")
  expect_s3_class(as_mild_df(x_main), "tbl")
  expect_s3_class(as_mild_df(x_main), "tbl_df")
})

test_that("Printing methods work as expected", {
  x <- x_main

  df <- as_mild_df(x)
  expect_snapshot(print(df))

  x$instance_label <- NULL
  df <- as_mild_df(x) %>%
    suppressMessages()
  expect_snapshot(print(df))

  x <- tibble::as_tibble(x)
  df <- as_mild_df(x) %>%
    suppressMessages()
  expect_snapshot(print(df))
  expect_snapshot(print(df, n = 2))

  expect_s3_class(df, "mild_df")
})

test_that("Subsetting `mild_df` gives correct warnings and classes", {
  df <- as_mild_df(x_main)

  expect_s3_class(df[, c(1:3)], "mild_df")
  expect_s3_class(df[, c(1:4)], "mild_df")
  expect_false(inherits(df[, 1], "mild_df"))
  expect_s3_class(df[, 1], "tbl_df")

  expect_warning(df2 <- df[, c(2:3)], "Dropping 'mild_df'")
  expect_s3_class(df2, "data.frame")
  expect_false(inherits(df2, "mild_df"))

  expect_warning(df2 <- df[, c(1,4)], "Dropping 'mild_df'")
  expect_s3_class(df2, "data.frame")
  expect_false(inherits(df2, "mild_df"))


  df <- as_mild_df(tibble::as_tibble(x_main))

  expect_s3_class(df[, c(1:3)], "mild_df")
  expect_s3_class(df[, c(1:4)], "mild_df")
  expect_false(inherits(df[, 1], "mild_df"))
  expect_s3_class(df[, 1], "data.frame") # different for tibbles

  expect_warning(df2 <- df[, c(2:3)], "Dropping 'mild_df'")
  expect_s3_class(df2, "data.frame")
  expect_false(inherits(df2, "mild_df"))

  expect_warning(df2 <- df[, c(1,4)], "Dropping 'mild_df'")
  expect_s3_class(df2, "data.frame")
  expect_false(inherits(df2, "mild_df"))
})

test_that("Subsetting `mi_df` rows works as expected", {
  df <- as_mild_df(x_main)

  check_row_subset <- function(df, ind) {
    df2 <- df[ind, ]
    n <- length(ind)
    expect_equal(nrow(df2), n)
    expect_equal(ncol(df2), ncol(df))
    expect_equal(length(df_instance_label(df2)), n)
    expect_equal(length(rownames(df2)), n)
  }

  check_row_subset(df, 1:2) # fewer rows
  check_row_subset(df, 1:3) # same rows
  check_row_subset(df, 1:4) %>%
    suppressWarnings() # extra rows
  check_row_subset(df, c(1, 1, 2)) # different order

  # list subsetting
  expect_equal(nrow(df[1]), nrow(df))
  expect_equal(nrow(df[1:2]), nrow(df))
  expect_equal(nrow(df[1:3]), nrow(df))

  # dplyr::filter
  df2 <- dplyr::filter(df, bag_label == 1)
  # expect_equal(length(df_instance_label(df2)), nrow(df2)) # fails
})