drake.R
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()
withr::with_envvar(
c(R_LIBS_USER = lib),
# Suppress warnings about loaded packages
retry(system(paste0("R CMD INSTALL ", path)))
)
stopifnot(dir.exists(file.path(lib, pkg)))
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)
check_targets <- map(check_targets, function(x) expr(try(!!x)))
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()
)