test-tar_map_rep.R
In tarchetypes: Archetypes for Targets

targets::tar_test("tar_map_rep(): combine, columns, static branches", {
  skip_if_not_installed("dplyr")
  targets::tar_script({
    f <- function(sigma1, sigma2) {
      tibble::tibble(
        out = sigma1 + 1000 * sigma2,
        length1 = length(sigma1),
        length2 = length(sigma2),
        random = sample.int(1e6, size = 1)
      )
    }
    hyperparameters <- tibble::tibble(
      scenario = c("tight", "medium", "diffuse"),
      sigma1 = c(10, 50, 50),
      sigma2 = c(10, 5, 10)
    )
    tarchetypes::tar_map_rep(
      x,
      command = f(sigma1, sigma2),
      values = hyperparameters,
      names = tidyselect::any_of("scenario"),
      batches = 2,
      reps = 3
    )
  })
  # manifest
  out <- targets::tar_manifest(callr_function = NULL)
  out <- out[order(out$name), ]
  expect_equal(
    sort(out$name),
    sort(
      paste0("x", c("_batch", "_tight", "_medium", "_diffuse", ""))
    )
  )
  expect_equal(out$command[out$name == "x_batch"], "seq_len(2)")
  expect_equal(
    grepl("diffuse|medium|tight", out$name),
    grepl("tar_rep_run", out$command)
  )
  expect_equal(
    grepl("diffuse|medium|tight", out$name),
    !is.na(out$pattern)
  )
  expect_equal(
    out$name == "x",
    grepl("bind_rows", out$command)
  )
  # network
  out <- targets::tar_network(callr_function = NULL)$edges
  out <- dplyr::arrange(out, from, to)
  exp <- tibble::tribble(
    ~from, ~to,
    "f", "x_diffuse",
    "f", "x_medium",
    "f", "x_tight",
    "x_batch", "x_diffuse",
    "x_batch", "x_medium",
    "x_batch", "x_tight",
    "x_diffuse", "x",
    "x_medium", "x",
    "x_tight", "x"
  )
  exp <- dplyr::arrange(exp, from, to)
  expect_equal(out, exp)
  # output
  targets::tar_make(callr_function = NULL)
  out <- dplyr::arrange(targets::tar_read(x), tar_batch, tar_rep, scenario)
  d <- dplyr::distinct(out, tar_group, tar_batch, tar_rep)
  expect_equal(nrow(out), nrow(d))
  expect_equal(out$out, rep(c(10050, 5050, 10010), times = 6))
  expect_equal(out$sigma1, rep(c(50, 50, 10), times = 6))
  expect_equal(out$sigma2, rep(c(10, 5, 10), times = 6))
  scenarios <- sort(unique(out$scenario))
  expect_equal(out$scenario, rep(scenarios, times = 6))
  expect_true(all(out$length1 == 1L))
  expect_true(all(out$length2 == 1L))
  expect_equal(length(unique(out$random)), nrow(out))
  # metadata
  meta <- targets::tar_meta(x_diffuse)
  expect_equal(length(unlist(meta$children)), 2L)
})

targets::tar_test("tar_map_rep(): no combine, 1 col, static branches", {
  skip_if_not_installed("dplyr")
  targets::tar_script({
    f <- function(sigma1, sigma2) {
      tibble::tibble(
        out = sigma1 + 1000 * sigma2
      )
    }
    hyperparameters <- tibble::tibble(
      scenario = c("tight", "medium", "diffuse"),
      sigma1 = c(10, 50, 50),
      sigma2 = c(10, 5, 10)
    )
    tarchetypes::tar_map_rep(
      x,
      command = f(sigma1, sigma2),
      values = hyperparameters,
      names = tidyselect::any_of("scenario"),
      columns = tidyselect::any_of(c("scenario", "sigma2")),
      combine = FALSE,
      batches = 2,
      reps = 3
    )
  })
  # manifest
  out <- targets::tar_manifest(callr_function = NULL)
  out <- out[order(out$name), ]
  expect_equal(
    sort(out$name),
    sort(
      paste0("x", c("_batch", "_tight", "_medium", "_diffuse"))
    )
  )
  expect_equal(out$command[out$name == "x_batch"], "seq_len(2)")
  expect_equal(
    grepl("diffuse|medium|tight", out$name),
    grepl("tar_rep_run", out$command)
  )
  expect_equal(
    grepl("diffuse|medium|tight", out$name),
    !is.na(out$pattern)
  )
  # network
  out <- targets::tar_network(callr_function = NULL)$edges
  out <- dplyr::arrange(out, from, to)
  exp <- tibble::tribble(
    ~from, ~to,
    "f", "x_diffuse",
    "f", "x_medium",
    "f", "x_tight",
    "x_batch", "x_diffuse",
    "x_batch", "x_medium",
    "x_batch", "x_tight"
  )
  exp <- dplyr::arrange(exp, from, to)
  expect_equal(out, exp)
  # output
  targets::tar_make(callr_function = NULL)
  out <- dplyr::bind_rows(
    targets::tar_read(x_diffuse),
    targets::tar_read(x_medium),
    targets::tar_read(x_tight)
  )
  out <- dplyr::arrange(out, tar_batch, tar_rep, scenario)
  d <- dplyr::distinct(out, tar_batch, tar_rep)
  expect_equal(nrow(out), nrow(d) * 3)
  expect_equal(out$out, rep(c(10050, 5050, 10010), times = 6))
  expect_false("sigma1" %in% colnames(out))
  expect_equal(out$sigma2, rep(c(10, 5, 10), times = 6))
  scenarios <- sort(unique(out$scenario))
  expect_equal(out$scenario, rep(scenarios, times = 6))
  # metadata
  meta <- targets::tar_meta(x_diffuse)
  expect_equal(length(unlist(meta$children)), 2L)
})

targets::tar_test("tar_map_rep(): combine, no cols, static branches", {
  skip_if_not_installed("dplyr")
  targets::tar_script({
    f <- function(sigma1, sigma2) {
      tibble::tibble(
        out = sigma1 + 1000 * sigma2
      )
    }
    hyperparameters <- tibble::tibble(
      scenario = c("tight", "medium", "diffuse"),
      sigma1 = c(10, 50, 50),
      sigma2 = c(10, 5, 10)
    )
    tarchetypes::tar_map_rep(
      x,
      command = f(sigma1, sigma2),
      values = hyperparameters,
      names = tidyselect::any_of("scenario"),
      columns = NULL,
      batches = 2,
      reps = 3
    )
  })
  # manifest
  out <- targets::tar_manifest(callr_function = NULL)
  out <- out[order(out$name), ]
  expect_equal(
    sort(out$name),
    sort(
      paste0("x", c("_batch", "_tight", "_medium", "_diffuse", ""))
    )
  )
  expect_equal(out$command[out$name == "x_batch"], "seq_len(2)")
  expect_equal(
    grepl("diffuse|medium|tight", out$name),
    grepl("tar_rep_run", out$command)
  )
  expect_equal(
    grepl("diffuse|medium|tight", out$name),
    !is.na(out$pattern)
  )
  expect_equal(
    out$name == "x",
    grepl("bind_rows", out$command)
  )
  # network
  out <- targets::tar_network(callr_function = NULL)$edges
  out <- dplyr::arrange(out, from, to)
  exp <- tibble::tribble(
    ~from, ~to,
    "f", "x_diffuse",
    "f", "x_medium",
    "f", "x_tight",
    "x_batch", "x_diffuse",
    "x_batch", "x_medium",
    "x_batch", "x_tight",
    "x_diffuse", "x",
    "x_medium", "x",
    "x_tight", "x"
  )
  exp <- dplyr::arrange(exp, from, to)
  expect_equal(out, exp)
  # output
  targets::tar_make(callr_function = NULL)
  out <- dplyr::arrange(targets::tar_read(x), tar_batch, tar_rep, tar_group)
  d <- dplyr::distinct(out, tar_group, tar_batch, tar_rep)
  expect_equal(nrow(out), nrow(d))
  expect_equal(out$out, rep(c(10050, 5050, 10010), times = 6))
  expect_equal(
    sort(colnames(out)),
    sort(c("tar_group", "out", "tar_batch", "tar_rep", "tar_seed"))
  )
  # metadata
  meta <- targets::tar_meta(x_diffuse)
  expect_equal(length(unlist(meta$children)), 2L)
})

targets::tar_test("tar_map_rep(): no static branches", {
  skip_if_not_installed("dplyr")
  targets::tar_script({
    f <- function(sigma1, sigma2) {
      tibble::tibble(
        out = sigma1 + 1000 * sigma2
      )
    }
    tarchetypes::tar_map_rep(
      x,
      command = f(1, 2),
      names = tidyselect::any_of("scenario"),
      batches = 2,
      reps = 3
    )
  })
  # manifest
  out <- targets::tar_manifest(callr_function = NULL)
  out <- out[order(out$name), ]
  expect_equal(
    sort(out$name),
    sort(
      paste0("x", c("_batch", ""))
    )
  )
  expect_equal(out$command[out$name == "x_batch"], "seq_len(2)")
  expect_equal(
    grepl("^x$", out$name),
    grepl("tar_rep_run", out$command)
  )
  expect_equal(
    grepl("^x$", out$name),
    !is.na(out$pattern)
  )
  # network
  out <- targets::tar_network(callr_function = NULL)$edges
  out <- dplyr::arrange(out, from, to)
  exp <- tibble::tribble(
    ~from, ~to,
    "f", "x",
    "x_batch", "x"
  )
  exp <- dplyr::arrange(exp, from, to)
  expect_equal(out, exp)
  # output
  targets::tar_make(callr_function = NULL)
  out <- dplyr::arrange(targets::tar_read(x), tar_batch, tar_rep)
  d <- dplyr::distinct(out, tar_batch, tar_rep)
  expect_equal(nrow(out), nrow(d))
  expect_equal(out$out, rep(2001, times = 6))
  expect_equal(
    sort(colnames(out)),
    sort(c("out", "tar_batch", "tar_rep", "tar_seed"))
  )
  # metadata
  meta <- targets::tar_meta(x)
  expect_equal(length(unlist(meta$children)), 2L)
})

targets::tar_test("tar_map_rep() column precedence", {
  skip_if_not_installed("dplyr")
  targets::tar_script({
    f <- function(theta) {
      tibble::tibble(
        theta = theta + 1L
      )
    }
    hyperparameters <- tibble::tibble(theta = 1L)
    tarchetypes::tar_map_rep(
      x,
      command = f(theta),
      values = hyperparameters,
      names = tidyselect::any_of("scenario"),
      batches = 2,
      reps = 3
    )
  })
  targets::tar_make(callr_function = NULL)
  expect_equal(unique(targets::tar_read(x)$theta), 2L)
})

targets::tar_test("tar_map_rep() list column support", {
  skip_if_not_installed("dplyr")
  targets::tar_script({
    f <- function(theta) {
      tibble::tibble(
        value = 1
      )
    }
    hyperparameters <- tibble::tibble(
      index = c(1L, 2L),
      theta = list(c(1L, 2L), c(3L, 4L))
    )
    tarchetypes::tar_map_rep(
      x,
      command = f(theta),
      values = hyperparameters,
      columns = tidyselect::everything(),
      batches = 1,
      reps = 2
    )
  })
  targets::tar_make(callr_function = NULL)
  x <- targets::tar_read(x)
  x <- dplyr::arrange(x, index, tar_rep)
  expect_equal(x$index, c(1L, 1L, 2L, 2L))
  expect_equal(
    tar_read(x)$theta,
    list(c(1L, 2L), c(1L, 2L), c(3L, 4L), c(3L, 4L))
  )
})

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

targets::tar_test("tar_map_rep() 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(x) {
      out <- digest::digest(
        paste(c(x, sample.int(n = 1e9, size = 1000)), collapse = "_")
      )
      data.frame(x = out)
    }
    tarchetypes::tar_map_rep(
      x,
      f(a),
      values = list(a = c(1, 2)),
      batches = 2,
      reps = 2
    )
  })
  targets::tar_make(callr_function = NULL)
  out1 <- paste(unname(targets::tar_read(x)), collapse = " ")
  targets::tar_destroy()
  targets::tar_make(callr_function = NULL)
  out2 <- paste(unname(targets::tar_read(x)), collapse = " ")
  targets::tar_script({
    tar_option_set(seed = 2L)
    f <- function(x) {
      out <- digest::digest(
        paste(c(x, sample.int(n = 1e9, size = 1000)), collapse = "_")
      )
      data.frame(x = out)
    }
    tarchetypes::tar_map_rep(
      x,
      f(a),
      values = list(a = c(1, 2)),
      batches = 2,
      reps = 2
    )
  })
  targets::tar_make(callr_function = NULL)
  out3 <- paste(unname(targets::tar_read(x)), collapse = " ")
  targets::tar_script({
    tar_option_set(seed = NA)
    f <- function(x) {
      out <- digest::digest(
        paste(c(x, sample.int(n = 1e9, size = 1000)), collapse = "_")
      )
      data.frame(x = out)
    }
    tarchetypes::tar_map_rep(
      x,
      f(a),
      values = list(a = c(1, 2)),
      batches = 2,
      reps = 2
    )
  })
  targets::tar_make(callr_function = NULL)
  out4 <- paste(unname(targets::tar_read(x)), collapse = " ")
  targets::tar_make(callr_function = NULL)
  out5 <- paste(unname(targets::tar_read(x)), 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)
})