add drake-based revdepcheck from RSQLite

krlmlr · krlmlr · commit 917fabccde91 · 2018-03-24T00:11:47.000Z
diff --git a/.gitignore b/.gitignore
@@ -1,3 +1,4 @@
 .Rproj.user
 .Rhistory
 .RData
+/.drake
diff --git a/revdep/.gitignore b/revdep/.gitignore
@@ -0,0 +1,3 @@
+/.cache.rds
+/libs
+/download
diff --git a/revdep/drake-base.R b/revdep/drake-base.R
@@ -0,0 +1,42 @@
+library(drake)
+library(tidyverse)
+library(glue)
+
+options(repos = revdepcheck:::get_repos(TRUE))
+
+get_this_pkg <- function() {
+  desc::desc_get("Package") %>% unname()
+}
+
+get_base_pkgs <- function() {
+  rownames(installed.packages(priority = "base"))
+}
+
+flatten <- . %>% unname() %>% unlist() %>% unique()
+
+retry <- function(code, N = 1) {
+  quo <- rlang::enquo(code)
+
+  for (i in seq_len(N)) {
+    ret <- tryCatch(rlang::eval_tidy(quo), error = identity)
+    if (!inherits(ret, "error")) return(ret)
+    Sys.sleep(runif(1) * 2)
+  }
+
+  stop(ret)
+}
+
+get_plan_deps <- function() {
+  plan_deps <- drake_plan(
+    available = available.packages(),
+    this_pkg = get_this_pkg(),
+    revdeps = tools::package_dependencies(this_pkg, available, 'most', reverse = TRUE) %>% flatten(),
+    first_level_deps = tools::package_dependencies(revdeps, available, 'most'),
+    all_level_deps = tools::package_dependencies(first_level_deps %>% flatten(), available, recursive = TRUE),
+    base_pkgs = get_base_pkgs(),
+    deps = c(revdeps, first_level_deps, all_level_deps) %>% flatten() %>% tools::package_dependencies(recursive = TRUE) %>% .[!(names(.) %in% base_pkgs)],
+    strings_in_dots = "literals"
+  )
+
+  plan_deps
+}
diff --git a/revdep/drake.R b/revdep/drake.R
@@ -0,0 +1,266 @@
+source("revdep/drake-base.R")
+
+subset_available <- function(available, pkg) {
+  if (pkg %in% rownames(available)) {
+    available[pkg, , drop = FALSE]
+  } else {
+    available[integer(), , drop = FALSE]
+  }
+}
+
+download <- function(pkg, available, ...) {
+  dir <- fs::dir_create("revdep/download")
+  dir <- fs::path_real(dir)
+
+  withr::with_options(
+    list(warn = 2),
+    download.packages(pkg, dir, available = available)[, 2]
+  )
+}
+
+get_i_lib <- function() {
+  path <- "revdep/libs/cran"
+  fs::dir_create(path)
+  fs::path_real(path)
+}
+
+install <- function(pkg, path, ...) {
+  dep_packages <- list(...)
+  dep_paths <- map_chr(dep_packages, attr, "path")
+  stopifnot(all(fs::dir_exists(dep_paths)))
+
+  deps <- c(pkg, sort(as.character(unique(unlist(map(dep_packages, attr, "deps"))))))
+
+  lib <- get_i_lib()
+
+  # Avoid flaky check for compiler availability on mclapply()
+  pkgbuild:::cache_set("has_compiler", TRUE)
+
+  withr::with_libpaths(
+    lib, action = "replace",
+    # Suppress warnings about loaded packages
+    retry(suppressWarnings(pkginstall::install_source(path, vignettes = FALSE)))
+  )
+
+  structure(
+    pkg,
+    path = file.path(lib, pkg),
+    version = utils::packageVersion(pkg, lib),
+    deps = deps
+  )
+}
+
+get_old_lib <- function() {
+  path <- "revdep/libs/old"
+  fs::dir_create(path)
+  fs::path_real(path)
+}
+
+get_new_lib <- function() {
+  path <- "revdep/libs/new"
+  fs::dir_create(path)
+  fs::path_real(path)
+}
+
+create_lib <- function(pkg, lib) {
+  fs::dir_create(lib)
+
+  target <- fs::path(lib, pkg)
+  fs::link_delete(target[fs::link_exists(target)])
+  fs::link_create(fs::path(get_i_lib(), pkg), target)
+  lib
+}
+
+create_new_lib <- function(old_lib, new_lib) {
+  lib <- c(new_lib, old_lib)
+  withr::with_libpaths(lib, action = "replace", {
+    remotes::install_local(".")
+  })
+
+  lib
+}
+
+get_pkg_and_deps <- function(i_pkg) {
+  get_deps(i_pkg)
+}
+
+get_deps <- function(i_pkg) {
+  attr(i_pkg, "deps")
+}
+
+check <- function(tarball, lib, ...) {
+  pkgs <- c(...)
+  check_lib <- fs::file_temp("checklib")
+  create_lib(pkgs, check_lib)
+  withr::with_libpaths(c(lib, check_lib), rcmdcheck::rcmdcheck(tarball, quiet = TRUE, timeout = ignore(600)))
+}
+
+compare <- function(old, new) {
+  rcmdcheck::compare_checks(old, new)
+}
+
+get_plan <- function() {
+
+  plan_deps <- get_plan_deps()
+  config_deps <- drake_config(plan_deps)
+  if (length(outdated(config_deps, make_imports = FALSE)) > 0) {
+    warning("Making dependencies first, rerun.", call. = FALSE)
+    return(plan_deps)
+  }
+
+
+# Avoid expensive and flaky check for build tools from pkgbuild
+# Leads to errors, need to check!
+#options(buildtools.check = identity)
+
+  deps <- readd(deps)
+
+  make_subset_available <- function(pkg) {
+    expr(subset_available(available, !!pkg))
+  }
+
+  plan_available <-
+    deps %>%
+    enframe() %>%
+    transmute(
+      target = glue("av_{name}"),
+      call = map(name, make_subset_available)
+    ) %>%
+    deframe() %>%
+    drake_plan(list = .)
+
+  make_download <- function(pkg, my_pkgs) {
+    av_pkg <- sym(glue("av_{pkg}"))
+    deps <- list()
+    if (!(pkg %in% my_pkgs)) {
+      deps <- c(deps, expr(old_lib))
+    }
+
+    expr(download(!!pkg, available = !!av_pkg, !!!deps))
+  }
+
+  plan_download <-
+    deps %>%
+    enframe() %>%
+    transmute(
+      target = glue("d_{name}"),
+      call = map(name, make_download, c(get_this_pkg(), deps[[get_this_pkg()]]))
+    ) %>%
+    deframe() %>%
+    drake_plan(list = .)
+
+  make_install <- function(pkg, dep_list) {
+    d_pkg <- sym(glue("d_{pkg}"))
+    expr(install(!!pkg, path = !!d_pkg, !!! dep_list))
+  }
+
+  create_dep_list <- function(deps, base_pkgs) {
+    valid_deps <- setdiff(deps, base_pkgs)
+    syms(glue("i_{valid_deps}"))
+  }
+
+  plan_install <-
+    deps %>%
+    enframe() %>%
+    mutate(target = glue("i_{name}")) %>%
+    mutate(
+      dep_list = map(value, create_dep_list, readd(base_pkgs)),
+      call = map2(name, dep_list, make_install)
+    ) %>%
+    select(target, call) %>%
+    deframe() %>%
+    drake_plan(list = .)
+
+  plan_base_libs <- drake_plan(
+    old_lib = create_lib(get_pkg_and_deps(!!sym(glue("i_{get_this_pkg()}"))), get_old_lib()),
+    new_lib = create_new_lib(old_lib, get_new_lib())
+  )
+
+  make_check <- function(pkg, lib, deps, first_level_deps, base_pkgs) {
+    lib <- enexpr(lib)
+
+    req_pkgs <- first_level_deps[[pkg]]
+    req_pkgs_deps <- deps[c(pkg, req_pkgs)] %>% unname() %>% unlist() %>% unique()
+    all_deps <- c(req_pkgs, req_pkgs_deps) %>% unique()
+
+    i_deps <- create_dep_list(all_deps, base_pkgs)
+    d_dep <- sym(glue("d_{pkg}"))
+
+    expr(check(!!d_dep, !!lib, !!! i_deps))
+  }
+
+  plan_check <-
+    readd(revdeps) %>%
+    enframe() %>%
+    mutate(
+      old = map(value, make_check, old_lib, readd(deps), readd(first_level_deps), readd(base_pkgs)),
+      new = map(value, make_check, new_lib, readd(deps), readd(first_level_deps), readd(base_pkgs))
+    ) %>%
+    gather(kind, call, old, new) %>%
+    transmute(
+      target = glue("c_{value}_{kind}"),
+      call
+    ) %>%
+    deframe() %>%
+    drake_plan(list = .)
+
+  make_compare <- function(pkg) {
+    old_result <- sym(glue("c_{pkg}_old"))
+    new_result <- sym(glue("c_{pkg}_new"))
+    expr(compare(!!old_result, !!new_result))
+  }
+
+  plan_compare <-
+    readd(revdeps) %>%
+    enframe() %>%
+    transmute(
+      target = glue("c_{value}"),
+      call = map(value, make_compare)
+    ) %>%
+    deframe() %>%
+    drake_plan(list = .)
+
+  make_compare_all <- function(pkg) {
+    check_targets <- set_names(syms(glue("c_{pkg}")), pkg)
+    expr(list(!!! check_targets))
+  }
+
+  plan_compare_all <-
+    readd(revdeps) %>%
+    enframe() %>%
+    summarize(
+      target = "compare_all",
+      call = list(make_compare_all(value))
+    ) %>%
+    deframe() %>%
+    drake_plan(list = .)
+
+  #future::plan(future.callr::callr)
+
+  plan <-
+    bind_rows(
+      # Put first to give higher priority
+      plan_check,
+      plan_compare,
+      plan_compare_all,
+      plan_install,
+      plan_base_libs,
+      plan_download,
+      plan_available,
+      plan_deps
+    )
+
+  plan
+}
+
+plan <- get_plan()
+
+#trace(conditionCall.condition, recover)
+make(
+  plan,
+  #"compare_all",
+  keep_going = TRUE,
+  #parallelism = "future"
+  , verbose = 3
+  , jobs = parallel::detectCores() - 2
+)

-Original file line number
+Diff line change
@@ @@ -1,3 +1,4 @@ @@
 .Rproj.user
 .Rhistory
 .RData
 +/.drake
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+/.cache.rds`
	`2`	`+/libs`
	`3`	`+/download`