test_slop.r
In valr: Genome Interval Arithmetic

genome <- tibble::tribble(
  ~chrom , ~size ,
  "chr1" ,  5000
)

x <- tibble::tribble(
  ~chrom , ~start , ~end , ~name , ~score , ~strand ,
  "chr1" ,    500 , 1000 , "."   , "."    , "+"     ,
  "chr1" ,   1000 , 1500 , "."   , "."    , "-"
)

test_that("left arg works", {
  dist <- 100
  out <- x |>
    bed_slop(genome, left = dist)
  expect_true(all(x$start - out$start == dist))
})

test_that("right arg works", {
  dist <- 100
  out <- x |>
    bed_slop(genome, right = dist)
  expect_true(all(out$end - x$end == dist))
})

test_that("both arg works", {
  dist <- 100
  out <- x |>
    bed_slop(genome, both = dist)
  expect_true(all(x$start - out$start == dist))
  expect_true(all(out$end - x$end == dist))
})

test_that("both with fraction works", {
  res <- bed_slop(x, genome, both = 0.5, fraction = TRUE)
  expect_equal(res$start, c(250, 750))
  expect_equal(res$end, c(1250, 1750))
})

test_that("left / right with fraction works", {
  res <- bed_slop(x, genome, left = 0.5, fraction = TRUE)
  expect_equal(res$start, c(250, 750))
  expect_equal(res$end, c(1000, 1500))
})

test_that("left, fraction, strand works", {
  res <- bed_slop(x, genome, left = 0.5, fraction = TRUE, strand = TRUE)
  expect_equal(res$start, c(250, 1000))
  expect_equal(res$end, c(1000, 1750))
})

test_that("right, fraction, strand works", {
  res <- bed_slop(x, genome, right = 0.5, fraction = TRUE, strand = TRUE)
  expect_equal(res$start, c(500, 750))
  expect_equal(res$end, c(1250, 1500))
})

test_that("strand with left works", {
  res <- bed_slop(x, genome, left = 100, strand = TRUE)
  expect_equal(res$start, c(400, 1000))
  expect_equal(res$end, c(1000, 1600))
})

# from https://github.com/arq5x/bedtools2/blob/master/test/slop/test-slop.sh
a <- tibble::tribble(
  ~chrom , ~start , ~end , ~name , ~score , ~strand ,
  "chr1" , 100L   , 200L , "a1"  , 1L     , "+"     ,
  "chr1" , 100L   , 200L , "a2"  , 2L     , "-"
)

tiny.genome <- tibble::tribble(
  ~chrom , ~size ,
  "chr1" ,  1000
)

h19 <- read.table(
  file = valr_example("hg19.chrom.sizes.gz"),
  sep = "\t",
  header = FALSE,
  stringsAsFactors = FALSE
)
colnames(h19) <- c("chrom", "size")
h19 <- tibble::as_tibble(h19)

test_that("test going beyond the start of the chrom", {
  res <- bed_slop(a, tiny.genome, both = 200, trim = TRUE)
  expect_equal(res$start, c(0, 0))
  expect_equal(res$end, c(400, 400))
})

test_that("test going beyond the end of the chrom", {
  res <- bed_slop(a, tiny.genome, left = 0, right = 1000, trim = TRUE)
  expect_equal(res$start, c(100, 100))
  expect_equal(res$end, c(1000, 1000))
})

test_that("test going beyond the start and end of the chrom", {
  res <- bed_slop(a, tiny.genome, both = 2000, trim = TRUE)
  expect_equal(res$start, c(0, 0))
  expect_equal(res$end, c(1000, 1000))
})

test_that("test going beyond the start and end of the chrom with strand", {
  res <- bed_slop(a, tiny.genome, both = 2000, strand = TRUE, trim = TRUE)
  expect_equal(res$start, c(0, 0))
  expect_equal(res$end, c(1000, 1000))
})

test_that("test slop factor being larger than a signed int", {
  res <- bed_slop(a, tiny.genome, both = 3000000000, strand = TRUE, trim = TRUE)
  expect_equal(res$start, c(0, 0))
  expect_equal(res$end, c(1000, 1000))
})

test_that("test that old floating-point issues are solved", {
  b <- tibble::tribble(
    ~chrom , ~start   , ~end     ,
    "chr1" , 16778071 , 16778771
  )
  res <- bed_slop(b, h19, left = 200, right = 200)
  expect_equal(res$start, 16777871)
  expect_equal(res$end, 16778971)
})

## order is different compared to bedtools
test_that("test that old floating-point issues are solved", {
  b <- tibble::tribble(
    ~chrom , ~start , ~end ,
    "chr1" ,    160 ,  170 ,
    "chr1" ,    100 ,  200
  )
  res <- bed_slop(b, h19, both = 0.1, fraction = TRUE)
  expect_equal(res$start, c(90, 159))
  expect_equal(res$end, c(210, 171))
})

test_that("test negative slop on l with strand", {
  b <- tibble::tribble(
    ~chrom , ~start , ~end ,
    "chr1" ,    300 ,  320
  )
  res <- bed_slop(b, tiny.genome, left = -60, right = 60)
  expect_equal(res$start, 360)
  expect_equal(res$end, 380)
})

test_that("test negative slop on l with strand", {
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,    300 ,  320 , "a1"  ,      5 , "-"
  )
  res <- bed_slop(b, tiny.genome, left = -60, right = 60, strand = TRUE)
  expect_equal(res$start, 240)
  expect_equal(res$end, 260)
})

test_that("test negative slop on r with strand", {
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,    300 ,  320 , "a1"  ,      5 , "-"
  )

  res <- bed_slop(b, tiny.genome, left = 60, right = -60, strand = TRUE)
  expect_equal(res$start, 360)
  expect_equal(res$end, 380)
})

test_that("test crossover during negative slop", {
  tiny.genome <- tibble::tribble(
    ~chrom , ~size ,
    "chr1" ,  1000
  )
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,    300 ,  320 , "a1"  ,      5 , "-"
  )
  res <- bed_slop(b, tiny.genome, left = -60, right = -60, strand = TRUE)
  expect_equal(res$start, 260)
  expect_equal(res$end, 360)
})

test_that("test crossover during negative slop resulting in 0 length intervals are tossed out", {
  tiny.genome <- tibble::tribble(
    ~chrom , ~size ,
    "chr1" ,  1000
  )
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,    300 ,  320 , "a1"  ,      5 , "-"
  )
  expect_warning(
    res <- bed_slop(b, tiny.genome, left = -10, right = -10, strand = TRUE)
  )
  expect_equal(nrow(res), 0)
})

test_that("going beyond the end of the chrom", {
  tiny.genome <- tibble::tribble(
    ~chrom , ~size ,
    "chr1" ,  1000
  )
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,    950 ,  970 , "a1"  ,      5 , "-"
  )
  res <- bed_slop(
    b,
    tiny.genome,
    left = 60,
    right = -60,
    strand = TRUE,
    trim = TRUE
  )
  expect_equal(res$start, 999)
  expect_equal(res$end, 1000)
})

test_that("test edge cases", {
  tiny.genome <- tibble::tribble(
    ~chrom , ~size ,
    "chr1" ,  1000
  )
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,     50 ,   60 , "a1"  ,      5 , "-"
  )
  res <- bed_slop(
    b,
    tiny.genome,
    left = -60,
    right = 60,
    strand = TRUE,
    trim = TRUE
  )
  expect_equal(res$start, 0)
  expect_equal(res$end, 1)
})

test_that("test edge cases", {
  tiny.genome <- tibble::tribble(
    ~chrom , ~size ,
    "chr1" ,  1000
  )
  b <- tibble::tribble(
    ~chrom , ~start , ~end , ~name , ~score , ~strand ,
    "chr1" ,     50 ,   60 , "a1"  ,      5 , "-"
  )
  res <- bed_slop(
    b,
    tiny.genome,
    left = -100,
    right = 100,
    strand = TRUE,
    trim = TRUE
  )
  expect_equal(res$start, 0)
  expect_equal(res$end, 1)
})