tests/testthat/test-scan-deps.R

In r-lib/depends: Package Dependency Resolution and Downloads

test_that("scan_deps", {
  local_reproducible_output(width = 500)
  withr::local_envvar(R_PKG_CACHE_DIR = tmp <- tempfile())
  on.exit(unlink(tmp), add = TRUE)

  project <- test_path("fixtures/scan/project-1")
  expect_snapshot(variant = .Platform$OS.type, {
    scan_deps(project, root = project)[]
  })
  expect_snapshot(variant = .Platform$OS.type, {
    scan_deps(project, root = project)
  })
})

test_that("scan_deps errors", {
  mkdirp(tmp <- tempfile())
  on.exit(unlink(tmp, recursive = TRUE), add = TRUE)
  withr::local_dir(tmp)
  writeLines(c("Package: foo", "Version: 1.0.0"), "DESCRIPTION")
  mkdirp(c("foo", "bar", "foobar"))
  expect_snapshot(error = TRUE, {
    # invalid types
    scan_deps(1:10)
    scan_deps(root = mtcars)
    # root does not exist
    scan_deps(root = "sdfssdfsdf")
    # path does not exist
    scan_deps("sdfssdfsdf")
    scan_deps(c("sdfssdfsdf-1", "sdfssdfsdf-2"))
    # path are not inside root
    scan_deps("foo", "bar")
    scan_deps(c("foo", "foobar"), "bar")
  })
})

test_that("get_deps_cache_path", {
  local_reproducible_output(width = 500)
  withr::local_envvar(R_PKG_CACHE_DIR = tmp <- tempfile())
  on.exit(unlink(tmp), add = TRUE)

  expect_snapshot(transform = transform_tempdir, {
    writeLines(get_deps_cache_path())
    writeLines(get_deps_cache_path("badcafe"))
  })
})

test_that("clear_deps_cache", {
  local_reproducible_output(width = 500)
  withr::local_envvar(R_PKG_CACHE_DIR = tmp <- tempfile())
  on.exit(unlink(tmp), add = TRUE)

  cval <- get_deps_cache_path("badcafe")
  mkdirp(dirname(cval))
  file.create(cval)

  expect_snapshot({
    dir(tmp, recursive = TRUE)
  })

  clear_deps_cache()
  expect_snapshot({
    dir(tmp, recursive = TRUE)
  })
})

test_that("re_r_dep", {
  expect_snapshot({
    re_r_dep()
  })
})

test_that("scan_path_deps", {
  local_reproducible_output(width = 500)
  withr::local_envvar(R_PKG_CACHE_DIR = tmp <- tempfile())
  on.exit(unlink(tmp), add = TRUE)

  rfile <- test_path("fixtures/scan/project-1/R/code.R")
  expect_snapshot(variant = .Platform$OS.type, {
    scan_path_deps(rfile)
  })

  # now from the cache
  fake(scan_path_deps, "re_r_dep", function(...) stop("no"))
  expect_snapshot(variant = .Platform$OS.type, {
    scan_path_deps(rfile)
  })
})

test_that("scan_deps_df", {
  expect_snapshot({
    scan_deps_df()
  })
})

test_that("scan_path_deps_do", {
  rfile <- test_path("fixtures/scan/project-1/R/code.R")
  nsfile <- test_path("fixtures/scan/NAMESPACE")
  expect_snapshot({
    scan_path_deps_do(readLines(rfile), basename(rfile))
    scan_path_deps_do(readLines(nsfile), basename(nsfile))
  })

  expect_snapshot(error = TRUE, {
    scan_path_deps_do("code", "foo.unknown")
  })
})

test_that("scan_path_deps_do_r", {
  local_reproducible_output(width = 500)
  rfile <- test_path("fixtures/scan/project-1/R/code.R")
  expect_snapshot({
    scan_path_deps_do_r(readLines(rfile), rfile)
  })
})

# test_that("scan_path_deps_do_pkg_hits", { })

test_that("scan_path_deps_do_fn_hits", {
  local_reproducible_output(width = 500)
  rfile <- test_path("fixtures/scan/methods.R")
  expect_snapshot({
    scan_path_deps_do_r(readLines(rfile), rfile)
  })
})

# test_that("scan_path_deps_do_gen_hits", { })

test_that("scan_path_deps_do_jr_hits", {
  local_reproducible_output(width = 500)
  rfile <- test_path("fixtures/scan/junit.R")
  expect_snapshot({
    scan_path_deps_do_r(readLines(rfile), rfile)
  })
})

test_that("scan_pat_deps_do_ragg_hits", {
  local_reproducible_output(width = 500)
  rfile <- test_path("fixtures/scan/knitr.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(rfile), rfile)
  })
  rfile <- test_path("fixtures/scan/noragg.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(rfile), rfile)
  })
})

# test_that("scan_pat_deps_do_db_hits", { })

test_that("safe_parse_pkg_from_call", {
  # error
  expect_null(
    safe_parse_pkg_from_call(NA_character_, "library", "library(error")
  )
  expect_snapshot(
    safe_parse_pkg_from_call(NA_character_, "library", "library(qwe)")
  )
})

# test_that("parse_pkg_from_call_match", { })

test_that("parse_pkg_from_call", {
  expect_snapshot({
    parse_pkg_from_call(NA_character_, "library", "library(qwe)")
    parse_pkg_from_call("base", "loadNamespace", "loadNamespace('q1')")
    parse_pkg_from_call(
      "base", "requireNamespace", "requireNamespace('q1')")
    parse_pkg_from_call(
      NA_character_, "pkg_attach", "pkg_attach('foobar')")
    parse_pkg_from_call(
      NA_character_, "pkg_attach2", "pkg_attach2('foobar')")
    parse_pkg_from_call("pacman", "p_load", "p_load('p1')")
    parse_pkg_from_call(NA_character_, "import", "import(x1)")
    parse_pkg_from_call(NA_character_, "module", "module({import('x2')})")
    parse_pkg_from_call("import", "from", "import::from(dplyr)")
    parse_pkg_from_call(
      "import", "into", "import::into('operators', .from = 'dplyr')")
    parse_pkg_from_call("import", "here", "import::here('dplyr')")
    parse_pkg_from_call("box", "use", "box::use(dplyr[filter, select])")
    parse_pkg_from_call(
      "targets",
      "tar_option_set",
      "tar_option_set(packages = c('p1', 'p2'))"
    )
    parse_pkg_from_call(
      "glue",
      "glue",
      "glue::glue('blah {library(x5)} blah')"
    )
    parse_pkg_from_call(
      NA_character_, "ggsave", "ggsave(filename = 'foo.svg')")
    parse_pkg_from_call(
      NA_character_, "set_engine", "set_engine(engine = 'spark')")
    parse_pkg_from_call(
      "R6", "R6Class", "R6::R6Class('foobar', inherit = JunitReporter)")
    parse_pkg_from_call(
      "testthat", "test_dir", "testthat::test_dir(reporter = 'junit')")
  })
})

test_that("parse_pkg_from_call_library", {
  ppcl <- function(fn, code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match(fn, code)
    parse_pkg_from_call_library(ns, fn, matched)
  }
  expect_null(
    ppcl("library", "library(qqq)", ns = "other"))
  expect_null(
    ppcl("library", "library(qqq, character.only = TRUE)"))
  expect_null(
    ppcl("require", "require(qqq)", ns = "other"))
  expect_null(
    ppcl("require", "require(qqq, character.only = TRUE)"))
  expect_snapshot({
    ppcl("library", "library(qqq)")
    ppcl("library", "library('qqq')")
    ppcl("library", "library(qqq)", ns = "base")
    ppcl("require", "require(qqq)")
    ppcl("require", "require('qqq')")
    ppcl("require", "require('qqq')", ns = "base")
  })
})

test_that("parse_pkg_from_call_loadnamespace", {
  ppcln <- function(fn, code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match(fn, code)
    parse_pkg_from_call_loadnamespace(ns, fn, matched)
  }
  expect_null(
    ppcln("loadNamespace", "loadNamespace('www')", ns = "other"))
  expect_null(
    ppcln("loadNamespace", "loadNamespace(www)"))
  expect_null(
    ppcln("loadNamespace", "loadNamespace(c('one', 'two'))"))
  expect_null(
    ppcln("loadNamespace", "loadNamespace(123)"))
  expect_equal(
    ppcln("loadNamespace", "loadNamespace('eee')"),
    "eee")
  expect_equal(
    ppcln("loadNamespace", "loadNamespace('eee')", ns = "base"),
    "eee")

  expect_null(
    ppcln("requireNamespace", "requireNamespace('www')", ns = "other"))
  expect_null(
    ppcln("requireNamespace", "requireNamespace(www)"))
  expect_null(
    ppcln("requireNamespace", "requireNamespace(c('one', 'two'))"))
  expect_null(
    ppcln("requireNamespace", "requireNamespace(123)"))
  expect_equal(
    ppcln("requireNamespace", "requireNamespace('eee')"),
    "eee")
  expect_equal(
    ppcln("requireNamespace", "requireNamespace('eee')", ns = "base"),
    "eee")
  })

test_that("parse_pkg_from_call_xfun", {
  ppcx <- function(fn, code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match(fn, code)
    parse_pkg_from_call_xfun(ns, fn, matched)
  }
  expect_null(
    ppcx("pkg_attach", "pkg_attach('qwe')", ns = "nope"))
  expect_null(
    ppcx("pkg_attach", "pkg_attach()"))
  expect_equal(
    ppcx("pkg_attach", "pkg_attach('p1', 'p2', 'p3')"),
    c("p1", "p2", "p3"))
  expect_equal(
    ppcx("pkg_attach2", "pkg_attach2('p1', 'p2', 'p3')"),
    c("p1", "p2", "p3"))
})

test_that("parse_pkg_from_call_pacman", {
  ppcp <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("p_load", code)
    parse_pkg_from_call_pacman(ns, fn, matched)
  }
  expect_null(ppcp("p_load()", ns = "foo"))
  expect_null(ppcp("p_load(xx, character.only = TRUE)"))
  expect_equal(ppcp("p_load(p1, 'p2', p3)"), c("p1", "p2", "p3"))
  expect_equal(ppcp("p_load(char = 'pp')"), 'pp')
  expect_equal(ppcp("p_load(char = c('p1', 'p2'))"), c("p1", "p2"))
})

test_that("parse_pkg_from_call_modules_import", {
  ppcmi <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("import", code)
    parse_pkg_from_call_modules_import(ns, fn, matched)
  }
  expect_null(ppcmi("import('pp')", ns = "foo"))
  expect_null(ppcmi("import(NULL)"))
  expect_equal(ppcmi("import('pp')"), 'pp')
  expect_equal(ppcmi("import(pp)"), 'pp')
})

test_that("parse_pkg_from_call_modules_module", {
  ppcmm <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("module", code)
    parse_pkg_from_call_modules_module(ns, fn, matched)
  }
  expect_null(ppcmm("module(x)", ns = "foo"))
  expect_null(ppcmm('module({})'))
  expect_equal(
    ppcmm("module({
      # other expressions, mixed with import()
      pkg::fun()
      blah + blah
      import(p1)
      baaaaah
      import('p2')
    })"),
    c('p1', 'p2')
  )
})

test_that("parse_pkg_from_call_import", {
  ppci <- function(fn, code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match(fn, code)
    parse_pkg_from_call_import(ns, fn, matched)
  }
  expect_null(ppci("from", "import::from(foo)", ns = "xx"))
  expect_equal(ppci("from", "import::from(foo)"), "foo")
  expect_equal(ppci("from", "import::from('foo')"), "foo")
  expect_equal(ppci("here", "import::here(foo)"), "foo")
  expect_equal(ppci("here", "import::here('foo')"), "foo")
  expect_equal(ppci("into", "import::into(.from = foo)"), "foo")
  expect_equal(ppci("into", "import::into(.from = 'foo')"), "foo")
  expect_null(ppci("from", "import::from(xx, .character_only = TRUE)"))
  expect_null(ppci("from", "import::from('./path.R')"))
})

test_that("parse_pkg_from_call_box", {
  ppcb <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("use", code)
    parse_pkg_from_call_box(ns, fn, matched)
  }
  expect_null(ppcb("box::use(pkg)", ns = 'not'))
  expect_null(ppcb("box::use(foo/bar)"))
  expect_null(ppcb("box::use(.[ff])"))
  expect_null(ppcb("box::use(..[ff])"))
  expect_equal(ppcb("box::use(pkg)"), "pkg")
  expect_equal(ppcb("box::use(pkg[f1, f2])"), c("pkg"))
  expect_equal(ppcb("box::use(pkg0, pkg[f1, f2])"), c("pkg0", "pkg"))
})

test_that("parse_pkg_from_call_targets", {
  ppct <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("tar_option_set", code)
    parse_pkg_from_call_targets(ns, fn, matched)
  }
  expect_null(ppct("tar_option_set(packages = 'pp')", ns = 'not'))
  expect_null(ppct("tar_option_set()"))
  expect_equal(
    ppct("tar_option_set(packages = { 1:10; c('p1', 'p2') })"),
    c("p1", "p2")
  )
})

test_that("dependencies_eval", {
  expect_snapshot({
    dependencies_eval(quote({ 1:10; c(10:1)[1:3] }))
  })
})

test_that("parse_pkg_from_call_glue", {
  ppcg <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("glue", code)
    parse_pkg_from_call_glue(ns, fn, matched)
  }
  expect_null(ppcg("glue('{library(xx)}')", ns = "nope"))
  expect_null(ppcg("glue('no code at all')"))
  expect_equal(
    ppcg("glue('some {library(p1)} code {p2::f()}')"),
    c("p1", "p2")
  )
})

test_that("parse_pkg_from_call_ggplot2", {
  ppcgg <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("ggsave", code)
    parse_pkg_from_call_ggplot2(ns, fn, matched)
  }
  expect_null(ppcgg("ggsave(filename = 'foo.svg')", ns = 'not'))
  expect_null(ppcgg("ggsave(filename = 'foo.png')"))
  expect_null(ppcgg("ggsave(filename = var)"))
  expect_equal(ppcgg("ggsave(filename = 'foo.svg')"), "svglite")
})

test_that("parse_pkg_from_call_parsnip", {
  ppcp <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("set_engine", code)
    parse_pkg_from_call_parsnip(ns, fn, matched)
  }
  expect_null(ppcp("set_engine(engine = 'keras')", ns = "nope"))
  expect_null(ppcp("set_engine()"))
  withr::local_options(renv.parsnip.engines = NULL)
  expect_equal(ppcp("set_engine(engine = 'glm')"), "stats")
  withr::local_options(renv.parsnip.engines = list(foo = "bar"))
  expect_equal(ppcp("set_engine(engine = 'foo')"), "bar")
  withr::local_options(renv.parsnip.engines = function(x) "eng")
  expect_equal(ppcp("set_engine(engine = 'foo')"), "eng")
  withr::local_options(renv.parsnip.engines = function(x) NULL)
  expect_null(ppcp("set_engine(engine = 'foo')"))
})

test_that("parse_pkg_from_call_testthat_r6class", {
  ppcttr6 <- function(code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match("R6Class", code)
    parse_pkg_from_call_testthat_r6class(ns, fn, matched)
  }
  expect_null(ppcttr6("R6Class(inherit = JunitReporter)", ns = 'not'))
  expect_null(ppcttr6("R6Class(inherit = someother)"))
  expect_equal(ppcttr6("R6Class(inherit = JunitReporter)"), "xml2")
  expect_equal(
    ppcttr6("R6Class(inherit = testthat::JunitReporter)"), "xml2")
})

test_that("parse_pkg_from_call_testthat_test", {
  ppcttt <- function(fn, code, ns = NA_character_) {
    matched <- parse_pkg_from_call_match(fn, code)
    parse_pkg_from_call_testthat_test(ns, fn, matched)
  }
  expect_null(
    ppcttt("test_dir", "test_dir(reporter = 'junit')", ns = "other"))
  expect_null(
    ppcttt("test_dir", "test_dir(reporter = 'other')"))
  expect_equal(
    ppcttt("test_dir", "test_dir(reporter = 'junit')"),
    "xml2")
})

test_that("scan_path_deps_do_rmd", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/chunk-errors.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), "chunk-errors.Rmd")
  })
})

test_that("scan_path_deps_do_rmd #2", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/inline-chunks.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), "inline-chunks.Rmd")
  })
})

test_that("scan_path_deps_do_rmd #3", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/nothing.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), "nothing.Rmd")
  })
})

# test_that("scan_path_deps_do_inline_hits", { })
# test_that("scan_path_deps_do_block_hits", { })

test_that("scan_path_deps_do_header_hits", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/header.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), basename(path))
  })
})

test_that("scan_path_deps_do_header_shiny_hits", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/header-shiny.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), basename(path))
  })
  path <- test_path("fixtures/scan/header-shiny2.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), basename(path))
  })
})

test_that("scan_path_deps_do_header_bslib_hits", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/header-bslib.Rmd")
  expect_snapshot({
    scan_path_deps_do_rmd(readLines(path), basename(path))
  })
})

test_that("scan_path_deps_do_dsc", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/DESCRIPTION")
  expect_snapshot({
    print(scan_path_deps_do_dsc(readLines(path), basename(path)), n = Inf)
  })
})

test_that("scan_path_deps_do_namespace", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/NAMESPACE")
  expect_snapshot({
    print(scan_path_deps_do_namespace(
      readBin(path, "raw", 10000),
      path
    ), n = Inf)
  })
})

test_that("scan_path_deps_do_{bookdown,pkgdown,quarto,renv_lock,rsconnect}", {
  local_reproducible_output(width = 500)
  withr::local_dir(test_path("fixtures/scan/project-2"))
  expect_snapshot({
    scan_deps()[]
  })
})

test_that(".Rproj file", {
  local_reproducible_output(width = 500)
  project <- test_path("fixtures/scan/project-3")
  expect_snapshot({
    scan_deps(project, root = project)[]
  })
})

test_that("scan_path_deps_do_rnw_ranges", {
  path <- test_path("fixtures/scan/test.Rnw")
  code <- readLines(path)
  expect_snapshot({
    scan_path_deps_do_rnw_ranges(code)
  })
})

test_that("scan_path_deps_do_rnw_parse_chunk_header", {
  expect_snapshot({
    scan_path_deps_do_rnw_parse_chunk_header("")
    scan_path_deps_do_rnw_parse_chunk_header("name")
    scan_path_deps_do_rnw_parse_chunk_header(
      "name, foo = 1, bar = TRUE, this = that"
    )
  })
})

test_that(".Rnw file", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/test.Rnw")
  expect_snapshot({
    scan_path_deps_do_rnw(
      readLines(path),
      basename(path)
    )
    scan_path_deps_do(
      readLines(path),
      basename(path)
    )
  })
})

test_that("Ignored chunks in .Rnw file", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/ignore-test.Rnw")
  expect_snapshot({
    scan_path_deps_do(
      readBin(path, "raw", file.size(path)),
      basename(path)
    )
  })
})

test_that("IPython notebook", {
  local_reproducible_output(width = 500)
  path <- test_path("fixtures/scan/notebook.ipynb")
  expect_snapshot({
    scan_path_deps_do(readLines(path), basename(path))
  })
})