Last active
December 3, 2025 01:01
-
-
Save HughParsonage/7a8d88175af1dc52ed754a6849a932d0 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # Things you might want to change | |
| # options(papersize="a4") | |
| # options(editor="notepad") | |
| # options(pager="internal") | |
| # set the default help type | |
| options(help_type="html") | |
| options(askYesNo = function(msg, default = NA, prompts, ...) { | |
| switch(menu(title = msg, | |
| choices = c("Yes", "No", "Cancel"), | |
| graphics = FALSE), | |
| switch(TRUE, FALSE, NA)) | |
| }) | |
| # set a site library | |
| # .Library.site <- file.path(chartr("\\", "/", R.home()), "site-library") | |
| # set a CRAN mirror | |
| # local({r <- getOption("repos") | |
| # r["CRAN"] <- "http://my.local.cran" | |
| # options(repos=r)}) | |
| # Give a fortune cookie, but only to interactive sessions | |
| # (This would need the fortunes package to be installed.) | |
| # if (interactive()) | |
| # fortunes::fortune() | |
| file_size <- function(...) { | |
| o <- file.info(..., extra_cols = FALSE) | |
| s <- o$size | |
| out <- as.character(s) | |
| wkb <- s >= 1024 & s <= 1024^2 | |
| out[wkb] <- paste0(round(s[wkb] / 1024, 2), " KB") | |
| wmb <- s >= 1024^2 & s <= 1024^3 | |
| out[wmb] <- paste0(round(s[wmb] / 1024^2, 2), " MB") | |
| wgb <- s >= 1024^3 | |
| out[wgb] <- paste0(round(s[wgb] / 1024^3, 2), " GB") | |
| o$Size <- out | |
| o[, "Size", drop = FALSE] | |
| } | |
| pkg_copy <- function(path = ".", dest, use.robocopy = TRUE) { | |
| get_wd <- getwd() | |
| on.exit(setwd(get_wd)) | |
| robocopy <- function(from = ".", to, recursive = FALSE, ..., J = FALSE) { | |
| if (!dir.exists(to)) dir.create(to) | |
| if (use.robocopy && .Platform$OS == "windows" && !identical(from, ".")) { | |
| shell(paste0("(", | |
| paste("robocopy", | |
| from, | |
| to, | |
| "*.*", | |
| if (recursive) "/S", | |
| if (J) "/J", | |
| # Don't print output | |
| "> NUL"), | |
| ") ", | |
| "^& IF %ERRORLEVEL% LEQ 1 exit 0")) | |
| } else { | |
| base::file.copy(from, to, recursive = recursive, ...) | |
| } | |
| } | |
| setwd(path) | |
| top_level_dirs <- list.dirs(recursive = FALSE, full.names = FALSE) | |
| ignore_dirs <- | |
| if (!file.exists(file.path(path, ".Rbuildignore"))) { | |
| invisible(NULL) | |
| } else { | |
| rbuildignore <- readLines(file.path(path, ".Rbuildignore")) | |
| rbuildignore_unescaped <- sub("^\\^(.*)\\$$", "\\1", rbuildignore) | |
| rbuildignore_unescaped <- | |
| gsub("\\.", ".", rbuildignore_unescaped, fixed = TRUE) | |
| igds <- vapply(rbuildignore_unescaped, dir.exists, FALSE) | |
| igds <- names(igds[igds]) | |
| } | |
| dirs_to_copy <- top_level_dirs | |
| dirs_to_copy <- setdiff(dirs_to_copy, ignore_dirs) | |
| dirs_to_copy <- setdiff(dirs_to_copy, ".git") | |
| dirs_not_yet_excluded <- setdiff(ignore_dirs, top_level_dirs) | |
| # Provide the directory: | |
| if (!dir.exists(dest)) { | |
| dir.create(dest) | |
| } | |
| # Copy the top-level files (regardless of build status) | |
| '%notin%' <- function(x, y) match(x, y, nomatch = 0L) == 0L | |
| top_level_files <- dir() | |
| top_level_files <- top_level_files[top_level_files %notin% top_level_dirs] | |
| for (i in top_level_files) { | |
| base::file.copy(i, file.path(dest, i)) | |
| } | |
| for (a in dirs_to_copy) { | |
| dest_a <- file.path(dest, a) | |
| if (dir.exists(dest_a)) { | |
| if (length(dir(dest_a))) { | |
| stop(normalizePath(dest_a), " exists but is not empty.") | |
| } | |
| } else { | |
| dir.create(dest_a) | |
| } | |
| robocopy(a, dest_a, recursive = TRUE) | |
| } | |
| setwd(dest) | |
| # It seems quicker to copy then remove than to | |
| # try to copy only those needed | |
| for (file.ignore in rbuildignore_unescaped) { | |
| if (dir.exists(file.ignore)) { | |
| unlink(file.ignore, recursive = TRUE) | |
| } | |
| if (file.exists(file.ignore)) { | |
| unlink(file.ignore, recursive = TRUE) | |
| } | |
| } | |
| setwd(get_wd) | |
| dest | |
| } | |
| rcmdcheck <- function(pkg = ".", tests = TRUE, vignettes = TRUE) { | |
| tempf <- tempfile("") | |
| dir.create(tempf) | |
| pkg_copy(pkg, dest = tempf) | |
| cat("\nMoved to ", normalizePath(tempf, winslash = "/"), ".\n") | |
| rcmdcheck::rcmdcheck(path = tempf, | |
| build_args = if (!vignettes) "--no-build-vignettes", | |
| args = if (!tests && !vignettes) { | |
| "--no-tests --no-vignettes" | |
| } else if (!tests) { | |
| "--no-tests" | |
| } else if (!vignettes) { | |
| "--no-vignettes" | |
| }) | |
| } | |
| de_in <- function(quiet = TRUE, quick = TRUE, verbose = FALSE, | |
| refresh_init = TRUE) { | |
| ## Determine package path and name more robustly | |
| pkg_path <- normalizePath(".", mustWork = TRUE) | |
| desc_file <- file.path(pkg_path, "DESCRIPTION") | |
| pkg_name <- basename(pkg_path) | |
| if (file.exists(desc_file)) { | |
| dcf <- read.dcf(desc_file, fields = "Package") | |
| if (!is.null(dcf) && nrow(dcf) == 1L && nzchar(dcf[1L, 1L])) { | |
| pkg_name <- dcf[1L, 1L] | |
| } | |
| } | |
| ## Clean unload (namespace + DLLs + S4) if loaded | |
| if (pkg_name %in% loadedNamespaces()) { | |
| pkgload::unload(pkg_name, quiet = quiet) | |
| } | |
| ## (Re)generate Rcpp exports if there is any C++ source | |
| if (dir.exists("src")) { | |
| cpp_files <- list.files("src", pattern = "\\.cpp$", full.names = TRUE) | |
| if (length(cpp_files) > 0L && requireNamespace("Rcpp", quietly = TRUE)) { | |
| Rcpp::compileAttributes(verbose = verbose) | |
| } | |
| } | |
| ## Refresh src/init.c for non-Rcpp native code | |
| ## - only if: | |
| ## * src/ exists | |
| ## * there is an existing src/init.c | |
| ## * no RcppExports.cpp (Rcpp now does its own registration) | |
| if (refresh_init && | |
| dir.exists("src") && | |
| file.exists("src/init.c") && | |
| !file.exists("src/RcppExports.cpp")) { | |
| tempf <- tempfile(fileext = ".c") | |
| ## Use C collation for deterministic skeleton output (avoids | |
| ## locale-dependent reordering of entries, as cpp11 had to fix). | |
| old_collate <- tryCatch(Sys.getlocale("LC_COLLATE"), | |
| error = function(e) NA_character_) | |
| if (!is.na(old_collate)) { | |
| on.exit(try(Sys.setlocale("LC_COLLATE", old_collate), silent = TRUE), | |
| add = TRUE) | |
| try(Sys.setlocale("LC_COLLATE", "C"), silent = TRUE) | |
| } | |
| ## For an already-registered package, tools::package_native_routine_registration_skeleton | |
| ## recommend character_only = FALSE when updating existing init.c. | |
| tools::package_native_routine_registration_skeleton( | |
| dir = pkg_path, | |
| con = tempf, | |
| character_only = FALSE | |
| ) | |
| if (!file.exists(tempf)) { | |
| stop("Failed to generate native registration skeleton for src/init.c") | |
| } | |
| md5_temp <- unname(tools::md5sum(tempf)) | |
| md5_init <- unname(tools::md5sum("src/init.c")) | |
| if (!identical(md5_temp, md5_init)) { | |
| file.copy(tempf, "src/init.c", overwrite = TRUE) | |
| } | |
| } | |
| ## Re-document and reinstall | |
| devtools::document(quiet = quiet) | |
| devtools::install(quiet = quiet, quick = quick, dependencies = FALSE) | |
| ## Load using pkgload (matches devtools::load_all) | |
| pkgload::load_all(pkg_path, quiet = quiet) | |
| invisible(pkg_name) | |
| } | |
| goto_test <- function(name) { | |
| test_dir <- ifelse(dir.exists("inst/tinytest"), | |
| "./inst/tinytest", | |
| "./tests/testthat/") | |
| possible_files <- | |
| dir(path = test_dir, | |
| pattern = paste0("test.*", name, ".*\\.R$"), | |
| full.names = TRUE) | |
| if (length(possible_files) == 0) { | |
| resp <- | |
| menu(graphics = FALSE, | |
| title = "No matching file found. Create one?", | |
| choices = c("Yes", "No")) | |
| if (resp == 1) { | |
| name.R <- | |
| hutils::provide.file(file.path(test_dir, paste0("test_", name, ".R"))) | |
| return(rstudioapi::navigateToFile(name.R)) | |
| } | |
| return(invisible(NULL)) | |
| } | |
| if (length(possible_files) > 1) { | |
| message("Multiple files found: ", toString(basename(possible_files)), | |
| " the first will be used.") | |
| possible_files <- possible_files[1] | |
| } | |
| rstudioapi::navigateToFile(possible_files) | |
| } | |
| test <- function(filter = NULL, ...) { | |
| if (requireNamespace("devtools", quietly = TRUE) && | |
| devtools::uses_testthat()) { | |
| devtools::test(".", filter = filter, ...) | |
| } else if (requireNamespace("tinytest", quietly = TRUE) && | |
| dir.exists("./inst/tinytest")) { | |
| if (is.null(filter)) { | |
| tinytest::test_all() | |
| } else { | |
| for (file.R in dir("inst/tinytest", | |
| pattern = paste0("^test.*", filter), | |
| full.names = TRUE)) { | |
| tinytest::run_test_file(file.R) | |
| } | |
| } | |
| } else { | |
| message("No test suite available.") | |
| } | |
| } | |
| dir_size <- function(folder, Recurse = FALSE) { | |
| stopifnot(.Platform$OS.type == "windows", | |
| requireNamespace("readr", quietly = TRUE)) | |
| get_wd <- getwd() | |
| on.exit(setwd(get_wd)) | |
| setwd(folder) | |
| res <- if (Recurse) { | |
| shell("powershell -command \"$fso = new-object -com Scripting.FileSystemObject; gci -Recurse -Directory | select @{l='Size'; e={$fso.GetFolder($_.FullName).Size}},FullName | sort Size -Descending | ft @{l='Size [MB]'; e={'{0:N2} ' -f ($_.Size / 1MB)}},FullName\"", | |
| intern = TRUE) | |
| } | |
| else { | |
| shell("powershell -command \"$fso = new-object -com Scripting.FileSystemObject; gci -Directory | select @{l='Size'; e={$fso.GetFolder($_.FullName).Size}},FullName | sort Size -Descending | ft @{l='Size [MB]'; e={'{0:N2} ' -f ($_.Size / 1MB)}},FullName\"", | |
| intern = TRUE) | |
| } | |
| res <- res[nzchar(res)] | |
| res <- res[!startsWith(res, "----")] | |
| is_dup <- length(res) == 2 | |
| new_res <- if (is_dup) | |
| c(res[-1], res[-1]) | |
| else res[-1] | |
| out <- readr::read_fwf(new_res, | |
| col_positions = readr::fwf_empty(new_res, | |
| col_names = c("Size [MB]", "FullName"), | |
| skip_empty_rows = TRUE)) | |
| if (is_dup) { | |
| out <- out[!duplicated(out), ] | |
| } | |
| setwd(get_wd) | |
| out | |
| } | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment