test_map.r
In valr: Genome Interval Arithmetic

test_that("x/y groupings are respected", {
  x <- tibble::tribble(
    ~chrom, ~start, ~end, ~id,
    "chr1", 100, 250, 1,
    "chr2", 250, 500, 2,
    "chr2", 250, 500, 3
  ) |>
    group_by(id)

  y <- tibble::tribble(
    ~chrom, ~start, ~end, ~value, ~id,
    "chr1", 100, 250, 10, 1,
    "chr1", 150, 250, 20, 2,
    "chr2", 250, 500, 500, 3
  ) |>
    group_by(id)

  pred <- tibble::tribble(
    ~chrom, ~start, ~end, ~id, ~vals,
    "chr1", 100, 250, 1, 10,
    "chr2", 250, 500, 3, 500,
    "chr2", 250, 500, 2, NA
  )
  res <- bed_map(x, y, vals = sum(value))
  expect_true(all(res == pred, na.rm = TRUE))
})

test_that("values_unique works correctly", {
  x <- tibble::tribble(
    ~chrom, ~start, ~end,
    "chr1", 100, 250
  )

  y <- tibble::tribble(
    ~chrom, ~start, ~end, ~value,
    "chr1", 100, 250, 10,
    "chr1", 150, 250, 20,
    "chr1", 100, 250, 10,
    "chr1", 150, 250, 20
  )

  res <- bed_map(x, y, vals = values_unique(value))
  expect_equal(res$vals, c("10,20"))
})

x <- tibble::tribble(
  ~chrom, ~start, ~end, ~id,
  "chr1", 100, 200, 1,
  "chr1", 250, 500, 2,
  "chr2", 250, 500, 3
)

y <- tibble::tribble(
  ~chrom, ~start, ~end, ~value,
  "chr1", 100, 150, 10,
  "chr1", 150, 250, 20,
  "chr1", 140, 250, 30,
  "chr1", 150, 200, 40
)

test_that("concat works correctly", {
  res <- bed_map(x, y, vals = concat(value))
  expected <- c("10,30,20,40", NA, NA)
  expect_equal(res$vals, expected)
})

test_that("values works correctly", {
  res <- bed_map(x, y, vals = values(value))
  expected <- c("10,30,20,40", NA, NA)
  expect_equal(res$vals, expected)
})

test_that("first works correctly", {
  res <- bed_map(x, y, first = first(value))
  expected <- c(10, NA, NA)
  expect_equal(res$first, expected)
})

test_that("last works correctly", {
  res <- bed_map(x, y, last = last(value))
  expected <- c(40, NA, NA)
  expect_equal(res$last, expected)
})

test_that("book-ended intervals are not reported", {
  x <- tibble::tribble(
    ~chrom, ~start, ~end,
    "chr1", 100, 200
  )

  y <- tibble::tribble(
    ~chrom, ~start, ~end, ~value,
    "chr1", 100, 150, 10,
    "chr1", 200, 250, 20
  )

  expected <- tibble::tribble(
    ~chrom, ~start, ~end, ~value,
    "chr1", 100, 200, 10
  )
  res <- bed_map(x, y, value = sum(value))
  expect_equal(res, expected, ignore_attr = TRUE)
})

test_that("ensure that mapping is calculated with respect to input tbls issue#108", {
  x <- tibble::tribble(
    ~chrom, ~start, ~end, ~group,
    "chr1", 100, 200, "B",
    "chr1", 200, 400, "A",
    "chr1", 500, 600, "C",
    "chr2", 125, 175, "C",
    "chr2", 150, 200, "A",
    "chr3", 100, 300, "A"
  )
  y <- tibble::tribble(
    ~chrom, ~start, ~end, ~group, ~value,
    "chr1", 100, 199, "A", 10,
    "chr1", 200, 400, "B", 20,
    "chr1", 500, 600, "A", 30,
    "chr2", 125, 175, "C", 40,
    "chr2", 350, 500, "A", 50,
    "chr3", 500, 600, "A", 100
  )

  pred <- tibble::tribble(
    ~chrom, ~start, ~end, ~group, ~total,
    "chr1", 100, 200, "B", NA,
    "chr1", 200, 400, "A", NA,
    "chr1", 500, 600, "C", NA,
    "chr2", 125, 175, "C", 40,
    "chr2", 150, 200, "A", NA,
    "chr3", 100, 300, "A", NA
  )

  x <- arrange(x, chrom, start)
  x <- group_by(x, group)
  y <- arrange(y, chrom, start)
  y <- group_by(y, group)

  res <- bed_map(x, y, total = sum(value))
  expect_true(all(pred == res, na.rm = T))
})

# from https://github.com/arq5x/bedtools2/blob/master/test/map/test-map.sh
x <- tibble::tribble(
  ~chrom, ~start, ~end,
  "chr1", 0L, 100L,
  "chr1", 100L, 200L,
  "chr2", 0L, 100L,
  "chr2", 100L, 200L,
  "chr3", 0L, 100L,
  "chr3", 100L, 200L
)
y <- tibble::tribble(
  ~chrom, ~start, ~end, ~group, ~value, ~strand,
  "chr1", 0L, 10L, "a1", 10L, "+",
  "chr1", 10L, 20L, "a2", 5L, "+",
  "chr1", 20L, 30L, "a3", 15L, "+",
  "chr1", 120L, 130L, "a4", 1L, "+",
  "chr3", 0L, 10L, "a5", 1L, "+",
  "chr3", 10L, 20L, "a6", 2L, "+",
  "chr3", 20L, 30L, "a7", 3L, "+",
  "chr3", 120L, 130L, "a8", 4L, "+"
)

## output NA instead of 0, see examples for code to change NA to 0
test_that("test count", {
  res <- bed_map(x, y, vals = n())
  expect_equal(res$vals, c(3, 1, NA, NA, 3, 1))
  res2 <- bed_map(x, y, vals = n()) |> mutate(vals = ifelse(is.na(vals), 0, vals))
  expect_equal(res2$vals, c(3, 1, 0, 0, 3, 1))
})

# R has no built-in mode function
test_that("test mode", {
  getmode <- function(v) {
    uniqv <- unique(v)
    uniqv[which.max(tabulate(match(v, uniqv)))]
  }
  res <- bed_map(x, y, vals = getmode(value))
  expect_equal(res$vals, c(10, 1, NA, NA, 1, 4))
})

test_that("Test GFF column extraction", {
  z <- tibble::tribble(
    ~chrom, ~seqid, ~type, ~start, ~end, ~score, ~strand, ~phase, ~attributes,
    "chr1", "hg19_ccdsGene", "start_codon", 1L, 9L, 0, "+", ".", "gene_id..CCDS30744.1...transcript_id..CCDS30744.1..",
    "chr1", "hg19_ccdsGene", "CDS", 2L, 11L, 0, "+", "0", "gene_id \"CCDS30744.1\"; transcript_id \"CCDS30744.1\";",
    "chr1", "hg19_ccdsGene", "exon", 8L, 20L, 0, "+", ".", "gene_id \"CCDS30744.1\"; transcript_id \"CCDS30744.1\";",
    "chr1", "hg19_ccdsGene", "CDS", 9L, 17L, 0, "+", "2", "gene_id \"CCDS30744.1\"; transcript_id \"CCDS30744.1\";",
    "chr1", "hg19_ccdsGene", "exon", 40L, 200L, 0, "+", ".", "gene_id \"CCDS30744.1\"; transcript_id \"CCDS30744.1\";"
  )

  res <- bed_map(x, z, vals = list(chrom))
  expect_equal(length(res$vals[[1]]), 5)
})

test_that("Tests for multiple columns and operations", {
  res <- bed_map(x, y, count = n(), sum = sum(value))
  expect_equal(res$sum, c(30, 1, NA, NA, 6, 4))
})