Skip to content

Instantly share code, notes, and snippets.

@olivroy

olivroy/.Rprofile

Last active April 22, 2024 02:04
Show Gist options
  • Save olivroy/0f521941a1c2d35257de33c73ce07e50 to your computer and use it in GitHub Desktop.
Save olivroy/0f521941a1c2d35257de33c73ce07e50 to your computer and use it in GitHub Desktop.
Download ZIP
Deprecated, moved to elsewhere
Raw
.Rprofile
# if (FALSE && rlang::is_interactive()) {
if (interactive() && !"rlang" %in% rownames(utils::installed.packages())) utils::install.packages("rlang", type = "binary")
# options(rlang_interactive = FALSE)
if (interactive()) rlang::check_installed(c("pak", "rprojroot", "tidyverse", "gt", "quarto", "skimr", "kit", "sf"))
# my packages
# if (interactive()) {
# invisible(pak::repo_add(sfirke = "https://sfirke.r-universe.dev", olivroy = "https://olivroy.r-universe.dev"))
# }
if (interactive() && getRversion() >= "4.4.0") {
pak::pak(c(
"olivroy/reuseme",
"r-lib/lifecycle#184", # if PR not merged
"r-lib/gtable#94", # if PR not merged
"r-lib/pkgload", # if pkgload 1.3.5 not released
"jimjam-slam/ggflags",
"lionel-/codegrip ",
"r-lib/usethis", # if usethis 2.3.0 not released
"r-lib/devtools#2561",
"ropensci/spelling#81",
"tidyverse/tidytemplate",
"r-lib/pkgapi",
"rfsaldanha/rspell" # spell check
))
pak::pkg_install(c(
"local::~/rrr/canadr/",
"local::~/rrr/instat-r/"
))
}
if (interactive()) rlang::check_installed("janitor (>= 2.2.0.9000)", action = \(pkg, ...) utils::install.packages("janitor", repos = c("https://sfirke.r-universe.dev", "https://cloud.r-project.org")))
# Possibly modify those with hooks https://github.com/rstudio/rstudioapi/issues/100
if (!rstudioapi::isAvailable()) {
# RStudio is not available on startup, so need to initialize these manually.
# but will leave in as older RStudio versions are used.
current_dir <- getwd()
is_pkg_repo <- !isFALSE(tryCatch(rprojroot::find_root(rprojroot::is_r_package, path = current_dir), error = function(e) FALSE))
is_git <- !isFALSE(tryCatch(rprojroot::find_root(rprojroot::is_git_root, path = current_dir), error = function(e) FALSE))
active_proj <- tryCatch(rprojroot::find_root(rprojroot::is_rstudio_project, path = current_dir), error = function(e) "Not in a project")
rm(current_dir)
} else {
is_pkg_repo <- !isFALSE(tryCatch(rprojroot::find_root(rprojroot::is_r_package), error = function(e) FALSE))
is_git <- !isFALSE(tryCatch(rprojroot::find_root(rprojroot::is_git_root), error = function(e) FALSE))
rlang::check_installed("reuseme (>= 0.0.0.9008)", action = \(pkg, ...) utils::install.packages("reuseme", repos = c("https://olivroy.r-universe.dev", "https://cloud.r-project.org")))
active_proj <- tryCatch(usethis:::proj_get(), error = function(e) "Not in a project")
}
# to test RStudio startup behaviour
if (rlang::is_interactive()) {
active_proj_startup <- tryCatch(rprojroot::find_root(criterion = rprojroot::is_rstudio_project), error = function(e) "Not in a project")
}
if (TRUE && rlang::is_interactive()) {
edit_proj_config <- function() {
rstudioapi::executeCommand("projectOptions")
}
pkg_version <- function(package) {
sessioninfo::session_info(
pkgs = "usethis",
dependencies = FALSE,
info = "packages"
)
}
#' Edit RProfile with some hacks
#'
#' If `open` is a function name, will go directly to this location.
#' @param open TRUE, FALSE or a function name to get to this location
#' @inheritParams usethis::edit_r_profile
#' @param alpha Should the file outline be printed alphabetically?
#' @param print_todo Should print todo?
#'
#' @return
#' @export
#'
#' @examples
#' edit_r_profile(print.tbl) # will take you to the right place
#' edit_r_profile(alpha = FALSE) # will print the file outline contents in the order they appear
#' edit_r_profile(print_todo = TRUE) # will show todo items in your Rprofile.
edit_r_profile <- function(open = NULL, scope = c("user", "project"), alpha = TRUE, print_todo = FALSE) {
# Make this available in pkg (no longer depend on file_outline)
scope <- rlang::arg_match(scope)
if (scope == "user") {
cli::cli_inform("Make sure it is up with the {.href [repo](https://gist.github.com/olivroy/d2c2f2a6869bddbf2cb4291f155c6552)}")
}
# https://cli.r-lib.org/reference/links.html?q=line%20nu#line-and-column-numbers
# usethis::edit_r_profile(scope = scope)
# Windows / RStudio is locking my .Rprofile, I use this to workaround.
path_r_prof_user <- if (fs::file_exists(fs::path_home_r("actual-r-profile.R"))) {
fs::path_home_r("actual-r-profile.R")
} else {
fs::path_home_r(".Rprofile")
}
path_rprof <- ifelse(scope == "user", path_r_prof_user, ".Rprofile")
line_r_prof <- character(0)
# If creating a new file, you don't want to show the outline.
tryCatch(
{
# The View function created by RStudio is possibly a simpler approach for this
# However, works well only if sourced,
# and / or if function is not nested.
function_call <- format(substitute(open))
if (function_call %in% c("TRUE", "FALSE", "NULL", "T", "F")) {
stop("not a function")
}
function_call <- function_call[length(function_call)]
function_call <- stringr::str_remove(function_call, "\\(\\)$")
function_call_regexp <- paste0(function_call, "\\s?(=|(<-))\\sfunction\\(")
rprof_content <- readLines(path_rprof, encoding = "UTF-8")
line_r_prof <- stringr::str_which(rprof_content, function_call_regexp)
},
error = function(e) NULL
)
if (length(line_r_prof == 1)) {
reuseme::open_rs_doc(
path_rprof,
line = line_r_prof
)
cli::cli_ul("Modify {.fn {function_call}} in {.file {path_rprof}}") # cli::cli_ul
return(invisible())
} else {
# forget we did all this.
open <- NULL
}
show_file_outline <- rlang::is_installed("reuseme (>= 0.0.0.9008)") && !isTRUE(open) && fs::file_exists(path_rprof)
# only show file outline if the function is defined, and the user doesn't want
# to open immediately (can do this by writing edit_r_profile(TRUE))
if (show_file_outline) {
reuseme::file_outline(path = path_rprof, work_only = FALSE, alpha = alpha, print_todo = print_todo)
} else if (!fs::file_exists(path_rprof)) {
usethis::edit_r_profile(scope = scope)
} else {
usethis::edit_file(path_rprof)
}
if (packageVersion("usethis") < "2.2.3.9000") {
cli::cli_ul("Modify {.file {path_rprof}}") # cli::cli_ul
usethis::ui_todo("Restart R for changes to take effect")
}
invisible(path_rprof)
}
edit_lintr <- function() {
# Make this available in pkg (no longer depend on file_outline)
path_lintr <- Sys.getenv("R_LINTR_LINTER_FILE",
unset = usethis:::path_first_existing(
c(".lintr", fs::path_home_r(".lintr"), fs::path_home(".lintr"))
) %||% ""
)
cli::cli_inform(c(
" Make sure it is up with the {.href [repo](https://gist.github.com/olivroy/ea1ae9ad00b54eb78e2cfd1910097d0c)}"
))
usethis::edit_file(path_lintr)
if (utils::packageVersion("usethis") < "2.2.3.9000") {
cli::cli_ul("Modify {.file {path_lintr}}.") # cli::cli_ul
}
invisible(path_lintr)
}
# is_in_prj <- tryCatch(rstudioapi::getActiveProject(), error = \(x) FALSE, TRUE)
# if (!isFALSE(is_in_prj)) is_in_prj <- TRUE
#' Makes it easy to see which tricks to display
#'
#' @param is_git
#' @param is_pkg
#'
#' @return
#'
#' @examples
# project specific
#' .internal_which_tricks_cat()
#' .internal_which_tricks_cat(is_git)
.internal_which_tricks_cat <- function(is_git = NULL, is_pkg = NULL) {
if (is.null(is_git)) {
is_git <- !isFALSE(tryCatch(rprojroot::find_root(rprojroot::is_git_root), error = function(e) FALSE))
}
if (is.null(is_pkg)) {
is_pkg <- !isFALSE(tryCatch(rprojroot::find_root(rprojroot::is_r_package), error = function(e) FALSE))
}
is_fork <- stringr::str_detect(getwd(), "rrr-forks")
types <- names(list_tricks_categories())
# To avoid printing them always in the same order
types <- sample(types, size = length(types))
types <- setdiff(types, "done")
# Don't print categories of tricks depending on project type
if (is_pkg) {
types <- setdiff(types, c("gen", "wf", "viz", "jobs"))
}
if (!is_pkg) {
types <- setdiff(types, c("pkg"))
}
if (!is_git) {
types <- setdiff(types, c("pkg", "git", "jobs"))
}
if (is_fork) {
types <- setdiff(types, c("indigenous", "isc-r", "write", "quarto", "viz"))
}
types
}
## `options()` (pkg) --------
options(
warnPartialMatchArgs = TRUE,
warnPartialMatchDollar = TRUE,
warnPartialMatchAttr = TRUE,
showWarnCalls = TRUE,
shiny.error = rlang::entrace,
usethis.description = list(
"Authors@R" = utils::person("Olivier", "Roy", email = "[email protected]", role = c("aut", "cre")),
License = "MIT + file LICENSE"
),
usethis.protocol = "https",
lifecycle_verbosity = "warning",
# cli.width = cli::console_width() - 1L,
reuseme.reposdir = fs::path_home("Documents", c("rrr", "rrr-forks")), # Default path for RStudio projects
usethis.destdir = fs::path_home("Documents", "rrr-forks") # Automatically create a repo in this directory.)
)
print_tricks <- function(type = "project_specific", n = NULL, as_bullets = TRUE, freq = NULL, id = NULL, ...) {
rlang::check_dots_used()
withr::local_options(list(cli.num_colors = cli::num_ansi_colors()))
cond <- tryCatch(
basename(reuseme::active_rs_doc()) == "TRICKS.md",
error = function(e) FALSE
)
if (cond) {
context <- rstudioapi::getSourceEditorContext()
rstudioapi::documentSave(id = context$id)
doc_content <- readLines(reuseme::active_rs_doc(), encoding = "UTF-8")
current_line <- rstudioapi::getSourceEditorContext()$selection[[1]][1]$range$start[1]
print(length(doc_content))
rlang:::check_number_whole(current_line, min = 1, max = as.numeric(length(doc_content)))
while (!stringr::str_starts(doc_content[current_line], "###")) {
if (current_line == 0) {
cli::cli_abort("internal error. Function not correctly implemented.")
}
current_line <- current_line - 1L
}
type <- stringr::str_extract(doc_content[current_line], "\\{\\{(.+)\\}\\}", group = 1)
}
if (identical(type, "project_specific")) {
type <- .internal_which_tricks_cat(...)
}
type <- rlang::arg_match(type, values = names(list_tricks_categories(with_all = TRUE)), multiple = TRUE)
bullets <- .internal_map_tricks(type, return_val = "tricks")
if (!is.null(n)) {
bullets <- sample(bullets, size = n)
}
# r-lib/cli#627 is fixed. Inline markup works correctly with 2023.12.0
# if (!rstudioapi::isAvailable("2023.12.0.274") && rstudioapi::isAvailable()) {
# bullets <- stringr::str_replace(bullets, "\\}$", "}.")
# bullets <- stringr::str_replace(bullets, "^\\{", ".{")
# }
if (!cond) cli::cli_inform("Run {.run [`edit_tricks()`](usethis::edit_file('~/Documents/TRICKS.md'))} to edit.")
if (as_bullets) {
if (is.null(freq)) freq <- "always"
# difficult to debug if I didn't format my tricks properly.
cli::cli_inform(bullets, .frequency = freq, .frequency_id = id)
}
invisible(bullets)
}
# use to know what is going on
list_tricks_categories <- function(with_all = FALSE) {
res <- .internal_map_tricks(alias_interest = "", return_val = "range")
if (!with_all) {
res$all <- NULL
}
res
}
edit_tricks <- function(type = "all") {
cli::cli_ul("Make sure it is up with the {.href [repo](https://gist.github.com/olivroy/6414971253d321c249b0600e844a383c)}.")
type <- rlang::arg_match0(type, names(list_tricks_categories(with_all = TRUE)))
if (type == "all") {
usethis::edit_file("~/Documents/TRICKS.md")
} else {
start_row <- .internal_map_tricks(alias_interest = type, return_val = "range")
reuseme::open_rs_doc("~/Documents/TRICKS.md", line = start_row[1])
}
if (rstudioapi::isAvailable("2023.09.0.375")) {
cli::cli_bullets(c("After that, use `print_tricks()`"))
} else {
print_tricks(type = type)
}
}
#' Internal use
#'
#' @param alias_interest if = "" will return all ranges
#' @param return_val
#'
#' @return Use the default value
#' @examples
.internal_map_tricks <- function(alias_interest = "", return_val = c("tricks", "range")) {
return_val <- rlang::arg_match(return_val)
doc <- tryCatch(
readLines(fs::path_home("Documents/TRICKS.md"), encoding = "UTF-8"),
error = function(e) {
cli::cli_warn(c(
"Documents/TRICKS.md doesn't exist. adding random tricks to continue.",
"See https://gist.github.com/olivroy/6414971253d321c249b0600e844a383c"
))
c(
"# Keyboard {{kbd}}",
" {.kbd Alt + Shift + J} Jump to section",
""
)
}
)
doc <- doc[nzchar(doc)] # Remove blanks
mapped_doc <- doc |>
tibble::enframe() |>
dplyr::mutate(
sect = dplyr::na_if(stringr::str_detect(value, "###"), FALSE),
sec_alias = stringr::str_extract(value, "\\{\\{(.+)\\}\\}", group = 1)
) |>
tidyr::fill(sec_alias)
if (return_val == "tricks" && (identical(alias_interest, "")) || identical(alias_interest, "all")) {
return(mapped_doc |> dplyr::filter(is.na(sect)) |> dplyr::pull(value))
}
if (return_val == "range" && identical(alias_interest, "all")) {
return(seq_along(doc))
}
all_aliases_start <- reuseme::extract_cell_value(
data = mapped_doc,
filter = !is.na(sect),
var = name,
name = "sec_alias"
)
all_aliases_end <- dplyr::lead(unname(all_aliases_start), default = length(doc) + 1) - 1
names(all_aliases_end) <- names(all_aliases_start)
all_aliases_start <- c("all" = 1, all_aliases_start + 1)
all_aliases_end <- c("all" = length(doc), all_aliases_end)
range <- purrr::map2(all_aliases_start, all_aliases_end, \(start, end) seq(start, end))
if (!all(alias_interest %in% names(range))) {
return(range)
}
if (return_val == "tricks") {
id <- unlist(range[alias_interest])
return(doc[id])
}
range[[alias_interest]]
}
format_inline_each <- function(x) {
purrr::map_vec(x, cli::format_inline)
}
is_in_reuseme_pkg_repo <- tryCatch(stringr::str_detect(active_proj, "reuseme"), error = function(e) FALSE)
if (!is_in_reuseme_pkg_repo) {
rlang::check_installed("reuseme (>= 0.0.0.9003)", reason = "access to my workflow helpers", action = \(pkg, ...) pak::pak("reuseme"))
# Test
use_todo2 <- function(todo) {
if (rlang::is_missing(todo)) {
other_items <- clipr::read_clip(allow_non_interactive = FALSE)
todo <- "Fix this code."
} else if (rlang::has_length(todo, 1) && stringr::str_detect(todo, "FIXME|all") && rlang::is_interactive()) {
other_items <- clipr::read_clip(allow_non_interactive = FALSE)
} else {
cli::cli_abort("weird, should not get there", .internal = TRUE)
}
if (length(other_items) > 15) {
cli::cli_warn("Probably not intended to copy {length(other_items)}, ignoring clipboard.")
}
rlang:::check_character(todo)
reuseme::use_todo(todo = todo, code = FALSE)
reuseme::use_todo(todo = other_items, code = TRUE)
}
library(reuseme)
}
rm(is_in_reuseme_pkg_repo)
# Package / Git specific functions --------------------------------------------------
if (is_git) {
tryCatch(
{
if (!gert::git_branch() %in% c("main", "master")) {
cli::cli_warn("We are on branch {.val {gert::git_branch()}}.")
}
},
error = function(e) NULL
)
if (is_pkg_repo) {
rlang::check_installed("devtools")
library(usethis, warn.conflicts = FALSE)
library(devtools)
is_in_pkgdown_pkg_repo <- tryCatch(stringr::str_detect(active_proj, "pkgdown"), error = function(e) FALSE)
if (!is_in_pkgdown_pkg_repo) {
check_pkgdown <- pkgdown::check_pkgdown
build_reference_index <- pkgdown::build_reference_index
}
snapshot_review <- testthat::snapshot_review
# TODO consider trying to put {.href [usethis PR helpers](https://usethis.r-lib.org/articles/pr-functions.html)} in background jobs.
# and use {.pkg beepr} to help.
cli::cli_bullets('See {.code usethis:::tidy_upkeep_checklist(posit_pkg = FALSE, posit_person_ok = TRUE) |> cat(sep = "\n")}')
use_test2 <- function(name = NULL, open = rlang::is_interactive()) {
if (!uses_testthat()) {
use_testthat_impl()
}
name_file <- fs::path("R", usethis:::compute_name(name))
path <- fs::path("tests", "testthat", paste0("test-", usethis:::compute_name(name)))
if (!fs::file_exists(path) && fs::file_exists(name_file)) {
lines <- readLines(name_file, encoding = "UTF-8")
fn_names <- stringr::str_subset(lines, stringr::fixed("<- function("))
fn_names <- stringr::str_remove(fn_names, "\\s?<- function.+")
if (length(fn_names) > 0) {
template <- c()
for (i in seq_along(fn_names)) {
template <- c(
template,
paste0('test_that("', fn_names[i], '() works", {'),
paste0(" expect_equal(", fn_names[i], "(), what)"),
"})",
""
)
}
}
usethis::write_over(template, path = path, quiet = TRUE)
}
usethis::edit_file(usethis::proj_path(path), open = open)
invisible(TRUE)
}
} else {
library(usethis, warn.conflicts = FALSE)
}
options(lifecycle_verbosity = "warning") # Always warn when using deprecated functions)
#' Open a Project or folder in VSCode
#'
#' @param path RStudio project, full directory path, or NULL (the default, the correct project)
#'
#' @return
#' @export
#'
#' @examples
open_vscode <- function(path = NULL) {
# Open a file to line and column
#
# vscode://file/{full path to file}:line:column
#
# vscode://file/c:/myProject/package.json:5:10
if (!is.null(path)) {
path <- fs::path_real(path)
}
path <- if (is.null(path)) {
usethis::proj_path()
} else if (!all(fs::is_dir(path)) && length(path) == 1) {
fs::dir_ls(
path = getOption("reuseme.reposdir") %||% fs::path_home("Documents", c("rrr", "rrr-forks")),
type = "directory",
regexp = paste0(path, "$"),
recurse = FALSE
)
} else {
fs::path_real(path)
}
if (!fs::is_dir(path)) {
cli::cli_abort("You must provide a dir. Rework `open_vscode in `~/.Rprofile` for file support.")
}
utils::browseURL(glue::glue("vscode://file/{path}"))
}
# check if you want a prompt
if (rlang::is_installed("prompt")) {
# from hadley https://posit.co/resources/videos/testthat-3/
prompt_git <- function(...) {
paste0(
"[", prompt::git_branch(), "]",
" > "
)
prompt::set_prompt(prompt_git)
rm(prompt_git)
}
# prompt::set_prompt(prompt::prompt_git)
}
# Copied from below.
git_add <- function(files = NULL, repo = ".", force = FALSE) {
if (is.null(files)) {
files <- active_rs_doc()
repo_path <- fs::path_real(repo)
common <- fs::path_common(c(files, repo_path))
files <- stringr::str_remove(files, common)
}
gert::git_add(files = files, repo = repo, force = force)
}
clean_files <- function() {
files <- gert::git_status(staged = FALSE) |>
dplyr::filter(status == "modified")
files <- files$file
# files to clear
files <- stringr::str_subset(
files,
"_files"
)
# https://github.com/rstudio/rstudio/issues/13303
# "index_files/libs/bootstrap/bootstrap.min.css"
# gert::git_branch_checkout()
# This will unstage all files you might have staged with git add:
# git reset HEAD -- <file>
# This will revert all local uncommitted changes (should be executed in repo root):
# git checkout -f -- <file>
command <- paste("git checkout -f --", paste(files, collapse = " "))
command
system(command)
cli::cli_inform("Reverted untracked changes.")
}
delete_untracked_file <- function(regexp_exclude = NULL) {
# inspired by usethis:::git_clean()
# https://github.com/rstudio/rstudio/issues/12453
st <- gert::git_status(staged = FALSE)
paths <- st[st$status == "new", ][["file"]]
if (!is.null(regexp_exclude)) {
paths <- stringr::str_subset(paths, "regexp_exclude", negate = TRUE)
}
n <- length(paths)
if (n == 0) {
cli::cli_inform(c(i = "Found no untracked files."))
return(invisible())
}
cli::cli_inform(c(
"There are {n} untracked files. {.file {paths}}",
paste0("Delete with {.run fs::file_delete('", paths, "')}")
))
}
clear_snapshots <- function() {
# Workaround to stage files, so that they disappear from git pane as modified
if (!fs::dir_exists("tests/testthat/_snaps")) {
cli::cli_inform("No snapshots")
return(invisible())
}
snap_files <- fs::dir_ls("tests/testthat/_snaps", regexp = ".new", invert = TRUE)
snap_files_changed <- fs::dir_ls("tests/testthat/_snaps", regexp = ".new.md", invert = FALSE)
snap_files_new <- stringr::str_replace_all(snap_files_changed, ".new.md", ".md")
snap_files_unchanged <- snap_files[!snap_files %in% snap_files_new]
st <- gert::git_status(staged = FALSE)
paths <- st[st$status == "new", ][["file"]]
snap_paths <- paths |> stringr::str_subset("tests/testthat/_snaps")
path_to_add <- snap_paths[snap_paths %in% snap_files_unchanged]
gert::git_add(
path_to_add
)
cli::cli_inform("Staged {.file {path_to_add}}")
invisible()
}
commit <- gert::git_commit
# Use commit all
commit_all <- gert::git_commit_all
git_push <- gert::git_push
# be careful, should only use this for my personal projects where I push to main.
proj_push <- function(repo = ".", ...) {
if (repo == ".") {
return(gert::git_push(repo = repo, ...))
}
proj_list <- reuseme::proj_list()
rlang::arg_match0(repo, names(proj_list))
repo_path <- proj_list[repo]
gert::git_push(repo = repo_path, ...)
}
# be careful with forks
proj_pull <- function(repo = ".", ...) {
rlang::check_dots_used()
if (repo == ".") {
return(gert::git_pull(repo = repo, ...))
}
proj_list <- reuseme::proj_list()
rlang::arg_match0(repo, names(proj_list))
repo_path <- proj_list[repo]
gert::git_pull(repo = repo_path, ...)
}
# be careful with my two accounts
proj_commit_all <- function(repo = ".", message, ...) {
rlang::check_dots_used()
if (repo == ".") {
return(gert::git_pull(repo = repo, ...))
}
proj_list <- reuseme::proj_list()
rlang::arg_match0(repo, names(proj_list))
repo_path <- proj_list[repo]
gert::git_commit_all(repo = repo_path, message = message, ...)
}
if (tryCatch(nrow(gert::git_remote_list()) != 0, error = function(e) TRUE)) {
push <- function() {
rstudioapi::jobAdd(name = "Push to remote", actions = list(
push = gert::git_push
))
}
pull <- function() {
rstudioapi::jobAdd(name = "Pull from remote", actions = list(
pull = gert::pull
))
}
}
git_pull <- gert::git_pull
user_email <- gert::git_config() |>
dplyr::filter(name == "user.email") |>
dplyr::arrange(dplyr::desc(level)) |>
dplyr::slice(1) |>
dplyr::pull(value)
## similar as this with reuseme
if (FALSE) {
user_email <- reuseme::extract_cell_value(
gert::git_config() |> dplyr::arrange(desc(level)),
var = value,
filter = c(name == "user.email"),
# length = 1,
name = "level"
)
user_email <- user_email[1]
}
if (length(user_email) != 1 || is.na(user_email)) {
user_email <- "No email"
}
# Very personal (.Rprofile)
if (tryCatch(nrow(gert::git_remote_list()) > 0, error = function(e) FALSE) && tryCatch(stringr::str_detect(gert::git_remote_info()$url, "github"), error = function(e) FALSE) && user_email != "[email protected]") {
cli::cli_warn(c(
"If forked a repo from GitHub",
'{.run gert::git_config_set("user.email", "[email protected]")}',
'For user {.run gert::git_config_set("user.name", "olivroy")}'
))
}
rm(user_email)
}
}
if (TRUE && rlang::is_interactive() && !is_pkg_repo) {
# Options and palettes -----------------------------------------------------
# Steps to make sure that you can use extra fonts.
# Use the extrafont package
# extrafont::font_import()
# extrafont::loadfonts(quiet = TRUE)
# Better now with systemfonts + dev: ragg_png
library(reprex)
if (!rlang::is_installed("opt")) {
rlang::check_installed("pkgbuild (>= 1.4.2)")
if (pkgbuild::has_build_tools()) {
rlang::check_installed(
"opt",
reason = "access to workflow options helpers. You need RTools to install",
action = \(pkg, ...) pak::pak("moodymudskipper/opt")
)
} else {
rlang::check_installed("remotes")
remotes::install_github("moodymudskipper/opt")
}
}
if (rlang::is_installed("opt")) {
library(opt)
}
## `options()` (eda) ------
options(
pillar.bold = TRUE, # To style column names as bold
pillar.advice = FALSE, # Since my `print.tbl()` gives advice
pillar.min_title_chars = 16, # Show at least 16 characters in col name
pillar.max_footer_lines = 15,
error = rlang::entrace,
shiny.error = rlang::entrace,
usethis.protocol = "https",
pillar.min_chars = 5, # Show at least 5 characters in a col name
conflicts.policy = list(warn = FALSE),
max.print = 200
)
# TODO use this trick in file_outline() withr::with_dir("R", cli::format_inline("{.file fsc-analysis.R:8}") |> cat())
# Stable functions
# Just using these functions interactively, without `pkg::`
# If used in scripts, load `pkg` or call `pkg::`
find_gcdocs_links <- function() {
content <- fs::dir_ls(c("~/Documents/rrr", "~/Downloads"), regexp = "\\.R$", recurse = TRUE) |>
fs::path_filter(regexp = "canadr|instat-r|reuseme|scraping", invert = TRUE) |>
purrr::set_names() |>
purrr::map(\(x) readLines(x, encoding = "UTF-8", warn = FALSE))
content |>
tibble::enframe() |>
tidyr::unnest(value) |>
filter(stringr::str_detect(tolower(value), "gcdocs")) |>
mutate(name = fs::path(name)) |>
relocate(value)
}
# pct takes a vector of columns to format as percentages.
interactive_tab <- function(data, pct = NULL, page_length = 10) {
rlang::check_installed("DT")
rlang:::check_number_whole(page_length, min = 5)
res <- data |>
janitor::clean_names(case = "title") |>
DT::datatable(extensions = "Responsive", style = "auto", options = list(pageLength = page_length)) |>
DT::formatStyle(fontFamily = "IBM Plex Sans", columns = seq_len(ncol(data)))
if (!is.null(pct)) {
tryCatch(
res <- DT::formatPercentage(res, columns = janitor::make_clean_names(pct, case = "title"), digits = 1),
error = function(e) {
cli::cli_inform("columns appear not to exist.", parent = e)
}
)
}
res
}
if (rlang::is_installed("reactable") && interactive()) {
options(reactable.theme = reactable::reactableTheme(
style = list(
fontFamily = "-apple-system, BlinkMacSystemFont, Segoe UI, Helvetica, IBM Plex Sans, sans-serif"
)
))
}
if (FALSE) {
# Not mature see (glin/reactable#329)
.internal_interactive_resp <- function(data) {
rlang::check_installed("reactable")
# brow
data_clean <- dplyr::rename_with(data, to_title)
data_text_cols <- dplyr::select(data_clean, dplyr::where(is_text_col))
if (ncol(data_text_cols) == 0) {
reactable::reactable(data_clean, searchable = TRUE)
return(invisible(data))
}
data_to_show <- dplyr::select(data_clean, !tidyselect::all_of(names(data_text_cols)))
row_details <- function(index) {
row <- data_text_cols[index, ]
text_to_show <- row |>
purrr::transpose() |>
purrr::list_c() |>
purrr::discard(is.na) |>
unlist()
to_show <- paste0(names(text_to_show), ": ", text_to_show, collapse = " <br> ")
htmltools::div( # Div can also take a list.. to check out..
htmltools::tags$li(to_show)
)
}
reactable::reactable(
data = data_to_show,
searchable = TRUE,
details = row_details
)
}
}
# May need to coordoninate with other similar functions, like pdf, Excel & al.
# canadr::edit_file is also not very relevant anymore
# Integrate with get_pdf etc.
image_read <- function(path = NULL, dir = NULL) {
dir <- dir %||% "figures"
rlang::check_installed("magick")
x <- fs::dir_ls(dir, type = "file", regexp = "png") |> purrr::set_names(fs::path_file)
cli::cli_bullets(c(
"Open",
paste0("{.run [", names(x), "](magick::image_read('", x, "'))}")
))
}
# open pdf in browser (override default app.)
open_pdf <- function(doc = NULL, proj = reuseme:::proj_get2()) {
if (.Platform$OS.type == "windows" && Sys.getenv("username") == "RoyO") {
# potentiall replace with `fs::file_show()`
# browser = "C:\\Program Files (x86)\\Microsoft\\Edge\\Application\\msedge.exe"
# fs::file_show(fs::path_real(doc), browser = browser)
}
# only on Windows
if (.Platform$OS.type != "windows") {
cli::cli_abort("Not sure it will work on macOS. fs::file_show should work.")
}
if (!is.null(doc) && fs::file_exists(doc)) {
doc <- fs::path_real(doc)
shell(glue::glue('start msedge.exe "file:///{doc}"'))
return(invisible(doc))
}
path <- NULL
in_proj_dir <- stringr::str_detect(doc, "\\~\\/", negate = TRUE)
if (!in_proj_dir) {
# cli::cli_abort("Not yet implemented", .internal = TRUE)
path <- fs::path_dir(doc) |> fs::path_real()
}
pdf_files <- fs::dir_ls(path = path %||% ".", type = "file", recurse = TRUE, regexp = "*.pdf$") |>
purrr::set_names(fs::path_file) |>
purrr::set_names(fs::path_ext_remove)
if (all(is.na(pdf_files[fs::path_ext_remove(doc)])) || length(pdf_files[fs::path_ext_remove(doc)]) == 0) {
rlang::arg_match0(doc, values = unname(pdf_files))
} else {
open_pdf(unname(pdf_files[doc]))
}
}
if (!"write_clip" %in% ls(envir = .GlobalEnv)) {
# write_clip, but returns data
write_clip <- function(content, override = TRUE) {
if (!override) {
clipr::write_clip(content)
# Sys.sleep(0.5)
tbl <- try(read_clip_tbl(), silent = TRUE)
while (!is.data.frame(tbl)) {
tbl <- try(read_clip_tbl(), silent = TRUE)
}
tbl
dim_copied <- dim(tbl)
dim_original <- dim(content)
if (!rlang::has_length(waldo::compare(dim_copied, dim_original), 0)) {
cli::cli_warn("Did not copy the full data, or have problems, please check. {dim_copied}")
}
return(content)
}
is_in_french <- Sys.getlocale() |> stringr::str_detect("French")
if (is.data.frame(content) && is_in_french) {
has_a_lgl_col <- purrr::some(content, is.logical)
if (!has_a_lgl_col) {
write_clip(content, override = FALSE)
} else {
content <- dplyr::mutate(
content,
dplyr::across(dplyr::where(is.logical), \(x) dplyr::case_when(
x ~ "VRAI",
!x ~ "FAUX",
.default = ""
))
)
cli::cli_inform(c(
"Changed TRUE -> VRAI, FALSE -> FAUX to copy to Excel",
"Use `override = FALSE` to use the default {.fun clipr::write_clip}"
))
}
}
clipr::write_clip(content)
tbl <- try(read_clip_tbl(), silent = TRUE)
while (!is.data.frame(tbl)) {
tbl <- try(read_clip_tbl(), silent = TRUE)
}
tbl
dim_copied <- dim(tbl)
dim_original <- dim(content)
if (!rlang::has_length(waldo::compare(dim_copied, dim_original), 0)) {
cli::cli_warn("Did not copy the full data, or have problems, please check. {dim_copied}")
}
content
}
# r-pkg
# if the issue isn't resolved, could put as reuseme::view_identity()
view <- function(x, title = NULL, ..., n = NULL) {
if (rlang::is_installed("sf") && inherits(x, "sf")) {
tibble::view(sf::st_drop_geometry(x), title = title, ..., n = n)
return(invisible(x))
}
tibble::view(x, title = title, ..., n = n)
}
read_clip_tbl <- function() {
x <- clipr::read_clip_tbl() |> tibble::as_tibble()
x
}
#' Format request name with a date argument
#'
#' req_id_fmt takes a date and returns the request ID formatted
#' req_parse_dir takes a `req_id` or a folder and returns the date
#'
#' Def:
#' `req_id` : `2023.07Jul05`
#'
#' @param date A date (default is today)
#'
#' @return the formatted name
#' @export
#'
#' @examples
#' testthat::expect_equal(
#' date_to_req_id(),
#' date_to_req_id() |> req_id_to_date() |> date_to_req_id()
#' )
date_to_req_id <- function(date = lubridate::today()) {
rlang::inherits_any(date, "Date")
withr::local_locale(c("LC_TIME" = "en_GB"))
format(date, "%Y.%m%b%d")
}
#' read excel override that allows the creation of a link
#'
#' @inheritParams readxl::read_excel
#' @return
#' @export
#'
#' @examples
read_excel <- function(path,
sheet = NULL,
.name_repair = "unique",
na = "",
skip = 0,
range = NULL,
col_names = TRUE) {
# Tracked in (tidyverse/readxl#729)
if (!fs::file_exists(path) && !file.exists(path)) {
excel_files <- fs::path_dir(".") |>
fs::dir_ls(type = "file", regexp = "xlsx", recurse = TRUE) |>
stringr::str_subset("\\~\\$", negate = TRUE) # Removing temp excel files.
rlang::arg_match0(path, excel_files)
}
if (is.numeric(sheet)) {
all_sheets <- readxl::excel_sheets(path = path)
if (sheet > length(all_sheets)) {
cli::cli_abort("Supply sheet as character or if numeric, name of sheet.")
}
sheet <- all_sheets[sheet]
cli::cli_inform(c(
'Write `sheet = "{sheet}"` for this sheet.'
))
} else if (!is.null(sheet)) {
all_sheets <- readxl::excel_sheets(path = path)
sheet <- rlang::arg_match(sheet, all_sheets)
}
excel_sheets_identity <- function(path) {
sheets <- readxl::excel_sheets(path)
cli::cli_inform("These sheets are available, {.val {sheets}}")
invisible(path)
}
if (interactive() && !getOption("rstudio.notebook.executing", FALSE)) {
line_1 <- '{.run [Edit or view](fs::file_show("{as.character(path)}"))} '
cli::cli_text(c(
line_1,
"the file in Excel. {.href [{as.character(fs::path_file(path))}](file://{path})}"
))
}
readxl::read_excel(
path = path,
sheet = sheet,
.name_repair = .name_repair,
na = na,
progress = FALSE,
range = range,
skip = skip,
col_names = col_names
)
}
# curl::ie_proxy_info()
intranet_connected <- function() !isFALSE(curl::curl_fetch_memory("gccode.ssc-spc.gc.ca") |> tryCatch(error = function(e) FALSE))
# canadr related work
if (rlang::is_installed("canadr")) on_intranet <- TRUE
if (!exists("on_intranet")) on_intranet <- intranet_connected()
if (on_intranet) {
## Local packages for general use {.file ~/rrr/instat-package-creation.R} ------
instat_update <- function(install = FALSE) {
if (install) {
devtools::install("~/Documents/rrr/canadr", upgrade = "never")
devtools::install("~/Documents/rrr/instat-r", upgrade = "never")
}
rstudioapi::jobAdd(
name = "Local Packages Creation",
autoRemove = FALSE,
show = FALSE
)
rstudioapi::jobRunScript(
path = "~/rrr/instat-package-creation.R",
name = "Local Packages Creation",
encoding = "UTF-8"
)
}
# no longer needed for people without build
install_gccode <- function(repo, auth_token = remotes:::gitlab_pat(quiet)) {
gccode <- "https://gccode.ssc-spc.gc.ca"
remotes::install_gitlab(repo = repo, auth_token = auth_token, host = gccode, quiet = TRUE, upgrade = "never")
cli::cli_alert_success("canadr was installed successfuly.")
cli::cli_abort("Now, Restart your R session.")
}
# pak local instat=local::~/Documents/rrr/instat-r # doesn't work...
# https://pak.r-lib.org/reference/pak_package_sources.html#package-names
rlang::check_installed(
"canadr (>= 0.4.4.9003)",
action = \(pkg, ...) install_gccode(glue::glue("service-research-division/{pkg}")),
reason = "To import shapefiles and read census data. (only available on VPN)"
)
is_in_instat_pkg_repo <- tryCatch(stringr::str_detect(active_proj, "instat-r"), error = function(e) FALSE)
if (!is_in_instat_pkg_repo) {
instat_install <- function(pkg, ...) {
instat_tar_gz <- list.files(
"//SFPHQOKLEASE1/DAVAULT/INSTAT-R-Packages/",
recursive = FALSE,
pattern = "instat.+tar",
full.names = TRUE
)
instat_tar_gz <- instat_tar_gz[length(instat_tar_gz)]
utils::install.packages(instat_tar_gz, repos = NULL, type = "source", quiet = TRUE)
cli::cli_alert_success("instat was correctly installed.")
cli::cli_abort("Restart your R session to avoid problems.")
}
rlang::check_installed("instat (>= 0.0.0.9003)", reason = "access INSTAT utilities-functions", action = instat_install)
gcdocs_save_copy <- instat::gcdocs_save_copy
gcdocs_links <- instat::gcdocs_links
use_report_template <- instat::use_report_template
}
rm(is_in_instat_pkg_repo, on_intranet)
if (rlang::is_installed("canadr")) {
convert_geo <- canadr::convert_geo
browse_census <- canadr::browse_census
}
# Report viewing ----------------------------------------
#' Create a website of reports as html
#' @param gcdocs_id A gcdocs ID.
#' @param title Title of the report
#' @param author
#' @param title_limit Should remove probably
#' @param description
#' @param tags
#' @param draft A draft post? Not really applicable
#' @param date
#' @param fr Is it in French?
#'
#' @source https://themockup.blog/posts/2022-11-08-use-r-to-generate-a-quarto-blogpost/
#' With slight modifications
new_gcdocs_post <- function(gcdocs_id, title, author = "Olivier", title_limit = 40,
description = "a desc", draft = FALSE, date = Sys.Date(), fr = FALSE, tags = NULL) {
available_tags <- c(
"remoteness",
"caf",
"band",
"nan",
"doc",
"temp"
)
if (!is.null(tags)) {
tags <- rlang::arg_match(tags, values = available_tags, multiple = TRUE)
tags <- paste0("[", paste(tags, collapse = ", "), "]")
}
rlang::check_required(gcdocs_id)
if (missing(title)) {
cli::cli_abort(
"Provide a human readable title of the docx report.",
"i" = "Run {.run instat::gcdocs_links({gcdocs_id})}."
)
}
usethis::local_project(
"~/Documents/rrr/report-view",
quiet = TRUE
)
instat::gcdocs_save_copy(id = gcdocs_id, destfile = "temp.docx", overwrite = FALSE, quiet = TRUE)
# convert to kebab case and remove non space or alphanumeric characters
title_kebab <- janitor::make_clean_names(title, sep_out = "-")
# warn if a very long slug
if (nchar(title_kebab) >= title_limit) {
cli::cli_warn("Title slug is longer than {.val {title_limit}} characters!")
}
# generate the slug as draft, prefix with _ which prevents
# quarto from rendering/recognizing the folder
if (draft) {
slug <- glue::glue("posts/_{title_kebab}")
cli::cli_alert_info("Appending a '_' to folder name to avoid render while a draft, remove '_' when finished.")
} else {
slug <- glue::glue("posts/{title_kebab}")
}
# create and alert about directory
if (!fs::dir_exists(slug)) {
fs::dir_create(
path = slug
)
}
cli::cli_alert_success("Folder created at {.file {slug}}")
# wrap description at 77 characters
description <- stringr::str_wrap(description, width = 77) |>
stringr::str_replace_all("[\n]", "\n ")
# start generating file
new_post_file <- glue::glue("{slug}/index.qmd")
pandoc::pandoc_convert(
file = "temp.docx",
from = "docx",
to = "markdown",
args = glue::glue("--extract-media=."),
output = new_post_file
)
if (fs::dir_exists("media")) {
image_files <- fs::dir_ls("media")
fs::dir_create(slug, "media")
fs::file_move(fs::dir_ls("media"), fs::path(slug, "media"))
fs::dir_delete("media")
}
lines <- readLines(new_post_file, encoding = "UTF-8")
lines <- strip_unnecessary_lines(lines)
# build yaml core
new_post_core <- c(
"---",
glue::glue('title: "{title}"'),
"description: |",
glue::glue(" {description}"),
glue::glue("author: {author}"),
glue::glue("date: {date}"),
glue::glue("last-modified: {date}"),
if (fr) glue::glue("lang: fr"),
if (!is.null(tags)) glue::glue("categories: {tags}")
)
# add draft if draft
if (draft) {
new_post_text <- c(
new_post_core,
"draft: true",
"---\n"
)
} else {
new_post_text <- c(
new_post_core,
"---\n"
)
}
# finalize new post text
new_post_text <- paste0(
c(
new_post_text,
"",
glue::glue("**This is a copy of [{gcdocs_id}](https://gcdocs.intra.pri/aanc-inac/llisapi.dll/app/nodes/{gcdocs_id})**"),
"",
"",
"<!--- Do not edit by hand, see the procedure (will probably do when the need arises) --->",
lines
),
collapse = "\n"
)
writeLines(
text = new_post_text,
con = new_post_file
)
unlink("temp.docx")
cli::cli_alert_success("Created {.file {new_post_file}}.")
cli::cli_alert_success("You can render with {.run quarto::quarto_render('~/rrr/report-view', as_job = TRUE)}")
cli::cli_inform("After everything works use {.run servr::httw('~/rrr/report-view/_site')}")
invisible(new_post_text)
}
#' Removes the Table of contents list from top
#'
strip_unnecessary_lines <- function(lines) {
# TODO later figure out how to strip See {.file ~/rrr/instat-r/data-raw/publication-guidelines.R}
first_line_to_strip <- stringr::str_which(lines, "Table of [Cc]ontents|Table des [Mm]ati.res")[1]
last_line_to_strip <- stringr::str_which(lines, ".unnumbered|^\\# Acknowledgements|^\\# User Information|^\\# Introduction|^\\# Remerciements")[1]
if (length(first_line_to_strip) == 1 && is.na(first_line_to_strip)) {
"No TOC"
} else if (length(first_line_to_strip) != 1 && length(last_line_to_strip) != 1) {
cli::cli_warn(c(
"could not detect the regexp to strip the table of contents.",
"Edit R profile. {.file ~/actual-r-profile.R:935}"
))
} else {
tryCatch(
range <- seq(first_line_to_strip, last_line_to_strip - 1L),
error = function(e) {
cli::cli_warn(c(
"Could not strip the TOC",
"TOC begin = {first_line_to_strip}, TOC end = {last_line_to_strip}"
))
range <- integer(0)
return(lines)
}
)
if (length(range)) lines <- lines[-range]
}
lines
}
# Requests Helpers ----------------------------------------------
#' Create a ad-hoc request
#' See the blog post
#' Use `favourite()` to add link to the current request
#'
use_request <- function(new = FALSE, which = NULL) {
if (!new) {
if (is.null(which)) {
last_req <- reuseme::max_named(x = req_id_to_date())
cli::cli_inform(c(
"The last request was {.href [{fs::path_file(names(last_req))}](file://{names(last_req)})}",
i = "Use {.code new = TRUE} to create a new request"
))
which <- last_req
}
return(invisible(req_checklist(which)))
}
additional_bullets <- NULL
active_req_folder <- date_to_req_id()
requests_dir <- fs::path_home("Documents", "Requests")
active_req_path <- fs::path(requests_dir, active_req_folder)
in_requests_rproj <- tryCatch(identical(proj_get(), fs::path_home("Documents", "rrr", "requests")), error = function(e) FALSE)
if (!in_requests_rproj) {
additional_bullets <- c(additional_bullets, i = "Open {.run [requests.Rproj](reuseme::proj_switch('requests'))} in RStudio.")
}
lines_to_write_to_r_file <- c(
"# Requests/{date_to_req_id()} -------------" |> cli::format_inline(),
'req_checklist(req_id = "{date_to_req_id()}")' |> cli::format_inline(),
# Quick description
"fs::dir_tree(",
' "~/Documents/Requests/{date_to_req_id()}",' |> cli::format_inline(),
" recurse = TRUE,",
" invert = TRUE,",
' regexp = "~\\\\$|lnk"',
")",
""
)
cli::cli_inform(c(
"i" = "Write the following lines to an R script", " " =
"{.emph [Copied to clipboard]}"
))
cli::cli_code(lines_to_write_to_r_file)
clipr::write_clip(lines_to_write_to_r_file)
cli::cli_bullets(c(
"Save the initial email attachments",
i = "Creating a new request at {date_to_req_id()}",
"Save the instructions you received to the folder.",
i = "Open {.run [Requests.xlsx](fs::file_show('{as.character(fs::path(requests_dir, \"Requests.xlsx\"))}'))}",
"If the request is similar to a previous one, use {.help [fs::file_copy(old, new)](fs::file_show())}",
"fs::file_copy, gert::git_add, gert::git_commit('Initial commit on Request')",
i = "Edit the first line of a syntax",
i = "Search for reference to the old request in the file to replace it with the new",
additional_bullets
))
if (!fs::dir_exists(active_req_path)) {
fs::dir_create(active_req_path)
cli::cli_ul("Creating the path {active_req_path}")
}
if (!fs::file_exists(fs::path(active_req_path, "requests-r.lnk"))) {
fs::file_copy(fs::path(requests_dir, "requests-r.lnk"), fs::path(active_req_path, "requests-r.lnk"))
cli::cli_ul("Adding requests-r.lnk to help toggle between the Rproj and the Requests directory.")
}
# TODO Add instructions on how to manage R files.
# TODO I figured out JanMarvin/openxlsx2#942 hyperlinks, add request link in my requests file.
}
req_checklist <- function(req_id) {
rlang::check_required(req_id)
cli::cli_inform(c(
"Use {.fn favourite}",
"Browse {.run [Browse Dir](fs::dir_tree('~/Documents/Requests/{req_id}', recurse = TRUE, invert = TRUE, regexp = '~\\\\$|lnk'))}",
"Open {.run [Requests.xlsx](fs::file_show('~/Documents/Requests/Requests.xlsx'))}",
"Make sure you add the path to Script in Comments metadata, if Excel, with `wb$set_properties()`, manually with docx."
))
cli::cli_warn("Add more to checklist.")
}
data_collection <- function() {
# To do later
# instat r package
# ri_band_class
# csd
# ri_csd_imputed
# band_ir
# Davault
# Karen's working files
# Add to useful links
c(
"band_ri_2021" = "//ncfpina0189/(SR)Branch/Research Analysis/Research Team/Walter-Remoteness work/Remoteness Index/Data/First_Nations_2021RI.xlsx",
)
instat::davault("IR")
}
add_tracker_link <- function(req_id = NULL, url) {
# may read the address or link from clipbaord
cli::cli_abort("Not ready")
clipr::read_clip()
# tracker_base_url <- ...
}
#' Show files associated to a request
#'
#' @param req the active R file that contains the special comment on top `# `req_id` -------`
#'
#' @return
#' @export
#'
#' @examples
req_show <- function(req = NULL) {
if (is.null(req)) {
req <- active_rs_doc()
req_id <- readLines(req, n = 1) |>
stringr::str_extract("\\d{4}.{8}")
} else {
cli::cli_abort("Another way to specify the request is not yet implemented.")
}
req_id_to_date(req_id) # assess req_id i.e. check_req_id()
path_req <- fs::path_home("Documents", "Requests", req_id)
files_req <- fs::dir_ls(path_req) |>
purrr::set_names(fs::path_file)
links_to_files <- dplyr::case_when(
stringr::str_detect(files_req, "\\(|\\)") ~ paste0("{.file ", names(files_req), "}"),
.default = paste0("{.run [", names(files_req), "](fs::file_show('", files_req, "'))}")
)
cli::cli_h3("{path_req}, {req_id}")
cli::cli_inform(
c(
i = "Click to open them",
links_to_files
)
)
req_id
}
req_id_to_date <- function(folder = fs::dir_ls("~/Documents/Requests", type = "dir")) {
is_dir <- inherits(folder, "fs_path")
if (inherits(folder, "fs_path")) {
original <- folder
if (all(fs::is_dir(folder))) {
folder <- fs::path_file(folder)
} else {
folder <- fs::path_dir(folder) |> fs::path_file()
}
}
res <- stringr::str_remove_all(folder, paste0(month.abb, collapse = "|")) |>
stringr::str_remove("\\.") |>
lubridate::ymd()
if (is_dir) {
names(res) <- fs::path(original)
}
res
}
if (FALSE) {
fs::dir_ls("~/Documents/Requests", type = "dir") |>
req_parse_dir() |>
req_id_fmt()
}
}
quarto_version <- quarto::quarto_version
use_r <- usethis::use_r
cli_text <- cli::cli_text
to_title <- function(names) {
# Could also use janitor::make_clean_names(case = "title")
janitor::make_clean_names(names, "title", abbreviations = c("CAF", "RI", "CD", "CSD", "RQAF", "CFS", "FN"))
}
growth <- function(initial, final) {
res <- final / initial - 1
replace(res, final == 0 & initial == 0, 0)
}
# from rlang and base
if (getRversion() < "4.4.0") {
`%||%` <- function(x, y) {
if (is.null(x)) {
y
} else {
x
}
}
}
# from naniar
all_na <- function(x) {
# Distinguish NaN from NA.
# if there are no missings, then there cannot be all missings
if (!anyNA(x) || all(is.nan(x))) {
return(FALSE)
}
all(is.na(x))
}
is_text_col <- function(x) {
if ((all(is.na(x))) || !is.character(x)) {
return(FALSE)
}
max(nchar(x), na.rm = TRUE) >= 50 & (var(nchar(x), na.rm = TRUE) > 10)
# maybe add something about the variance var(nchar(.))>0, mais ce serait trop de calculs
}
}
# Workflow helpers ------------------------------------------------------------
# Recent files
# Duplication https://jmbarbone.github.io/mark/reference/get_recent_dir.html
access_recent_files <- function(n_max = 10, excel = FALSE) {
# Specify the directory containing the .lnk files
# WINDOWS <- .Platform$OS.type == "windows"
# R.utils + symlink local option?
# https://github.com/HenrikBengtsson/R.utils/issues/152
# withr::local_envvar(list(R_R_UTILS_SYS_READLINKS2_WINDOWS = "TRUE"))
if (.Platform$OS.type != "windows") {
cli::cli_abort("This function works only on Windows.")
}
user_name <- Sys.getenv("username")
lnk_directory <- glue::glue("C:/Users/{user_name}/AppData/Roaming/Microsoft/Windows/Recent")
# Get a list of .lnk files in the directory
lnk_files <- fs::dir_info(lnk_directory, pattern = "\\.lnk$") |>
dplyr::arrange(desc(modification_time)) |>
dplyr::pull(path) |>
fs::path_norm() |>
stringr::str_subset("softwarecenter|\\(\\d+\\)|ms\\-|dll|This PC|zip|Rproj|\\.R|\\.qmd|\\.rdb|\\.csv|template|README|css|\\.ya?ml", negate = TRUE) |>
purrr::set_names(fs::path_ext_remove)
lnk_files <- lnk_files[fs::path_ext(names(lnk_files)) != ""] |>
unname()
if (excel) {
lnk_files <- stringr::str_subset(lnk_files, "xls")
}
# instat::intranet_connected()
intranet_connected <- intranet_connected()
if (!intranet_connected) {
lnk_files <- stringr::str_subset(lnk_files, pattern = "OpenText|davault|SFPHQOKLEASE1|[:upper:]\\:/", negate = TRUE)
}
links_to_files_raw <- lnk_files |>
# purrr::map(R.utils::)
# iconv(to = "UTF-8") |>
purrr::map(purrr::possibly(R.utils::readWindowsShellLink))
if (intranet_connected) {
links_to_files_raw <- links_to_files_raw |>
purrr::map(\(x) {
x$pathname <- c(x$pathname, x$networkPathname)
x
})
}
links_to_files_raw <- links_to_files_raw |>
purrr::map("pathname") |>
purrr::map(purrr::possibly(\(x) fs::path_real(x))) |>
purrr::compact() |>
purrr::list_c()
# Maybe show only outside wdirectory. Add alert for GCdocs
links_to_files_raw <- links_to_files_raw[seq_len(min(n_max, length(links_to_files_raw)))] |> purrr::set_names(fs::path_file)
links_to_files <- dplyr::case_when(
stringr::str_detect(links_to_files_raw, "\\(|\\)") ~ paste0("{.file ", names(links_to_files_raw), "}"),
.default = paste0("{.run [", names(links_to_files_raw), "](fs::file_show('", links_to_files_raw, "'))}")
)
cli::cli_h1("Most recent files (n = {min(n_max, length(links_to_files))})")
cli::cli_bullets(
c(
i = "Click to open them Set {.arg n_max} to see more.",
links_to_files
)
)
on_network <- stringr::str_detect(links_to_files_raw, "^//")
if (any(on_network)) {
cli::cli_h2("Network files")
print(fs::path_real(links_to_files_raw[on_network]))
}
invisible(links_to_files)
}
# Pour googler des affaires.
google <- function(query) {
query <- stringr::str_replace_all(query, " ", "+")
utils::browseURL(glue::glue("https://www.google.ca/search?q={query}"))
}
browse_gh <- function(user = NULL) {
preferred <- c(
"hadley",
"lionel-",
"gaborcsardi",
"jennybc",
"DavisVaughan",
"cderv",
"yihui"
)
user <- user %||% sample(preferred, 1)
link <- glue::glue("https://github.com/issues?q=involves%3A{user}+sort%3Aupdated-desc")
cli::cli_text("{.href [{user}]({link})}")
bullets <- c(
"{.href [quarto](https://github.com/quarto-dev/quarto-cli/tree/main/news)}",
"{.href [R](https://cran.r-project.org/doc/manuals/r-devel/NEWS.html)}",
"{.href [RStudio](https://github.com/rstudio/rstudio/blob/main/NEWS.md)}",
"{.href [RStudio old](https://github.com/rstudio/rstudio/tree/main/version/news)}"
)
cli::cli_bullets(bullets)
}
# Quarto cross-references ----------------------------------------------------
#' Jump to a cross reference
#' issue rstudio/rstudioapi#283
#' @param ref A reference
#' @param path don't use (only for initial testing) after that I will just use
#'
#' @return
#' @export
#'
#' @examples
jump_to_cross_ref <- function(ref, path = NULL) {
rlang:::check_arg(ref)
# when done uncomment this line
file_content <- rstudioapi::getSourceEditorContext()$contents
line_regex <- stringr::str_which(file_content, ref)
rstudioapi::documentOpen(
# id = rstudioapi::getSourceEditorContext()$id,
path = NULL,
line = line_regex[1] # just using the first match for simplicity
)
}
list_cross_refs <- function(query = NULL) {
}
#' Like x[select], but pipeable.
#'
#' @param x A vector
#' @param select Indices
#'
#' @return subset of x
#' @export
#'
#' @examples
select_ref <- function(x, select) {
x[select]
}
# Almost work, just need to find a way to move focus with setCursorPosition
navigate_to_unsaved_file <- function(regex, path = NULL) {
if (is.null(path)) {
file <- rstudioapi::getSourceEditorContext()
file_content <- file$content
doc_id <- file$id
} else {
file <- path
file_content <- readLines(file, encoding = "UTF-8", warn = FALSE)
doc_id <- rstudioapi::documentOpen(file, moveCursor = FALSE)
}
line_regex <- stringr::str_which(file_content, regex)
reg_pos <- rstudioapi::document_position(line_regex[1], 1)
rstudioapi::setCursorPosition(position = reg_pos, id = doc_id)
rstudioapi::selectionSet(id = doc_id, value = " ")
}
view_temps <- function(outline = FALSE) {
temp_files <- fs::dir_ls("~/Downloads", regexp = "\\.R(md)?|\\.qmd|\\.css")
if (outline) {
reuseme::file_outline(path = temp_files, TRUE)
} else {
cli::cli_bullets(paste0("{.file ", temp_files, "}"))
}
}
link_doc <- function(x) {
if (!any(stringr::str_detect(x, "\\d{8}"))) {
return(x)
}
li <- stringr::str_split(x, pattern = "\\s")
res <- purrr::map(li, function(x) {
purrr::map_chr(x, function(y) {
if (stringr::str_detect(y, "\\d{8,}")) {
doc_id <- stringr::str_extract(y, "\\d{8,}")
y <- stringr::str_remove_all(y, "\"")
y <- stringr::str_replace_all(y, doc_id, paste0(" {.run [#", doc_id, "](instat::gcdocs_links(", doc_id, "))}"))
}
y
})
})
purrr::map_chr(res, \(x) paste(x, collapse = " "))
}
#' @examples
#' go_to_file_line("this is alline")
go_to_file_line <- function(line = clipr::read_clip(), proj = usethis::proj_get()) {
rlang:::check_string(line)
files <- fs::dir_ls(
path = proj,
regexp = "\\.R$|qmd|Rmd|*.Rd|Rmarkdown",
recurse = TRUE,
invert = FALSE
) |>
fs::path_filter(
"_files|testthat.R|xlsx|\\~\\$|\\.RDS|.rds",
invert = TRUE
)
files <- stringr::str_remove(files, paste0(proj, "/?"))
# browser()
file_content <- purrr::set_names(files)
# Assuming inside project
file_content <- purrr::map(file_content, function(x) readLines(x, encoding = "UTF-8"))
# Combine everything into a tibble that contains file, line_id, content
file_content <- purrr::map(file_content, function(x) tibble::enframe(x, name = "line_id", value = "content"))
file_content <- dplyr::bind_rows(file_content, .id = "file")
file_content <- dplyr::filter(file_content, content == line)
if (nrow(file_content) != 1) {
if (nrow(file_content) > 1) {
thing <- paste0(file_content$file, ":", file_content$line_id)
print(file_content |> dplyr::select(-content))
cli::cli_abort(c(
"Expected a single match, but found {nrow(file_content)} match{?es} of {.val {line}}",
"i" = "Navigate to a location {.file {thing}}"
))
} else {
cli::cli_abort(
"No match found, try another line, or maybe simply {.run [Find in Files](rstudioapi::executeCommand('activateFindInFiles'))}"
)
}
}
reuseme::open_rs_doc(
file_content$file,
line = file_content$line_id
)
}
# TODO Should `file_outline()` use {.fn rstudioapi::sourceMarkers} See rstudio/rstudio#14297
im_bored <- function() {
# Will show items that you may have to do
reuseme::proj_outline(work_only = TRUE)
}
# Use this function to start with the active doc and make a copy of it
# in the same directory.
active_document_copy <- function(new_name = NULL) {
old <- reuseme::active_rs_doc()
if (is.null(old)) {
cli::cli_abort("Unsaved document, focus on the saved doc you want to save")
}
if (!fs::path_ext(old) %in% c("R", "qmd", "Rmd")) {
cli::cli_abort("Only R docs for now")
}
old_path_file <- fs::path_file(old) |> fs::path_ext_remove()
if (is.null(new_name)) {
new_name <- paste0(old_path_file, "-new")
} else {
new_name <- stringr::str_remove(new_name, "\\.R|\\.qmd|\\.Rmd$")
}
new_path <- stringr::str_replace(old, old_path_file, new_name)
file.copy(old, new_path, overwrite = FALSE)
cli::cli_inform(c(
v = "Copied {.file {old}}",
i = "Edit {.file {new_path}}"
))
}
}
# Package Contribution exploration index -------------------------------------------------
#' Opens the .R file associated with a function on GitHub
#'
#' it process the aliases!
#' View() is cool, but it doesn't allow to see the roxygen comments, how the documentation is inherited etc.
#' It can also be useful to make quick pull requests.
#' This function basically automates the following workflow for an installed package.
#' 1. reuseme::browse_pkg("pkg")
#' 2. Open the reference tab of the pkgdown website
#' 3. click on the link at source to view the source file on GH
#'
#' @details
#' The function uses rvest to query the link as I didn't find a way to find `%` comment in the `.Rd` file
#' % Generated by roxygen2: do not edit by hand
#' % Please edit documentation in R/deprec-tibble.R
#'
#' @param func A character, either pkg::fun
#' @param pkg Optional is the package is provided in `func`. For better results, `pkg` must be installed!
#'
#' @returns Opens the GitHub source file
#' @export
#' @rdname browse_help
#' @examples
#' browse_gh_fn_source("fs::file_show")
browse_gh_fn_source <- function(func, pkg = NULL) {
# hacky, but could find it in the Rd file comments
# would work if the pkg is not installed.
fn_url <- browse_help(func = func, pkg = pkg, open = FALSE)
gh_source <- rvest::read_html(fn_url) |>
rvest::html_elements(".page-header") |>
rvest::html_element(".dont-index") |>
rvest::html_element("a") |>
rvest::html_attr(name = "href")
if (rlang::is_interactive()) {
utils::browseURL(gh_source)
}
}
#' @returns The function URL on the pkgdown site.
#' @export
browse_help <- function(func, pkg = NULL, open = TRUE) {
if (is.function(func)) {
# browser()
fn_name <- as.character(substitute(func))
if (!rlang::has_length(fn_name, 3)) {
cli::cli_abort("Must supply package name")
}
func <- fn_name[3]
pkg <- fn_name[2]
} else if (stringr::str_detect(func, "\\:\\:")) {
pkg <- stringr::str_extract(func, "(.+)\\:\\:", group = 1)
func <- stringr::str_extract(func, "\\:\\:(.+)", group = 1)
} else if (is.null(pkg)) {
cli::cli_abort("Not yet implemented use func = pkg::func, or specify the `pkg` argument.")
guess_pkg(func)
}
if (!rlang::is_installed(pkg)) {
cli::cli_warn(c(
"The package {.pkg {pkg}} is not installed.",
i = "Install it or use {.run reuseme::browse_pkg('{pkg}')} to go to its pkgdown website."
))
return(pkg)
}
alias_fn <-
readRDS(
system.file("help", "aliases.rds", package = pkg, mustWork = TRUE)
)
# downlit::href_topic("render", "rmarkdown", is_fun = T) could simplify this :)
rd <- alias_fn[func]
rd
pkgdown_ref <- reuseme::browse_pkg(pkg, open = FALSE, ref_only = TRUE)
fn_url <- glue::glue("{pkgdown_ref}/{rd}.html")
if (open) {
utils::browseURL(fn_url)
}
invisible(fn_url)
}
# doesn't work
pkg_process_pkgdown_grouping <- function(pkg, n_max = 10) {
# possibly using pkgdown data
index <- pkg_extract_fns_from_rd(pkg, print_gt = FALSE)
fn_index <- browse_pkgdown_config(pkg)
index_prep <- index |>
dplyr::bind_rows() |>
tidyr::fill(title) |>
dplyr::filter(!is.na(contents)) |>
dplyr::mutate(
is_special = stringr::str_detect(contents, "$matches|starts_with|ends_with|contains") & str_detect(contents, "\"|\'"),
pattern = stringr::str_extract(contents, "\"(.+)\"", group = 1),
special_pattern = dplyr::case_when(
!is_special ~ NA_character_,
stringr::str_detect(contents, "starts_with\\(") ~ paste0("^", pattern),
stringr::str_detect(contents, "ends_with\\(") ~ paste0(pattern, "$"),
stringr::str_detect(contents, "matches\\(") ~ pattern
)
)
}
#' Query the `pkgdown` reference index of a package!
#'
#' It prints the yaml to the console.
#'
#' cat([yaml::as.yaml()]) can be a good option to print a list!
#'
#' @param pkg a package
#' @param verbose If `TRUE`, will show the yaml output in the console. (Using [yaml::as.yaml()])
#' @return A list created by [yaml::read_yaml()] (invisibly)
#' @export
browse_pkgdown_config <- function(pkg, verbose = TRUE) {
withr::local_options(rlang_interactive = FALSE)
gh_link <- usethis::browse_github(pkg)
pkgdown_url <- stringr::str_extract(gh_link, ".com/(.+)", group = 1)
# browser()
possible_urls <- paste0(
"https://raw.githubusercontent.com/", pkgdown_url, "/", c("main", "master", "HEAD"), "/",
rep(c("", "pkgdown/"), each = 3), rep(c("_pkgdown.yml", "_pkgdown.yaml"), each = 6)
)
i <- 0
pkgdown_yaml <- NULL
has_pkgdown <- reuseme::browse_pkg(package = pkg, open = FALSE, vignettes_show = FALSE) |>
suppressMessages()
if (is.null(has_pkgdown)) {
cli::cli_warn("No pkgdown found in DESCRIPTION.")
}
while (is.null(pkgdown_yaml)) {
i <- i + 1
try(pkgdown_yaml <- suppressWarnings(yaml::read_yaml(possible_urls[i])), silent = TRUE)
if (i == 12 && is.null(pkgdown_yaml)) {
cli::cli_abort(c("The package {.pkg {pkg}} doesn't have a pkgdown index file.!", "It has the following link {has_pkgdown}"))
}
}
if (verbose) {
cat(yaml::as.yaml(pkgdown_yaml$reference))
cli::cli_bullets("{.url {possible_urls[i]}}")
}
if (is.null(pkgdown_yaml$reference)) {
cli::cli_inform("the pkgdown site uses the default ordering! browse it at {possible_urls[i]}")
cat(yaml::as.yaml(pkgdown_yaml))
}
invisible(pkgdown_yaml$reference)
}
pkg_extract_fns_from_rd <- function(pkg, print_gt = TRUE) {
if (!rlang::is_installed(pkg)) {
cli::cli_warn("The package {.pkg {pkg}} is not installed. Install it or use `reuseme::browse_pkg('{pkg}')` to go to its pkgdown website")
return(pkg)
}
# If the grouping exists i.e. if yaml::read_yaml("https://raw.githubusercontent.com/r-lib/fs/main/_pkgdown.yml")$reference is not NULL
# this function is useless
alias_fn <- system.file("help", "aliases.rds", package = pkg, mustWork = TRUE) |>
readRDS() |>
tibble::enframe(name = "fn", value = "rd_name")
tab_index <- readLines(system.file("INDEX", package = pkg)) |>
tibble::enframe() |>
tidyr::separate_wider_delim(cols = value, delim = stringr::regex("\\s{3,}"), names = c("rd_name", "desc"), too_few = "align_start") |>
dplyr::mutate(rd_name = dplyr::na_if(rd_name, "")) |>
tidyr::fill(rd_name) |>
dplyr::summarise(
desc = paste(desc, collapse = " "),
.by = rd_name
) |>
dplyr::full_join(alias_fn, by = "rd_name") |>
dplyr::mutate(rd_name_is_fn = rd_name == fn) |>
# dplyr::filter(rd_name != fn) |> # worked with dplyr and fs... I will have to figure out what's different about those
dplyr::relocate(fn)
if (print_gt) {
tab_index |>
dplyr::mutate(rd_name = paste0(rd_name, ".Rd")) |>
dplyr::select(-rd_name_is_fn) |>
gt::gt(groupname_col = c("desc", "rd_name")) |>
gt::tab_options(row_group.font.weight = "bold") |>
print()
}
invisible(tab_index)
}
## Tibble printing override -------------------------------------------------
compare_cols <- function(data, strict = TRUE) {
# I'd only want to run get_one_to_one on columns that are not equal
# Ideally, we'd be strict for TRUE, FALSE, O, or NA, as those are very common values.
# In the future, when printing tibbles,
# The message will be
# i fly_in_2016 = fly_in_2021, pr_2016 = pr_2021, band_name_2016 = band_name_2021
# Will only work if the names are snake_case
# Test if two columns are the same
# Will not test columns of different classes.
if (nrow(data) > 10000 || nrow(data) == 0) {
# cli::cli_inform("Will not perform the comparisons for performance ")
return(character(0))
}
grouping_var <- ifelse(strict, list(c("prefix", "value")), list("value"))
grouping_var <- unlist(grouping_var)
# browser()
combinations <- purrr::map_chr(data, \(x)class(x)[1]) |>
tibble::enframe() |>
dplyr::mutate(
id = dplyr::row_number(),
prefix = stringr::str_extract(name, ifelse(strict, "[^_]+", ".+"))
) |>
dplyr::filter(dplyr::n() > 1, .by = tidyselect::all_of(grouping_var))
if (nrow(combinations) == 0) {
return(character(0))
}
combinations_list <- combinations |>
dplyr::summarise(
comb = list(combn(name, m = 2, simplify = FALSE)),
.by = tidyselect::all_of(grouping_var)
) |>
dplyr::pull() |>
purrr::list_flatten()
purrr::map_chr(combinations_list, \(x) ifelse(identical(data[[x[1]]], data[[x[2]]]), paste0(x[1], " = ", x[2]), NA)) |>
na.omit() |>
as.character()
}
#' show column types (readr style)
#'
#' If the other API is sketchy and touches internals
#' @param data
#' @param width could also be `getOption("width")`
#'
#' @return A list of the header of the list, with the concerned columns that follow.
#' @export
#'
#' @examples
show_column_types <- function(data, with_back_ticks, width = Inf) {
if (ncol(data) != length(with_back_ticks)) {
stop("Internal errors due to back ticks")
}
if (nrow(data) > 50) {
is_potential_factor <- \(col) (is.character(col) | (is.numeric(col))) & dplyr::n_distinct(col, na.rm = TRUE) < 10
data <- data |>
dplyr::mutate(
dplyr::across(dplyr::where(is_potential_factor), as.factor)
)
}
type_map <- dplyr::case_match(
vapply(data, function(x) class(x)[[1]], character(1)),
"character" ~ "chr",
"pillar_char" ~ "chr",
"double" ~ "dbl",
"numeric" ~ "dbl",
"integer" ~ "int",
"number" ~ "num",
"logical" ~ "lgl",
"factor" ~ "fct",
"ordered" ~ "fct",
"list" ~ "list",
"POSIXct" ~ "dttm",
"datetime" ~ "dttm",
"Date" ~ "date",
"date" ~ "date",
"time" ~ "time",
"guess" ~ "???"
) |>
purrr::set_names(names(data))
names(type_map)[with_back_ticks] <- paste0("`", names(type_map)[with_back_ticks], "`")
# col_types <- droplevels(factor(type_map[col_types], levels = unname(type_map)))
type_counts <- table(type_map)
color_type <- function(type) {
switch(type,
chr = ,
fct = cli::col_red(type),
lgl = cli::col_yellow(type),
dbl = ,
int = ,
num = cli::col_green(type),
date = ,
dttm = ,
time = cli::col_blue(type),
list = cli::col_cyan(type),
"???" = type
)
}
types <- format(vapply(names(type_counts), color_type, character(1)))
# counts <- format(glue::glue("({type_counts})"), justify = "right")
# col_width <- min(width - (cli::ansi_nchar(types) + nchar(counts) + 4))
# Showing a max of 15 columns (can change later)
columns <- purrr::map(split(names(type_map), type_map), .f = sort) |>
purrr::set_names(paste0(types, " (", type_counts, "):")) |>
purrr::map(\(x) paste0(x, ",")) |>
purrr::map(\(x) {
# removing the comma from the last element.
last <- x[length(x)]
x[length(x)] <- stringr::str_remove(last, ",")
x
})
# browser()
purrr::imap(columns, \(x, name) c(name, pillar::style_subtle(x))) |>
unname() |>
unlist() |>
stringr::str_squish() # as I don't know how to remove the extra space.
}
tbl_format_footer.tbl_df <- function(x, setup, ...) {
footer <- pillar:::format_footer(x, setup)
# browser()
# print("W")
if (any(unlist(footer) |> stringr::str_detect("\\<.+\\>"))) {
# Just change the known variable types, it would have to be changed here
# https://github.com
# in color_type above too and in type_map, maybe review all these methods.
extra_cols_names <- unlist(footer) |>
stringr::str_subset("\\<.+\\>") |>
stringr::str_extract("\\\033\\[1m(.+)\\\033\\[22m", group = 1)
footer <- purrr::map(footer, \(x) stringr::str_subset(x, "<.+>", negate = TRUE))
has_back_ticks <- stringr::str_detect(extra_cols_names, "`")
extra_cols <- show_column_types(x[stringr::str_remove_all(extra_cols_names, "^`|`$")], with_back_ticks = has_back_ticks)
# footer <- c(footer, list(extra_cols))
footer[[length(footer)]] <- c(footer[[length(footer)]], extra_cols)
}
footer_comment <- pillar:::wrap_footer_bullet(footer, setup)
footer_advice <- pillar:::format_footer_advice(x, setup)
footer_advice_comment <- pillar:::wrap_footer_bullet(
footer_advice,
setup,
lines = 1,
ellipsis = FALSE,
bullet = cli::symbol$info
)
pillar::style_subtle(c(footer_comment, footer_advice_comment))
}
tbl_format_footer.tbl <- tbl_format_footer.tbl_df
# Custom printing of POSIXct (ymdhms)
# https://github.com/tidyverse/googledrive/commit/d71785e008c6cd0af9c4f590ad91909f022ec084
pillar_shaft.POSIXct <- function(x, ...) {
width <- 17L
date <- format(x, format = "%Y-%m-%d")
time <- format(x, format = "%H:%M")
# time_second <- format(x, format = "%H:%M:%OS")
datetime <- paste0(date, " ", pillar::style_subtle(time))
datetime[is.na(x)] <- NA
pillar::new_pillar_shaft_simple(datetime, width = width, align = "left")
}
#' returns bullets of an example one to one mapping
#'
#' @param dat A data frame, tibble
#' @param ignoreNA Will not show one to one mapping that include `NA` if `TRUE` (default)
#'
#' @return A formatted bullet list otherwise of an example of a mapping one to one. `NULL` if no match is found, and
#' @export
#'
#' @examples
#' bulls <- f_one_to_one(starwars[1:4,])
#' cli::cli_bullets(bulls)
f_one_to_one <- function(dat, ignoreNA = TRUE) {
if (nrow(dat) < 3 || nrow(dat) > 1e6) {
return(NULL)
}
if (inherits(dat, "sf")) dat <- sf::st_drop_geometry(dat)
# fs issues temp until I find something better.
problematic_vars <- c("inode", "permissions")
dat <- dplyr::select(dat, -dplyr::where(is.list), -dplyr::where(lubridate::is.POSIXct), -any_of(problematic_vars)) |> dplyr::ungroup()
if (ncol(dat) < 3) {
return(NULL)
}
one_to_one_list <- suppressMessages(janitor::get_one_to_one(dat))
if (rlang::has_length(one_to_one_list, 0)) {
return(NULL)
}
dat <- dplyr::mutate(dat, dplyr::across(
dplyr::where(is.numeric) & dplyr::any_of(purrr::list_c(one_to_one_list)),
\(x) round(x, 4) # possibly creating mistake here, trying 4 instead of 3
))
bullets <- purrr::map_chr(one_to_one_list, \(var_name) {
# error adding a 1 is in here
var_name <- unlist(var_name)
example_mapping_one_to_one <- dat |>
dplyr::add_count(.data[[var_name[1]]], name = "n_count_one_to_one") |>
dplyr::filter(n_count_one_to_one > 1) # Maybe useful when trying to do NA analysis!
if (ignoreNA) {
example_mapping_one_to_one <- example_mapping_one_to_one |> tidyr::drop_na(all_of(var_name[1]))
}
if (nrow(example_mapping_one_to_one) == 0) {
return(NA)
}
if (rlang::is_installed("canadr")) {
max_4_n <- suppressWarnings(canadr::max_n(unique(example_mapping_one_to_one$n_count_one_to_one), n = 4L))
} else {
rlang::check_installed("kit")
max_4_n <- suppressWarnings(kit::topn(unique(example_mapping_one_to_one$n_count_one_to_one), n = 4L, index = FALSE))
}
example_mapping_one_to_one_chr <- example_mapping_one_to_one |>
dplyr::filter(n_count_one_to_one %in% max_4_n) |>
dplyr::mutate(id = vctrs::vec_group_id(.data[[var_name[1]]])) |>
# reuseme::slice_sample_group() |>
dplyr::filter(id == sample(id, size = 1)) |>
dplyr::distinct(dplyr::across(dplyr::all_of(var_name), as.character)) |>
as.list()
if (any(lengths(example_mapping_one_to_one_chr) > 1)) {
cli::cli_warn("Possibly an error with `janitor::get_one_to_one()`")
example_mapping_one_to_one_chr <- purrr::map(example_mapping_one_to_one_chr, 1)
}
example_mapping_one_to_one_chr <- example_mapping_one_to_one_chr |>
unlist()
res <- example_mapping_one_to_one_chr
if (length(res) == 2) {
res_cli <- cli::ansi_collapse(paste0(pillar::style_bold(names(res)), " = ", res), last = ", ")
} else {
res_cli <- cli::ansi_collapse(paste0(pillar::style_bold(names(res)), " = ", res))
}
pillar::style_subtle(paste("# ", " For", res_cli))
}) |>
purrr::discard(is.na)
if (rlang::has_length(bullets, 0)) {
return(NULL)
}
c(pillar::style_subtle(glue::glue("# {cli::symbol$info} One to one matchings:")), bullets)
}
show_end <- function(chr) {
if (is.factor(chr)) {
chr <- as.character(chr)
}
pillar::char(chr, shorten = "front")
}
#' custom print method for tibbles
#'
#' It detects if a column is all NAs
#' if all rows in a column have a unique value
#' If it has duplicate columns
#' 1. Check for all NA columns, won't care about those (not printing)
#' 2. find columns with unique value, won't do comparisons with those either (not printing)
#' 3. Check for equal cols data$x == data$y (prints only x)
#' 3.1 To avoid long calculations, only doing this for small data frames
#' 3.2 I could consider removing that condition since it looks quite fast
#' 3.3 only doing comparisons for columns of the same type.
#' 4. Check for columns who map to each others.
#'
#' Removes the second when printing dttm. (width = 15 instead of 17.)
#' Problems with partial matching.
#'
#' Would need a major rewrite for more consistency, now everything works, but it uses unexported functions + unexported API.
#' Ideally, I would simplify my print.tbl method, by adding things to the footer in tbl_foot
#' I would only override print.tbl to cut the columns I don't want!
#'
#' The documented way to do it in pillar https://pillar.r-lib.org/articles/printing.html#overview
#' doesn't seem to allow me to hide columns.
#' The hack to do tbl_format_footer.tbl_df <- tbl_format_footer.tbl seemed to solve many things.
#' For ex. employment_allowance_factor1 =employment_allowance_factor2...
#' Features:
#' @param x The object to be printed
#' @param ...
#'
#' @return
#' @export
#'
#' @examples
#' # Large tibble
#' mtcars |> as_tibble()
#' # With NA values
#'
# With unique values
#'
#' # Bench marking
# if (FALSE) {
print.tbl <- function(x, ...) {
ncells <- nrow(x) * ncol(x)
if (ncells > 1e7 || ncells == 1) {
return(pillar:::print.tbl(x, ...))
}
x_original <- x
cols_id_to_remove_na <- which(purrr::map_lgl(x_original, all_na))
# browser()
cols_id_to_remove <- cols_id_to_remove_na
check_for_unique_values <- nrow(x_original) > 1 & !inherits(x_original, "sf") & ((ncol(x_original) - length(cols_id_to_remove_na)) > 1)
if (check_for_unique_values) {
# browser()
# Ensure that with 2 values, x and NA, doesn't get captured as unique value.
# Still capture all NA as a single value
has_single_val <- \(x) dplyr::n_distinct(x, na.rm = TRUE) == 1 & dplyr::n_distinct(x) <= 1
df_with_unique_values <- x_original |>
dplyr::ungroup() |>
dplyr::select(!dplyr::any_of(cols_id_to_remove)) |>
dplyr::select(dplyr::where(has_single_val))
if (ncol(df_with_unique_values) > 0) {
cols_with_unique_value_raw <- df_with_unique_values |>
dplyr::distinct() |>
dplyr::mutate(dplyr::across(dplyr::everything(), format)) |>
# dplyr::mutate(dplyr::across(dplyr::everything(), as.character)) |>
tidyr::pivot_longer(cols = dplyr::everything()) |>
dplyr::summarise(name = cli::ansi_collapse(pillar::style_bold(name)), .by = value) |>
dplyr::select(name, value) |>
tibble::deframe()
cols_with_unique_value <- names(df_with_unique_values)
footnote_unique_values <- cols_with_unique_value_raw |>
purrr::imap_chr(\(x, name) glue::glue("{name}: {x}"))
# browser()
} else {
footnote_unique_values <- character(0)
cols_with_unique_value <- character(0)
}
} else {
cols_with_unique_value <- character(0)
}
if (length(cols_with_unique_value) > 0) {
cols_id_to_remove <- c(cols_id_to_remove, which(names(x_original) %in% cols_with_unique_value))
}
strict <- (ncol(x_original) - length(cols_id_to_remove) > 35) | nrow(x_original) > 10000 | nrow(x_original) <= 1 | inherits(x_original, "sf")
if (length(cols_id_to_remove) > 0) {
equal_cols_msg <- compare_cols(x_original[, -cols_id_to_remove], strict = strict)
} else {
equal_cols_msg <- compare_cols(x_original, strict = strict)
}
# TODO add note about some columns being high NA (and tell who they are associated with)
# high_na <- purrr::map_dbl(x, \(x) mean(is.na(x)))
# If you have two identical columns, you do not want to print those
if (length(equal_cols_msg) > 0) {
cols_to_remove_dupes <- stringr::str_extract(equal_cols_msg, "=\\s(.+)", group = 1)
cols_to_keep_dupes <- stringr::str_extract(equal_cols_msg, "(.+)\\s=", group = 1)
cols_id_to_remove <- c(cols_id_to_remove, which(names(x_original) %in% cols_to_remove_dupes))
}
if (length(cols_with_unique_value) > 0 && length(equal_cols_msg) > 0) {
# equal_cols_msg <- stringr::str_replace_all(equal_cols_msg, cols_with_unique_value |> purrr::set_names(\(x) paste0("\\b", x, "\\b")))
# cols_with_unique_value <- cols_with_unique_value[!names(cols_with_unique_value) %in% cols_to_keep_dupes]
# Change the second variable name in first_var = second_var
}
if (length(equal_cols_msg) > 0) {
equal_cols_msg <- stringr::str_replace_all(equal_cols_msg, "= ([:graph:]+)", paste("=", pillar::style_bold("\\1")))
equal_cols_msg <- stringr::str_replace_all(equal_cols_msg, "^([:graph:]+)", pillar::style_bold("\\1"))
}
if (any(c("characteristic_name", "DGUID") %in% names(x))) {
x <- x |> dplyr::mutate(dplyr::across(any_of(c("characteristic_name", "DGUID")), show_end))
}
if (length(cols_id_to_remove) == 0) {
if (inherits(x_original, "sf")) {
x <- dplyr::relocate(x_original, geometry, .after = dplyr::last_col())
pillar:::print.tbl(x, ...)
x <- x_original
} else {
pillar:::print.tbl(x, ...)
}
one_to_one_bullets <- f_one_to_one(x_original)
} else {
if (inherits(x, "sf")) {
x <- dplyr::relocate(x_original, geometry, .after = dplyr::last_col())
pillar:::print.tbl(x, ...)
x <- x_original
} else {
x <- x_original[, -cols_id_to_remove]
pillar:::print.tbl(x, ...)
x <- x_original
}
one_to_one_bullets <- f_one_to_one(x_original[, -cols_id_to_remove])
if (length(cols_id_to_remove_na) > 0) {
footer <- pillar::style_subtle(c(
"# ", cli::col_blue(cli::symbol$info), " ", pillar::style_na(NA), " cols: ",
cli::ansi_collapse(pillar::style_bold(names(x_original)[cols_id_to_remove_na]))
))
cli::cli_text(c(
footer,
"\n"
))
}
if (rlang::has_length(cols_with_unique_value)) {
# browser()
footer <- c("# ", cli::col_blue(cli::symbol$info), " List of unique values: \n", cli::ansi_collapse(footnote_unique_values))
cli::cli_text(c(
pillar::style_subtle(footer),
"\n"
))
}
if (rlang::has_length(equal_cols_msg)) {
footer <- c(
"# ", cli::col_blue(cli::symbol$info),
" With: ", paste(equal_cols_msg, collapse = ", ")
)
cli::cli_text(pillar::style_subtle(c(footer, "\n")))
}
}
cli::cli_bullets(one_to_one_bullets)
if (ncol(x) - length(cols_id_to_remove_na) > 6) {
links_to_run <- cli::ansi_collapse(
c(
"{.run [names](reuseme::names_identity(.Last.value))}",
"{.run [glimpse](dplyr::glimpse(.Last.value))}",
"{.run [view](tibble::view(.Last.value))}"
),
last = pillar::style_subtle(", or ")
)
cli::cli_text(c(
pillar::style_subtle(c("# ", cli::col_blue(cli::symbol$info), " Column ")),
links_to_run,
"\n"
))
}
if (nrow(x) > 100 && ncol(x) > 0) {
# browser()
cli::cli_text(c(
pillar::style_subtle(c("# ", cli::col_blue(cli::symbol$info), " Check 10 random ")),
"{.run [rows](reuseme::slice_sample_identity(.Last.value, n = 10))}",
"\n"
))
}
invisible(x)
}
# }
# EDA helpers ---------------------------------------------
## {.fun gt::gt} override ---------------------------------------------------
#' Print gt tables with minimal formatting
#'
#' @param x a `data.frame`
#'
#' @return An object of class `gt_tbl`
#' @export
#'
#' @examples
gt <- function(x, ...) {
rlang::check_required(x)
fmts <- function(data) {
data |>
gt::fmt_auto(tidyselect::starts_with(c("pop_"))) |>
gt::cols_label_with(fn = to_title) |> # FIXME problem when using with {.fn gt::cols_labels_with}
gt::fmt_number(tidyselect::starts_with("avg_"), decimals = 3) |>
gt::fmt_percent(dplyr::contains(c("caf", "pct_", "_pct", "percent", "increase")), decimals = 1, drop_trailing_zeros = TRUE) |>
gt::fmt_currency(
c(dplyr::contains(c("allowance", "dollar")), -dplyr::contains(c("factor", "class"))),
drop_trailing_dec_mark = TRUE
) |>
gt::sub_missing(missing_text = "--") |>
gt::tab_options(column_labels.font.weight = "bold")
}
if (nrow(x) < 2) {
return(gt::gt(x, ...) |> fmts())
}
df_with_unique_values <- x |>
dplyr::ungroup() |>
dplyr::select(tidyselect::where(\(x) dplyr::n_distinct(x) == 1))
if (ncol(df_with_unique_values) > 0) {
# browser()
cols_with_unique_value <- df_with_unique_values |>
dplyr::distinct() |>
dplyr::mutate(dplyr::across(dplyr::everything(), format)) |>
# dplyr::mutate(dplyr::across(dplyr::everything(), as.character)) |>
tidyr::pivot_longer(cols = dplyr::everything()) |>
dplyr::summarise(
name = cli::ansi_collapse(name),
.by = value
) |>
dplyr::relocate(name) |>
tibble::deframe() |>
purrr::imap_chr(\(x, name) glue::glue("{x}: *{to_title(name)}*"))
footnote <- paste(
c("List of unique values:", cols_with_unique_value),
collapse = "<br>"
)
}
my_gt <- x |>
dplyr::select(-tidyselect::all_of(names(df_with_unique_values))) |>
gt::gt(...) |>
fmts()
if (ncol(df_with_unique_values) > 0) {
my_gt <- my_gt |>
gt::tab_footnote(
footnote = gt::md(unname(footnote))
)
}
my_gt
}
## {.fn skimr::skim} override -----------------------------------------------
#' A skimr pimped with formatted output
#'
#' @param data A data frame
#' @param ...
#' @param .data_name Ignored in this version (may )
#'
#' @return
#' @export
#'
#' @examples
skim <- function(data, ..., .data_name = NULL) {
if (rstudioapi::isAvailable() && rlang::is_interactive()) {
gt_skim <- function(data, type) {
gt(data, caption = type) |>
gt::fmt_auto(lg_num_pref = "suf") |>
gt::fmt_percent(
columns = tidyselect::any_of("complete_rate"),
drop_trailing_zeros = TRUE,
decimals = 1
)
}
# browser()
data |>
dplyr::mutate(
dplyr::across(dplyr::where(is.character), \(x) dplyr::na_if(x, "")),
dplyr::across(dplyr::where(\(x) dplyr::n_distinct(x) < 15), factor)
) |>
skimr::skim(..., .data_name = .data_name) |>
skimr::partition() |>
purrr::imap(gt_skim) |>
htmltools::tagList() |>
htmltools::browsable() |>
print()
} else {
skimr::skim(data, ..., .data_name = .data_name)
}
return(invisible(data))
}
#' Create a pseudo-path with last n elements.
#'
#' @param path A vector of paths
#' @param n Number of elements
#'
#' @return A character vector
#' @export
#'
#' @examples
#' path_parent("~/Documents/rrr/canadr/DESCRIPTION", n = 3)
path_parent <- function(path, n = 2) {
path_parts <- fs::path_split(path)
length_parts <- lengths(path_parts)
path_parts |>
purrr::map(\(component) {
ret <- if (length(component) >= n) {
component[(length(component) - n + 1):length(component)]
} else {
component
}
ret
}) |>
purrr::map_vec(\(x) paste0(x, collapse = "/"))
}
# Favorite something
favourite <- function(path, alias = NULL, dest = "~/Documents/Indigenous info") {
url <- stringr::str_detect(path, "https")
if (!url) {
path <- fs::path_real(path)
}
alias_null <- is.null(alias)
if (alias_null && url) {
cli::cli_abort("If providing a URL, you must provide `alias`.")
}
alias <- alias %||% path_parent(path, n = 2)
if (!alias_null && nchar(alias) > 30) {
cli::cli_abort("Supply a better alias for this file instead {alias}")
}
file_ext <- ifelse(url, "url", "lnk")
shortcut_location <- fs::path_expand(fs::path(dest, alias, ext = file_ext))
if (!url) {
rlang::check_installed("R.utils")
fs::file_create(shortcut_location)
try(suppressWarnings(R.utils::createLink(
link = shortcut_location,
target = path,
overwrite = TRUE
)), silent = TRUE)
try(fs::file_delete(fs::path_ext_remove(shortcut_location)))
} else {
url <- path
# Create the contents of the .url file
url_file_content <- paste0(
"[InternetShortcut]\n",
"URL=", url, "\n"
)
# Write the contents to the .url file
writeLines(url_file_content, shortcut_location)
}
dir_dest <- fs::path_dir(shortcut_location)
# Possibly not necessary
cli::cli_inform(
c(
"You can verify if the link was created and works.",
"With {.run fs::file_show('{dir_dest}')}"
)
)
}
write_temp_excel <- function(dat, font = "Arial") {
wb <- openxlsx2::wb_workbook()$add_worksheet()
wb$add_data(x = dat, na.strings = "")
wb$set_base_font(font_name = "Arial")
# wb$add_cell_style(
# dims = openxlsx2::wb_dims(x = dat),
# vertical = "center"
# )
wb$open()
}
}
print_todo <- function(width = cli::console_width()) {
n_colors <- cli::num_ansi_colors()
todo <- fs::file_exists(c("TODO.R", fs::path_home_r("TODO.R")))
todo <- todo[todo]
if (length(todo) == 0) {
return(invisible())
}
# file_exists names the logical vector with the file
todo <- names(todo)
if (rlang::is_installed("reuseme (>= 0.0.0.9008")) {
reuseme::file_outline(path = fs::path_real(todo), width = width, n_colors = n_colors)
} else {
cli::cli_bullets("View {.file {todo}}")
purrr::walk(
todo,
\(file) cli::cli_bullets(readLines(file, encoding = "UTF-8"))
)
}
}
# # A version of install.packages() that is quieter
# Using pak is more convenient (especially with Rtools installed.)
# See `outdated_pkgs()`
# no longer needed, because pak allows to update packages while they are still loaded.
install.packages <- function(pkgs, ...) {
is_clean_env <- identical(ls(envir = .GlobalEnv), "install.packages")
# If FALSE, not ready to install packages.
if (any(stringr::str_detect(pkgs, "\\/")) && length(pkgs) == 1) {
cli::cli_inform("Trying to install from r-universe")
org <- stringr::str_extract(pkgs, "^[^\\/]+")
pkgs <- stringr::str_remove(pkgs, paste0(org, "\\/", collapse = "|"))
if (!identical(org, pkgs)) {
repo_r_universe <- c(
paste0("https://", org, ".r-universe.dev"),
"https://cloud.r-project.org"
)
cli::cli_bullets(c(
"Restart R session and run",
"{.code utlis::install.packages('{pkgs}', repos = '{cat(deparse(repo_r_universe))}'}}"
))
utils::install.packages(pkgs, repos = repo_r_universe)
return(invisible())
}
}
if (!is_clean_env) {
cli::cli_inform(c(
"Run {.run usethis::edit_r_profile()} and change the first line to `FALSE`",
"Then, restart R session"
))
}
utils::install.packages(pkgs, quiet = TRUE, ...)
}
if (FALSE) {
df <- tibble::tibble(
x = c(TRUE, FALSE, NA),
y = c("x", "y", "z"),
z = c(TRUE, TRUE, TRUE)
)
write_clip(df)
}
if (interactive() && rlang::is_interactive()) {
print_todo()
print_tricks(n = 10, freq = "once", id = "tricks_startup")
# Color in 2023.12
# Rstudio hooks instructions rstudio/rstudio#1579
# setHook("rstudio.sessionInit", action = "append", function(newSession) {
# # See ?cli::`cli-config` for further experiment.
# withr::with_options(list(cli.dynamic = TRUE, cli.width = Inf), {
# print_todo(width = getOption())
# tricks <- print_tricks(as_bullets = FALSE)
# tricks |>
# sample(size = 10) |>
# paste0("\f") |>
# cli::format_inline(collapse = FALSE, keep_whitespace = TRUE) |>
# cli::ansi_strwrap(width = getOption("width"), simplify = FALSE) |>
# cat(sep = "\n")
# })
# })
}
# override rstudio at startup.
rm(is_pkg_repo, is_git)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment