tests/testthat/test_Task.R

In mlr3: Machine Learning in R - Next Generation

test_that("Feature columns can be reordered", {
  bh = load_dataset("BostonHousing", "mlbench")
  bh$medv = NULL

  task = tsk("boston_housing")
  task$col_roles$feature = setdiff(names(bh), "cmedv")

  expect_equal(task$feature_names, setdiff(names(bh), "cmedv"))
  expect_equal(names(task$data(rows = 1)), c("cmedv", setdiff(names(bh), "cmedv")))

  task$col_roles$feature = shuffle(task$col_roles$feature)
  expect_equal(names(task$data(rows = 1)), c("cmedv", task$col_roles$feature))
})

test_that("Task duplicates rows", {
  # getting same row ids twice
  task = tsk("iris")
  data = task$data(c(1L, 1L))
  expect_data_table(data, nrows = 2L, any.missing = FALSE)

  # task with duplicated ids in row_roles$use
  # this happens in ResamplingBootstrap!
  task = tsk("iris")
  task$row_roles$use = c(1:5, 1:5, 146:150)
  expect_task(task, duplicated_ids = TRUE)

  expect_equal(task$nrow, 15L)
  expect_data_table(task$data(), nrows = 15)
  task$droplevels()
  expect_character(task$class_names, len = 2L)

  task$set_row_roles(1, remove_from = "use")
  expect_equal(task$nrow, 13L)
  task$set_row_roles(1L, add_to = "use")
  expect_equal(task$nrow, 14L)
  task$set_row_roles(1L, add_to = "use")
  expect_equal(task$nrow, 15L)
})

test_that("Rows return ordered", {
  x = load_dataset("nhtemp", "datasets", TRUE)
  data = as.data.frame(x)
  data$x = as.numeric(data$x)
  data$t = as.integer(time(x))
  data = data[rev(seq_row(data)), ]
  rownames(data) = NULL
  b = as_data_backend(data)
  task = TaskRegr$new(id = "nhtemp", b, target = "x")

  x = task$data()
  expect_true(is.unsorted(x$t))

  task$col_roles$order = "t"
  x = task$data(ordered = TRUE)
  expect_integer(x$t, sorted = TRUE, any.missing = FALSE)

  x = task$data(ordered = FALSE)
  expect_true(is.unsorted(x$t))

  x = task$data(rows = sample(nrow(data), 50), ordered = TRUE)
  expect_integer(x$t, sorted = TRUE, any.missing = FALSE)
})

test_that("Rows return ordered with multiple order cols", {
  task = tsk("iris")

  x = task$data()
  expect_true(is.unsorted(x$Petal.Length))

  task$col_roles$order = c("Petal.Length", "Petal.Width")
  expect_equal(task$col_roles$order, c("Petal.Length", "Petal.Width"))

  x = task$data(ordered = TRUE)
  expect_numeric(x$Petal.Length, sorted = TRUE, any.missing = FALSE)

  expect_true(x[, is.unsorted(Petal.Width)])
  expect_true(all(x[, is.unsorted(Petal.Width), by = Petal.Width]$V1 == FALSE))
})


test_that("Task rbind", {
  task = tsk("iris")
  # expect_error(task$rbind(task), "data.frame")
  data = iris[1:10, ]
  task$rbind(iris[1:10, ])
  expect_task(task)
  expect_equal(task$nrow, 160)

  task$rbind(iris[integer(), ])
  expect_equal(task$nrow, 160)

  # #185
  task = tsk("iris")
  task$select("Petal.Length")
  task$rbind(task$data())
  expect_set_equal(task$row_ids, 1:300)

  task$rbind(data.table())
  expect_equal(task$nrow, 300L)

  # #437
  task = tsk("zoo")
  data = task$data()
  data$foo = 101:1
  nt = task$clone()$rbind(data)
  expect_task(nt)
  expect_set_equal(nt$row_ids, 1:202)
  expect_equal(nt$row_names$row_name, c(task$row_names$row_name, rep(NA, 101)))
  expect_equal(nt$col_info[list("foo"), .N, nomatch = NULL], 0L)

  # 496
  data = iris
  data$blocks = sample(letters[1:2], nrow(iris), replace = TRUE)
  task = TaskClassif$new("iris", data, target = "Species")
  task$col_roles$feature = setdiff(task$col_roles$feature, "blocks")
  task$col_roles$group = "blocks"
  learner = lrn("classif.rpart")
  learner$train(task)
  expect_prediction(predict(learner, iris, predict_type = "<Prediction>"))

  # merge factor levels
  task = tsk("penguins")
  data = task$data(1)
  data$sex = factor("unsure", levels = c("male", "female", "unsure"))
  task$rbind(data)
  expect_equal(task$levels("sex")[[1]], c("female", "male", "unsure"))
  expect_equal(task$col_info[list("sex"), fix_factor_levels], TRUE)
})

test_that("Task cbind", {
  task = tsk("iris")

  iris_col_hashes = task$col_hashes

  # expect_error(task$cbind(task), "data.frame")
  data = cbind(data.frame(foo = 150:1), data.frame(..row_id = task$row_ids))
  task$cbind(data)
  expect_task(task)
  expect_equal(task$ncol, 6L)
  expect_names(task$feature_names, must.include = "foo")

  expect_equal(iris_col_hashes, task$col_hashes[names(iris_col_hashes)])

  data = data.frame(bar = runif(150))
  task$cbind(data)
  expect_task(task)
  expect_equal(task$ncol, 7L)
  expect_names(task$feature_names, must.include = "bar")

  data = data.frame(..row_id = task$row_ids)
  task$cbind(data)
  expect_equal(task$ncol, 7L)

  task$cbind(iris[, character()])
  expect_equal(task$ncol, 7L)

  task$cbind(data.table())
  expect_equal(task$ncol, 7L)

  y = task$data(cols = task$target_names, rows = shuffle(task$row_ids))
  task$cbind(y)
  expect_equal(task$ncol, 7L)
  expect_disjunct(task$feature_names, task$target_names)

  # cbind to subsetted task
  task = tsk("iris")$filter(1:120)
  backend = data.table(x = runif(120))
  task$cbind(backend)

  expect_equal(iris_col_hashes, task$col_hashes[names(iris_col_hashes)])

  # cbind 0-row data (#461)
  task = tsk("iris")$filter(integer())
  task$cbind(data.frame(x = integer()))
  expect_set_equal(c(task$target_names, task$feature_names), c(names(iris), "x"))

})

test_that("cbind/rbind works", {
  task = tsk("iris")
  data = data.table(..row_id = 1:150, foo = 150:1)

  task$cbind(data)
  expect_task(task)
  expect_equal(task$n_features, 5L) # "foo" was added as a feature
  expect_set_equal(c(task$feature_names, task$target_names), c(names(iris), "foo"))
  expect_data_table(task$data(), ncols = 6, any.missing = FALSE)

  task$rbind(cbind(data.table(..row_id = 201:210, foo = 99L), iris[1:10, ]))
  expect_task(task)
  expect_set_equal(task$row_ids, c(1:150, 201:210))
  expect_equal(task$n_features, 5L) # adding rows doesn't change #features
  expect_data_table(task$data(), ncols = 6, nrows = 160, any.missing = FALSE)

  # auto generated ids
  task = tsk("zoo")
  newdata = task$data(1)
  newdata$animal = "boy"
  task$rbind(newdata)
  expect_set_equal(task$row_ids, 1:102)
})

test_that("filter works", {
  task = tsk("iris")
  task$filter(1:100)
  expect_equal(task$nrow, 100L)

  task$filter(91:150)
  expect_equal(task$nrow, 10L)

  expect_equal(task$row_ids, 91:100)

  task$filter(91)
  expect_equal(task$nrow, 1L)
  expect_data_table(task$data(), nrows = 1L, any.missing = FALSE)
})

test_that("select works", {
  task = tsk("iris")
  task$select(setdiff(task$feature_names, "Sepal.Length"))
  expect_equal(task$ncol, 4L)

  expect_error(task$select(c("Sepal.Width", "foobar")))

  task$select("Sepal.Width")
  expect_equal(task$feature_names, "Sepal.Width")

  expect_error(task$select(1:4), "character")
  expect_error(task$select("xxx", "subset"))
})

test_that("rename works", {
  task = tsk("iris")
  old = names(iris)
  new = paste0("xx_", old)
  task$rename(old, new)

  expect_set_equal(task$feature_names, setdiff(new, "xx_Species"))
  expect_equal(task$target_names, "xx_Species")
  expect_task_classif(task)
})

test_that("stratify works", {
  task = tsk("iris")
  expect_false("strata" %in% task$properties)
  expect_null(task$strata)

  task$col_roles$stratum = task$target_names
  expect_true("strata" %in% task$properties)
  tab = task$strata
  expect_data_table(tab, ncols = 2, nrows = 3)
  expect_list(tab$row_id, "integer")
})

test_that("groups/weights work", {
  b = as_data_backend(data.table(x = runif(20), y = runif(20), w = runif(20), g = sample(letters[1:2], 20, replace = TRUE)))
  task = TaskRegr$new("test", b, target = "y")
  task$set_row_roles(16:20, character())

  expect_false("groups" %in% task$properties)
  expect_false("weights" %in% task$properties)
  expect_null(task$groups)
  expect_null(task$weights)

  task$col_roles$weight = "w"
  expect_subset("weights", task$properties)
  expect_data_table(task$weights, ncols = 2, nrows = 15)
  expect_numeric(task$weights$weight, any.missing = FALSE)

  task$col_roles$weight = character()
  expect_true("weights" %nin% task$properties)

  task$col_roles$group = "g"
  expect_subset("groups", task$properties)
  expect_data_table(task$groups, ncols = 2, nrows = 15)
  expect_subset(task$groups$group, c("a", "b"))

  task$col_roles$group = character()
  expect_true("groups" %nin% task$properties)

  expect_error({
    task$col_roles$weight = c("w", "g")
  }, "up to one")
})

test_that("col roles are valid", {
  b = as_data_backend(data.table(
    y = runif(20),
    logical = sample(c(TRUE, FALSE), 20, replace = TRUE),
    numeric = runif(20),
    integer = sample(1:3, 20, replace = TRUE),
    factor = factor(sample(letters[1:3], 20, replace = TRUE))))
  task = TaskRegr$new("test", b, target = "y")

  # weight
  expect_error(task$set_col_roles("logical", roles = "weight"), "type")
  expect_error(task$set_col_roles("factor", roles = "weight"), "type")
  expect_error(task$set_col_roles(c("integer", "numeric"), roles = "weight"), "There may only be up to one column with role")

  # name
  expect_error(task$set_col_roles("logical", roles = "name"), "type")
  expect_error(task$set_col_roles("integer", roles = "name"), "type")
  expect_error(task$set_col_roles("numeric", roles = "name"), "type")
  expect_error(task$set_col_roles(c("integer", "numeric"), roles = "name"), "There may only be up to one column with role")

  # group
  expect_error(task$set_col_roles(c("numeric", "factor"), roles = "group"), "There may only be up to one column with role")

  # missing weights
  b = as_data_backend(data.table(y = runif(20), numeric = c(runif(19), NA_real_)))
  task = TaskRegr$new("test", b, target = "y")

  expect_error(task$set_col_roles("numeric", roles = "weight"), "missing")

  # negative weights
  b = as_data_backend(data.table(y = runif(20), numeric = c(runif(19), -10)))
  task = TaskRegr$new("test", b, target = "y")

  expect_error(task$set_col_roles("numeric", roles = "weight"), "is not")

  # target classif
  b = as_data_backend(data.table(
    y = factor(sample(letters[1:3], 20, replace = TRUE)),
    numeric = runif(20)))
  task = as_task_classif(b, target = "y")

  expect_error({task$col_roles = insert_named(task$col_roles, list(target = "numeric", feature = "y"))},
    "must be a factor or ordered factor")

  expect_error(task$set_col_roles("numeric", roles = "target"), "up to one column with")

  # target regr
  b = as_data_backend(data.table(
    y = runif(20),
    factor = factor(sample(letters[1:3], 20, replace = TRUE))))
  task = TaskRegr$new("test", b, target = "y")

  expect_error({task$col_roles = insert_named(task$col_roles, list(target = "factor", feature = "y"))},
    "numeric or integer column")

  expect_error(task$set_col_roles("factor", roles = "target"), "up to one column with")
})

test_that("ordered factors (#95)", {
  df = data.frame(
    x = c(1, 2, 3),
    y = factor(letters[1:3], levels = letters[1:3], ordered = TRUE),
    z = factor(c("M", "R", "R"), levels = c("M", "R"))
  )
  b = as_data_backend(df)
  task = TaskClassif$new(id = "id", backend = b, target = "z")
  expect_subset(c("numeric", "ordered", "factor"), task$col_info$type)
  expect_set_equal(task$col_info[id == "z", levels][[1L]], c("M", "R"))
  expect_set_equal(task$col_info[id == "y", levels][[1L]], letters[1:3])
})

test_that("as.data.table", {
  task = tsk("iris")
  expect_data_table(as.data.table(task), nrows = 150, ncols = 5)
})

test_that("extra factor levels are stored (#179)", {
  dt = data.table(
    x1 = factor(letters[1:5], levels = letters[5:1]),
    x2 = factor(letters[1:5], levels = letters),
    x3 = letters[1:5],
    target = 1:5)
  task = TaskRegr$new("extra_factor_levels", as_data_backend(dt), "target")
  expect_equal(task$levels("x2")$x2, letters)
})

test_that("task$droplevels works", {
  dt = data.table(
    x1 = factor(letters[1:3]),
    target = 1:3
  )
  task = TaskRegr$new("droplevels", as_data_backend(dt), "target")

  task$filter(1:2)
  expect_equal(task$nrow, 2L)
  expect_equal(task$levels("x1")$x1, letters[1:3])
  task$droplevels()
  expect_equal(task$levels("x1")$x1, letters[1:2])
})

test_that("task$missings() works", {
  task = tsk("pima")
  x = task$missings()
  y = map_int(task$data(), count_missing)
  expect_equal(x, y[match(names(x), names(y))])

  # issue #862
  task = tsk("iris")$cbind(data.frame(x = 1:150))$rename("x", "y")
  missings = task$missings(cols = character())
  expect_integer(missings, len = 0L)
  testthat::expect_named(missings)
})

test_that("task$feature_types preserves key (#193)", {
  task = tsk("iris")$select(character())$cbind(iris[1:4])
  expect_data_table(task$feature_types, ncols = 2L, nrows = 4L, key = "id")
})

test_that("switch columns on and off (#301)", {
  task = tsk("iris")
  expect_equal(task$n_features, 4L)
  task$col_roles$feature = setdiff(task$col_roles$feature, "Sepal.Length")
  expect_equal(task$n_features, 3L)
  task$cbind(data.table(x = 1:150))
  expect_equal(task$n_features, 4L)
  task$col_roles$feature = union(task$col_roles$feature, "Sepal.Length")
  expect_equal(task$n_features, 5L)
  expect_data_table(task$data(), ncols = 6, nrows = 150, any.missing = FALSE)
})

test_that("row roles setters", {
  task = tsk("iris")

  expect_error({
    task$row_roles$use = "foo"
  })
  expect_error({
    task$row_roles$foo = 1L
  })

  task$row_roles$use = 1:20
  expect_equal(task$nrow, 20L)
})

test_that("col roles getters/setters", {
  task = tsk("iris")

  expect_error({
    task$col_roles$feature = "foo"
  })

  expect_error({
    task$col_roles$foo = "Species"
  })

  task$col_roles$feature = setdiff(task$col_roles$feature, "Sepal.Length")
  expect_false("Sepal.Length" %in% task$feature_names)
})

test_that("Task$row_names", {
  task = tsk("mtcars")
  tab = task$row_names
  expect_data_table(tab, any.missing = FALSE, ncols = 2, nrows = task$nrow)
  expect_integer(tab$row_id, unique = TRUE)
  expect_character(tab$row_name)

  tab = task$filter(1:10)$row_names
  expect_data_table(tab, any.missing = FALSE, ncols = 2, nrows = task$nrow)
  expect_integer(tab$row_id, unique = TRUE)
  expect_character(tab$row_name)
})

test_that("Task$set_row_roles", {
  task = tsk("pima")

  task$set_row_roles(1:10, remove_from = "use")
  expect_true(all(1:10 %nin% task$row_ids))

  task$set_row_roles(1:10, add_to = "use")
  expect_true(all(1:10 %in% task$row_ids))
})


test_that("Task$set_col_roles", {
  task = tsk("pima")
  expect_equal(task$n_features, 8L)

  task$set_col_roles("mass", remove_from = "feature")
  expect_equal(task$n_features, 7L)
  expect_true("mass" %nin% task$feature_names)

  task$set_col_roles("mass", add_to = "feature")
  expect_equal(task$n_features, 8L)
  expect_true("mass" %in% task$feature_names)

  task$set_col_roles("age", roles = "weight")
  expect_equal(task$n_features, 7L)
  expect_true("age" %nin% task$feature_names)
  expect_data_table(task$weights)

  task$set_col_roles("age", add_to = "feature", remove_from = "weight")
  expect_equal(task$n_features, 8L)
  expect_true("age" %in% task$feature_names)
  expect_null(task$weights)
})

test_that("$add_strata", {
  task = tsk("mtcars")
  expect_equal(task$col_roles$stratum, character())

  task$add_strata("mpg", bins = 5)
  expect_set_equal(task$col_roles$stratum, "..stratum_mpg")
  expect_data_table(task$strata, nrows = 5)

  task$add_strata("am", bins = 3)
  expect_set_equal(task$col_roles$stratum, c("..stratum_mpg", "..stratum_am"))

  task = tsk("mtcars")
  task$add_strata(c("mpg", "am"), bins = c(2, 5))
  expect_set_equal(task$col_roles$stratum, c("..stratum_mpg", "..stratum_am"))
})

test_that("column labels", {
  task = tsk("iris")
  expect_character(task$col_info$label)
  expect_true(allMissing(task$col_info$label))
  expect_true(allMissing(task$labels))

  task$labels = c(Species = "sp")
  expect_equal(task$labels[["Species"]], "sp")
  expect_equal(count_missing(task$labels), 4L)

  fn = task$feature_names
  task$labels = set_names(toupper(fn), fn)
  expect_equal(unname(task$labels), c("sp", toupper(fn)))

  expect_error({ task$labels = c(foo = "as") }, "names")

  dt = data.table(id = c(task$target_names, task$feature_names))
  dt$label = tolower(dt$id)

  task$labels = dt
  expect_equal(
    unname(task$labels),
    tolower(c(task$target_names, task$feature_names))
  )
})

test_that("set_levels", {
  task = tsk("penguins")

  new_lvls = c("male", "female", "missing")
  task$set_levels(list(sex = new_lvls))

  tab = task$col_info[list("sex")]
  expect_equal(tab$levels[[1]], new_lvls)
  expect_equal(tab$fix_factor_levels[[1]], TRUE)
  expect_equal(levels(task$data(1)$sex), new_lvls)
  expect_equal(levels(head(task)$sex), new_lvls)


  new_lvls = c("female", "nothing")
  task$set_levels(list(sex = new_lvls))

  tab = task$col_info[list("sex")]
  expect_equal(tab$levels[[1]], new_lvls)
  expect_equal(tab$fix_factor_levels[[1]], TRUE)
  expect_equal(as.integer(task$data(1)$sex), NA_integer_)
  expect_equal(as.integer(head(task, 1)$sex), NA_integer_)
  expect_equal(levels(task$data(1)$sex), new_lvls)
  expect_equal(levels(head(task, 1)$sex), new_lvls)
})

test_that("special chars in feature names (#697)", {
  prev = options(mlr3.allow_utf8_names = FALSE)
  on.exit(options(prev))

  expect_error(
    TaskRegr$new("test", data.table(`%^` = 1:3, t = 3:1), target = "t"),
    "comply"
  )
  options(mlr3.allow_utf8_names = TRUE)

  expect_error(
    TaskRegr$new("test", data.table(`%asd` = 1:3, t = 3:1), target = "t")
    ,
    "special character"
  )
})

test_that("head/tail", {
  task = tsk("iris")
  expect_data_table(head(task, n = 3), nrows = 3)
  expect_data_table(head(task, n = -3), nrows = task$nrow - 3)

  expect_data_table(tail(task, n = 3), nrows = 3)
  expect_data_table(tail(task, n = -3), nrows = task$nrow - 3)

  expect_data_table(head(task, n = Inf), nrows = 150)
  expect_data_table(tail(task, n = Inf), nrows = 150)

  expect_data_table(head(task, n = -Inf), nrows = 0)
  expect_data_table(tail(task, n = -Inf), nrows = 0)
})

test_that("Roles get printed (#877)", {
  task = tsk("iris")
  task$col_roles$weight = "Petal.Width"
  expect_output(print(task), "Weights: Petal.Width")
})

test_that("validation task is cloned", {
  task = tsk("iris")
  task$internal_valid_task = c(1:10, 51:60, 101:110)
  task2 = task$clone(deep = TRUE)
  expect_different_address(task$internal_valid_task, task2$internal_valid_task)
})

test_that("task is cloned when assining internal validation task", {
  task = tsk("iris")
  task$internal_valid_task = task
  expect_false(identical(task, task$internal_valid_task))
})

test_that("validation task changes a task's hash", {
  task = tsk("iris")
  h1 = task$hash
  task$internal_valid_task = task$clone(deep = TRUE)$filter(1:10)
  h2 = task$hash
  expect_false(h1 == h2)
})

test_that("compatibility checks on internal_valid_task", {
  d1 = data.table(x = 1:10, y = 1:10)
  d2 = data.table(x = rnorm(10), y = 1:10)
  d3 = data.table(x1 = rnorm(10), y = 1:10)

  t1 = as_task_regr(d1, target = "y")
  t2 = as_task_regr(d2, target = "y")
  t3 = as_task_regr(d3, target = "y")
  expect_error({t1$internal_valid_task = t2 }, "differs from the type")
  expect_error({t1$internal_valid_task = t3 }, "not present")
})

test_that("can NULL validation task", {
  task = tsk("iris")
  task$internal_valid_task = 1
  task$internal_valid_task = NULL
  expect_equal(length(task$row_ids), 149)
})

test_that("internal_valid_task is printed", {
  task = tsk("iris")
  task$internal_valid_task = c(1:10, 51:60, 101:110)
  out = capture_output(print(task))
  expect_true(grepl(pattern = "* Validation Task: (30x5)", fixed = TRUE, x = out))
})

test_that("task hashes during resample", {
  orig = tsk("iris")
  task = orig$clone(deep = TRUE)
  resampling = rsmp("holdout")
  resampling$instantiate(task)
  task$internal_valid_task = resampling$test_set(1)
  task$hash
  learner = lrn("classif.debug", validate = "test")
  expect_equal(resampling_task_hashes(task, resampling, learner), task$hash)
})

test_that("integer vector can be passed to internal_valid_task", {
  task = tsk("iris")$filter(1:5)
  task$internal_valid_task = 5
  expect_permutation(task$row_ids, 1:4)
  expect_equal(task$internal_valid_task$row_ids, 5)
})

test_that("cbind supports non-standard primary key (#961)", {
  tbl = data.table(x = runif(10), y = runif(10), myid = 1:10)
  b = as_data_backend(tbl, primary_key = "myid")
  task = as_task_regr(b, target = "y")
  task$cbind(data.table(x1 = 10:1))
  expect_true("x1" %in% task$feature_names)
})