tests/testthat/test-tar_rep2.R

In tarchetypes: Archetypes for Targets

targets::tar_test("tar_rep2() manifest", {
  targets::tar_script({
    list(
      targets::tar_target(label, "aggregate"),
      tarchetypes::tar_rep(
        data1,
        data.frame(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep(
        data2,
        list(value = rnorm(2)),
        batches = 2,
        reps = 3,
        iteration = "list"
      ),
      tarchetypes::tar_rep2(
        aggregate1,
        data.frame(x = label, value = data1$value + data2$value),
        data1,
        data2
      ),
      tarchetypes::tar_rep2(
        aggregate2,
        list(value = data1$value + data2$value),
        data1,
        data2,
        iteration = "list"
      ),
      tarchetypes::tar_rep2(
        aggregate3,
        data.frame(value = aggregate1$value + aggregate2$value),
        aggregate1,
        aggregate2
      )
    )
  })
  expect_empty_pattern <- function(out) {
    if ("pattern" %in% colnames(out)) {
      if (all(is.na(out$pattern))) {
        out$pattern <- NULL
      }
      expect_null(out$pattern)
    }
  }
  out <- targets::tar_manifest(callr_function = NULL)
  expect_equal(nrow(out), 8L)
  out <- targets::tar_manifest(label, callr_function = NULL)
  expect_equal(out$command, "\"aggregate\"")
  expect_empty_pattern(out)
  out <- targets::tar_manifest(data1_batch, callr_function = NULL)
  expect_equal(out$command, "seq_len(2)")
  expect_empty_pattern(out)
  out <- targets::tar_manifest(data2_batch, callr_function = NULL)
  expect_equal(out$command, "seq_len(2)")
  expect_empty_pattern(out)
  out <- targets::tar_manifest(data1, callr_function = NULL)
  expect_true(grepl("tar_rep_run", out$command))
  expect_false(is.na(out$pattern))
  expect_true(length(out$pattern) > 0L && nzchar(out$pattern) > 0L)
  out <- targets::tar_manifest(data2, callr_function = NULL)
  expect_true(grepl("tar_rep_run", out$command))
  expect_false(is.na(out$pattern))
  expect_true(length(out$pattern) > 0L && nzchar(out$pattern) > 0L)
  out <- targets::tar_manifest(aggregate1, callr_function = NULL)
  expect_true(grepl("tar_rep2_run", out$command))
  expect_false(is.na(out$pattern))
  expect_true(length(out$pattern) > 0L && nzchar(out$pattern) > 0L)
  out <- targets::tar_manifest(aggregate2, callr_function = NULL)
  expect_true(grepl("tar_rep2_run", out$command))
  expect_false(is.na(out$pattern))
  expect_true(length(out$pattern) > 0L && nzchar(out$pattern) > 0L)
  out <- targets::tar_manifest(aggregate3, callr_function = NULL)
  expect_true(grepl("tar_rep2_run", out$command))
  expect_false(is.na(out$pattern))
  expect_true(length(out$pattern) > 0L && nzchar(out$pattern) > 0L)
})

targets::tar_test("tar_rep2() graph", {
  targets::tar_script({
    list(
      targets::tar_target(label, "aggregate"),
      tarchetypes::tar_rep(
        data1,
        data.frame(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep(
        data2,
        list(value = rnorm(2)),
        batches = 2,
        reps = 3,
        iteration = "list"
      ),
      tarchetypes::tar_rep2(
        aggregate1,
        data.frame(x = label, value = data1$value + data2$value),
        data1,
        data2
      ),
      tarchetypes::tar_rep2(
        aggregate2,
        list(value = data1$value + data2$value),
        data1,
        data2,
        iteration = "list"
      ),
      tarchetypes::tar_rep2(
        aggregate3,
        data.frame(value = aggregate1$value + aggregate2$value),
        aggregate1,
        aggregate2
      )
    )
  })
  out <- targets::tar_network(callr_function = NULL)
  exp <- tibble::tribble(
    ~from, ~to,
    "data1", "aggregate1",
    "data2", "aggregate1",
    "label", "aggregate1",
    "data1", "aggregate2",
    "data2", "aggregate2",
    "aggregate1", "aggregate3",
    "aggregate2", "aggregate3",
    "data1_batch", "data1",
    "data2_batch", "data2"
  )
  skip_if_not_installed("dplyr")
  expect_equal(dplyr::arrange(out$edges, from), dplyr::arrange(exp, from))
})

targets::tar_test("tar_rep2() pipeline", {
  targets::tar_script({
    list(
      targets::tar_target(label, "aggregate"),
      tarchetypes::tar_rep(
        data1,
        data.frame(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep(
        data2,
        list(value = rnorm(2)),
        batches = 2,
        reps = 3,
        iteration = "list"
      ),
      tarchetypes::tar_rep2(
        aggregate1,
        data.frame(x = label, value = data1$value + data2$value),
        data1,
        data2,
        rep_workers = 1
      ),
      tarchetypes::tar_rep2(
        aggregate2,
        list(value = data1$value + data2$value),
        data1,
        data2,
        iteration = "list",
        rep_workers = 2
      ),
      tarchetypes::tar_rep2(
        aggregate3,
        data.frame(value = aggregate1$value + aggregate2$value),
        aggregate1,
        aggregate2
      )
    )
  })
  targets::tar_make(callr_function = NULL)
  expect_equal(targets::tar_outdated(callr_function = NULL), character(0))
  targets::tar_load(tidyselect::everything())
  for (batch in seq_len(2)) {
    for (rep in seq_len(3)) {
      out1 <- aggregate1$value[
        aggregate1$tar_batch == batch & aggregate1$tar_rep == rep
      ]
      exp <- data1$value[data1$tar_batch == batch & data1$tar_rep == rep] +
        data2[[batch]][[rep]]$value
      expect_equal(out1, exp)
      out2 <- aggregate2[[batch]][[rep]]$value
      expect_equal(out2, exp)
      out3 <- aggregate3$value[
        aggregate3$tar_batch == batch & aggregate3$tar_rep == rep
      ]
      expect_equal(out1 + out2, out3)
    }
  }
  out <- tar_read(aggregate1, branches = 2)
  expect_equal(out$tar_batch, rep(2L, 6L))
  expect_equal(out$tar_rep, rep(seq_len(3L), each = 2L))
  expect_true(is.numeric(out$tar_seed))
})

targets::tar_test("tar_rep2() runs the command once per rep", {
  targets::tar_script({
    list(
      tarchetypes::tar_rep(
        x,
        data.frame(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep2(
        y,
        data.frame(value = rnorm(1)),
        x
      )
    )
  })
  targets::tar_make(callr_function = NULL)
  out <- targets::tar_read(y)
  expect_equal(nrow(out), 6L)
  expect_false(as.logical(anyDuplicated(out$value)))
})

targets::tar_test("tar_rep2() errors without correct list aggregation", {
  targets::tar_script({
    list(
      targets::tar_target(label, "aggregate"),
      tarchetypes::tar_rep(
        data1,
        data.frame(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep(
        data2,
        list(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep2(
        aggregate1,
        data.frame(x = label, value = data1$value + data2$value),
        data1,
        data2
      )
    )
  })
  expect_error(
    targets::tar_make(callr_function = NULL),
    class = "tar_condition_run"
  )
  out <- targets::tar_meta(starts_with("aggregate1"), error)
  expect_false(all(is.na(out)))
  expect_true(any(grepl("batch", out)))
  expect_true(any(grepl("iteration", out)))
})

targets::tar_test("tar_rep2() errors if bad upstream data type", {
  targets::tar_script({
    list(
      targets::tar_target(label, "aggregate"),
      tarchetypes::tar_rep(
        data1,
        data.frame(value = rnorm(2)),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep(
        data2,
        rnorm(2),
        batches = 2,
        reps = 3
      ),
      tarchetypes::tar_rep2(
        aggregate1,
        data.frame(x = label, value = data1$value + data2$value),
        data1,
        data2
      )
    )
  })
  expect_error(
    targets::tar_make(callr_function = NULL),
    class = "tar_condition_run"
  )
})

targets::tar_test("tar_rep2() seeds are resilient to re-batching", {
  skip_on_cran()
  targets::tar_script({
    f <- function() {
      tibble::tibble(
        x = digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
    }
    g <- function(x) {
      x$x <- paste0(
        x$x,
        digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
      x
    }
    list(
      tarchetypes::tar_rep(x, f(), batches = 1, reps = 4),
      tarchetypes::tar_rep2(y, g(x), targets = "x")
    )
  })
  targets::tar_make(callr_function = NULL)
  out1 <- targets::tar_read(y)
  out1$tar_batch <- NULL
  out1$tar_rep <- NULL
  targets::tar_script({
    f <- function() {
      tibble::tibble(
        x = digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
    }
    g <- function(x) {
      x$x <- paste0(
        x$x,
        digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
      x
    }
    list(
      tarchetypes::tar_rep(x, f(), batches = 2, reps = 2),
      tarchetypes::tar_rep2(y, g(x), targets = "x")
    )
  })
  targets::tar_make(callr_function = NULL)
  out2 <- targets::tar_read(y)
  out2$tar_batch <- NULL
  out2$tar_rep <- NULL
  targets::tar_script({
    f <- function() {
      tibble::tibble(
        x = digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
    }
    g <- function(x) {
      x$x <- paste0(
        x$x,
        digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
      x
    }
    list(
      tarchetypes::tar_rep(x, f(), batches = 4, reps = 1),
      tarchetypes::tar_rep2(y, g(x), targets = "x")
    )
  })
  targets::tar_make(callr_function = NULL)
  out3 <- targets::tar_read(y)
  out3$tar_batch <- NULL
  out3$tar_rep <- NULL
  expect_equal(out1, out2)
  expect_equal(out1, out3)
})

targets::tar_test("tar_rep2() seeds change with the seed option", {
  skip_on_cran()
  skip_if(!("seed" %in% names(formals(targets::tar_option_set))))
  targets::tar_script({
    tar_option_set(seed = 1L)
    f <- function() {
      tibble::tibble(
        x = digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
    }
    g <- function(x) {
      x$x <- paste0(
        x$x,
        digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
      x
    }
    list(
      tarchetypes::tar_rep(x, f(), batches = 2, reps = 2),
      tarchetypes::tar_rep2(y, g(x), targets = "x")
    )
  })
  targets::tar_make(callr_function = NULL)
  out1 <- paste(unname(targets::tar_read(y)), collapse = " ")
  targets::tar_destroy()
  targets::tar_make(callr_function = NULL)
  out2 <- paste(unname(targets::tar_read(y)), collapse = " ")
  targets::tar_script({
    tar_option_set(seed = 2L)
    f <- function() {
      tibble::tibble(
        x = digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
    }
    g <- function(x) {
      x$x <- paste0(
        x$x,
        digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
      x
    }
    list(
      tarchetypes::tar_rep(x, f(), batches = 2, reps = 2),
      tarchetypes::tar_rep2(y, g(x), targets = "x")
    )
  })
  targets::tar_make(callr_function = NULL)
  out3 <- paste(unname(targets::tar_read(y)), collapse = " ")
  targets::tar_script({
    tar_option_set(seed = NA)
    f <- function() {
      tibble::tibble(
        x = digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
    }
    g <- function(x) {
      x$x <- paste0(
        x$x,
        digest::digest(
          paste(sample.int(n = 1e9, size = 1000), collapse = "_")
        )
      )
      x
    }
    list(
      tarchetypes::tar_rep(x, f(), batches = 2, reps = 2),
      tarchetypes::tar_rep2(y, g(x), targets = "x")
    )
  })
  targets::tar_make(callr_function = NULL)
  out4 <- paste(unname(targets::tar_read(y)), collapse = " ")
  targets::tar_make(callr_function = NULL)
  out5 <- paste(unname(targets::tar_read(y)), collapse = " ")
  expect_equal(out1, out2)
  expect_false(out1 == out3)
  expect_false(out1 == out4)
  expect_false(out1 == out5)
  expect_false(out1 == out3)
  expect_false(out3 == out4)
  expect_false(out3 == out5)
  expect_false(out4 == out5)
})