# DO NOT EDIT THIS FILE BY HAND! Instead edit the R Markdown source file `Rmd/salim.Rmd` and run `pkgpurl::purl_rmd()`.
# See `README.md#r-markdown-format` for more information on the literate programming approach used applying the R Markdown format.
# salim: A Wild Mix of Functions Serving Various Purposes
# Copyright (C) 2024 Salim Brüggemann
#
# This program is free software: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License as published by the Free
# Software Foundation, either version 3 of the License, or any later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE. See the GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License along with this program. If not, see <https://www.gnu.org/licenses/>.
utils::globalVariables(names = c(".",
":=",
# other
"download_url",
"filename",
"id",
"name",
"version_nr"))
as_code_chunk_array <- function(x) {
if (length(x) == 1L) {
return(paste0("#| - ", x))
}
yaml::as.yaml(x) |>
stringr::str_split_1("\n") %>%
magrittr::extract(nchar(.) > 0L) %>%
paste0("#| ", .,
collapse = "\n")
}
as_yaml_inline <- function(x) {
yaml::as.yaml(x) |> stringr::str_remove(pattern = "\n$")
}
pkg_mgr_hint <- function(software = names(pkg_mgr_software)) {
software <- rlang::arg_match(software)
result <- ""
if (xfun::is_macos()) {
result %<>% paste0(pkg_mgr_prose(software = software,
pkg_mgrs = "brew"))
} else if (xfun::is_windows()) {
result %<>% paste0(pkg_mgr_prose(software = software,
pkg_mgrs = c("scoop", "choco")))
}
result
}
pkg_mgr_prose <- function(software,
pkg_mgrs = c("brew", "scoop", "choco")) {
pkg_mgr_names <-
pkg_mgrs |>
dplyr::case_match("brew" ~ "Homebrew",
"scoop" ~ "Scoop",
"choco" ~ "Chocolatey")
pkg_mgr_software |>
purrr::chuck(software) |>
purrr::keep_at(at = pkg_mgrs) |>
purrr::map2_chr(.y = pkg_mgr_names,
.f = \(x, y) paste0(y, " ({.code ", x$cmd, "})")) |>
pal::enum_str(sep2 = " or ") |>
pal::when(length(.) > 0L ~ paste0(" ", software, " is also available via ", ., "."),
~ "")
}
#' Prettify date
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' Use [stringi::stri_datetime_format()] instead:
#'
#' ```r
#' stringi::stri_datetime_format(format = c("date_short", "date_medium", "date_long", "date_full"),
#' locale = "en")
#' ```
#'
#' @details
#' Note that this might only work on (Ubuntu) Linux in the current form since locales are one bitchy hell of a PITA...
#'
#' @param date Date to be prettified. A [date][base::Date] or something coercible to.
#' @param locale Locale the date should be prettified for. Currently only `"en"`/`"en-US"` and `"de"`/`"de-CH"` are implemented.
#'
#' @return A character scalar.
#' @family spoken
#' @keywords internal
#'
#' @examples
#' salim:::prettify_date("2021-12-21")
prettify_date <- function(date,
locale = c("en", "de", "en-US", "de-CH")) {
lifecycle::deprecate_warn(when = "0.0.9015",
what = "prettify_date()",
details = paste0('Use the more powerful and more robust `stringi::stri_datetime_format(format = c("date_short", "date_medium", ',
'"date_long", "date_full"), locale = "en")` function instead.'))
locale <- rlang::arg_match(locale)
withr::with_locale(new = c(LC_TIME = pal::when(. = locale,
. %in% c("en", "en-US") ~ "C",
. %in% c("de", "de-CH") ~ "de_CH.utf8")),
code =
locale |>
pal::when(. %in% c("en", "en-US") ~
"%B %d, %Y",
. %in% c("de", "de-CH") ~
"%d. %B %Y",
~ cli::cli_abort("Specified {.arg locale} not implemented yet.")) |>
format(x = lubridate::as_date(date)))
}
#' Prettify datetime
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' Use [stringi::stri_datetime_format()] instead:
#'
#' ```r
#' stringi::stri_datetime_format(format = c("datetime_short", "datetime_medium", "datetime_long", "datetime_full"),
#' locale = "en")
#' ```
#'
#' @details
#' Note that this might only work on (Ubuntu) Linux in the current form since locales are one bitchy hell of a PITA...
#'
#' @param datetime Datetime to be prettified. A [datetime][base::DateTimeClasses] or something coercible to.
#' @param locale Locale the datetime should be prettified for. Currently only `"en"`/`"en-US"` and `"de"`/`"de-CH"` are implemented.
#'
#' @return A character scalar.
#' @family spoken
#' @keywords internal
#'
#' @examples
#' salim:::prettify_datetime("2021-12-21T00:00:01Z")
prettify_datetime <- function(datetime,
locale = c("en", "de", "en-US", "de-CH")) {
lifecycle::deprecate_warn(when = "0.0.9015",
what = "prettify_datetime()",
details = paste0('Use the more powerful and more robust `stringi::stri_datetime_format(format = c("datetime_short", ',
'"datetime_medium", "datetime_long", "datetime_full"), locale = "en")` function instead.'))
locale <- rlang::arg_match(locale)
withr::with_locale(new = c(LC_TIME = pal::when(. = locale,
. %in% c("en", "en-US") ~ "C",
. %in% c("de", "de-CH") ~ "de_CH.utf8")),
code =
locale |>
pal::when(. %in% c("en", "en-US") ~
"%B %d, %Y, %I:%M %p",
. %in% c("de", "de-CH") ~
"%d. %B %Y, %H:%M Uhr",
~ cli::cli_abort("Specified {.arg locale} not implemented yet.")) |>
format(x = lubridate::as_datetime(datetime)))
}
#' Convert an integer into spelled abbreviated English or German rank
#'
#' @param x An integer scalar or something coercible to.
#' @param lang The language to write the rank in.
#'
#' @return A character scalar.
#' @family spoken
#' @export
rank_nr <- function(x,
lang = c("en", "de")) {
lang <- rlang::arg_match(lang)
result <- "?"
if (length(x) > 0L) {
if (lang == "de") {
result <- switch(EXPR = as.character(as.integer(x)),
"1" = "erste",
"2" = "zweite",
"3" = "dritte",
"4" = "vierte",
"5" = "f\u00fcnfte",
"6" = "sechste",
"7" = "siebte",
"8" = "achte",
"9" = "neunte",
"?")
} else if (lang == "en") {
result <- switch(EXPR = as.character(as.integer(x)),
"1" = "1st",
"2" = "2nd",
"3" = "3rd",
"4" = "4th",
"5" = "5th",
"6" = "6th",
"7" = "7th",
"8" = "8th",
"9" = "9th",
"?")
}
}
result
}
#' Write out a count
#'
#' @param n The count to write out in letters. A non-negative integer scalar.
#' @param lang The language to write out `n` in.
#' @param use_singular Use a definite descriptor for `n = 0` and `n = 1` instead of the indistinct number. A logical scalar.
#' @param use_dual Use a definite descriptor for `n = 2` instead of the indistinct number. A logical scalar.
#' @param strip_article Strip the definite article from the definite descriptors. Only relevant if at least one of `use_singular` or `use_dual` is `TRUE`. A
#' logical scalar.
#'
#' @return A character scalar.
#' @seealso [gt::vec_fmt_spelled_num()] which spells out integers from 0 to 100 in `r length(setdiff(colnames(gt:::spelled_num), "number"))` different locales.
#' @family spoken
#' @export
write_out_n <- function(n,
lang = c("en", "de"),
use_singular = FALSE,
use_dual = FALSE,
strip_article = use_dual) {
n %<>% checkmate::assert_count() %>% as.character()
lang <- rlang::arg_match(lang)
checkmate::assert_flag(use_singular)
checkmate::assert_flag(use_dual)
checkmate::assert_flag(strip_article)
if (lang == "en") {
result <- switch(EXPR = n,
`0` = ifelse(use_singular,
"no",
"zero"),
`1` = ifelse(use_singular,
"the",
"one"),
`2` = ifelse(use_dual,
"the two",
"two"),
xfun::numbers_to_words(as.integer(n)))
} else if (lang == "de") {
result <- switch(EXPR = n,
`0` = ifelse(use_singular,
"keine",
"null"),
`1` = ifelse(use_singular,
"die",
"ein"),
`2` = ifelse(use_dual,
"die beiden",
"zwei"),
`3` = "drei",
`4` = "vier",
`5` = "f\u00fcnf",
`6` = "sechs",
`7` = "sieben",
`8` = "acht",
`9` = "neun")
}
if (strip_article) {
result %<>% stringr::str_remove(pattern = switch(EXPR = lang,
de = "^[Dd]ie ?",
en = "^[Tt]he ?"))
}
result
}
#' Append `"n"` to indefinite article where indicated
#'
#' Appends an `"n"` to the indefinite article "a" if required by English language rules.
#'
#' Note that this function only covers part of all cases where "an" instead of "a" is indicated. Since the choice of _a_ or _an_ [depends on sound, not
#' spelling](http://www.butte.edu/departments/cas/tipsheets/grammar/articles.html), it's not trivial to implement a universal solution.
#'
#' For example, this function doesn't properly append an `"n"` to the indefinite article in the following situations:
#' - A word starting with the letter "u" where it is pronounced as a vowel, e.g. _**unhappy**_. Note that most English words starting with letter "u" are
#' pronounced differently like _universum_ and thus require the indefinite article _a_, not _an_.
#' - A word starting with a consonant that is pronounced as a vowel, e.g. _**hour**_.
#'
#' @param x A character vector.
#'
#' @return A character vector.
#' @family spoken
#' @export
#'
#' @examples
#' n_ify("This is a absolute disaster, such a error.")
n_ify <- function(x) {
purrr::map_chr(.x = x,
.f = \(s) stringr::str_replace_all(string = s,
pattern = "(^[Aa]| a)(?= [AaEeOoIi]\\w+)",
replacement = "\\1n"))
}
#' Get the German definite article
#'
#' @param gender The grammatical gender of the subject the definite article refers to.
#' @param case The grammatical case of the subject the definite article refers to.
#' @param pluralize Whether to return the plural form of the definite article. A logical scalar.
#'
#' @return A character scalar.
#' @family spoken
#' @export
definite_article_de <- function(gender = c("feminine",
"masculine",
"neuter"),
case = c("nominative",
"genitive",
"dative",
"accusative"),
pluralize = FALSE) {
gender <- rlang::arg_match(gender)
case <- rlang::arg_match(case)
if (checkmate::assert_flag(pluralize)) {
switch(EXPR = case,
nominative = "die",
genitive = "der",
dative = "den",
accusative = "die")
} else {
switch(EXPR = case,
nominative = switch(EXPR = gender,
feminine = "die",
masculine = "der",
neuter = "das"),
genitive = switch(EXPR = gender,
feminine = "der",
"des"),
dative = switch(EXPR = gender,
feminine = "der",
"dem"),
accusative = switch(EXPR = gender,
feminine = "die",
masculine = "den",
neuter = "das"))
}
}
#' Decline the German definite article
#'
#' The declination of the German definite article [is a relative pronoun](https://de.wikipedia.org/wiki/Relativpronomen#Der,_die,_das).
#'
#' Note that the second singular feminine and plural genitive form `"derer"` is ignored by this function.
#'
#' @inheritParams definite_article_de
#'
#' @inherit definite_article_de return
#' @family spoken
#' @export
definite_article_de_declined <- function(gender = c("feminine",
"masculine",
"neuter"),
case = c("nominative",
"genitive",
"dative",
"accusative"),
pluralize = FALSE) {
gender <- rlang::arg_match(gender)
case <- rlang::arg_match(case)
if (checkmate::assert_flag(pluralize)) {
switch(EXPR = case,
nominative = "die",
genitive = "deren",
dative = "deren",
accusative = "die")
} else {
switch(EXPR = case,
nominative = switch(EXPR = gender,
feminine = "die",
masculine = "der",
neuter = "das"),
genitive = switch(EXPR = gender,
feminine = "deren",
"dessen"),
dative = switch(EXPR = gender,
feminine = "der",
"dem"),
accusative = switch(EXPR = gender,
feminine = "die",
masculine = "den",
neuter = "das"))
}
}
#' Add the German definite article in dative case to a preposition
#'
#' @param preposition The preposition to add the German definite article in dative case to. A character scalar.
#' @param gender The grammatical gender of the `preposition`.
#'
#' @inherit definite_article_de return
#' @family spoken
#' @export
add_definite_article_de <- function(preposition,
gender = c("feminine",
"masculine",
"neuter")) {
checkmate::assert_string(preposition)
gender <- rlang::arg_match(gender)
if (gender == "feminine") {
preposition |> pal::when(stringr::str_to_lower(.) == "zu" ~ paste0(., "r"),
~ paste0(., " ", definite_article_de(gender = "feminine",
case = "dative")))
} else {
preposition |> pal::when(stringr::str_to_lower(.) %in% c("bei", "zu") ~ paste0(., "m"),
stringr::str_to_lower(.) %in% c("in", "an") ~ stringr::str_replace(string = .,
pattern = "n$",
replacement = "m"),
~ paste0(., " ", definite_article_de(gender = "masculine",
case = "dative")))
}
}
#' Decline a German noun
#'
#' Note that this function is far from covering all grammatical possibilities. I.a. it currently doesn't support the [special
#' cases](https://deutsch.lingolia.com/de/grammatik/nomen/deklination/genitiv#a-besonderheiten) where a masculine noun gets an `n` or `en` ending attached in
#' the accusative, dative and genitive cases.
#'
#' @param noun The noun to decline, optionally with preceding adjective(s), in (indefinite) nominative. A character scalar.
#' @param gender The grammatical gender of the `noun`.
#' @param case The grammatical case of the `noun`.
#' @param is_plural Whether or not `noun` is a plural.
#'
#' @inherit definite_article_de return
#' @family spoken
#' @export
decline_noun_de <- function(noun,
gender = c("feminine",
"masculine",
"neuter"),
case = c("nominative",
"genitive",
"dative",
"accusative"),
is_plural = FALSE) {
gender <- rlang::arg_match(gender)
case <- rlang::arg_match(case)
checkmate::assert_flag(is_plural)
result <- noun
if (gender != "feminine" && case == "genitive") {
result %<>% pal::when(stringr::str_detect(string = ., pattern = "(ss|\U00DF|x|z)$") ~ paste0(., "es"),
endsWith(., "s") ~ paste0(., "ses"),
~ paste0(., "s"))
# decline preceeding adjectives
} else if (case %in% c("genitive", "dative") || (case == "accusative" && is_plural)) {
result %<>% stringr::str_replace_all(pattern = "((?:^|[:blank:])[:alnum:]+e)([:blank:])(?!\\s*$)",
replacement = "\\1n\\2")
}
result
}
#' Regular expression patterns and replacements for spelling normalization
#'
#' @format `r pkgsnip::return_lbl("tibble")`
#' @seealso
#' Other regular expression rules: [`yay::regex_text_normalization`], [`yay::regex_file_normalization`]
#'
#' String normalization functions: [yay::str_normalize()], [yay::str_normalize_file()]
#'
#' @examples
#' # unnest the pattern column
#' salim::regex_spelling_normalization |> tidyr::unnest_longer(col = pattern)
"regex_spelling_normalization"
#' Download Pandoc release
#'
#' Downloads the [assets][pandoc_release_assets] and extracts the executable program binaries for Linux, macOS and Windows of a certain [Pandoc
#' release][pandoc_releases].
#'
#' @param os The operating system(s) for which Pandoc binaries should be downloaded. Any combination of
#' `r pal::fn_param_defaults(param = "os", fn = download_pandoc_binaries) |> pal::wrap_chr("\x60") |> cli::ansi_collapse(last = " and ")`.
#' @param path The filesystem path to which the binaries are saved to. A [path][fs::fs_path] or something coercible to.
#' @param overwrite Whether to overwrite existing binaries under `path`.
#' @inheritParams pandoc_release_assets
#'
#' @return `path` invisibly.
#' @family pandoc
#' @export
download_pandoc_binaries <- function(release_id = pandoc_release_id_latest(),
os = c("linux", "macos", "windows"),
path = "bin/",
overwrite = TRUE) {
checkmate::assert_count(release_id,
positive = TRUE)
checkmate::assert_subset(os,
choices = eval(formals()$os),
empty.ok = FALSE)
checkmate::assert_path_for_output(path,
overwrite = TRUE)
checkmate::assert_flag(overwrite)
rlang::check_installed("waldo",
reason = pal::reason_pkg_required())
path_tmp <- fs::path_temp()
assets <-
pandoc_release_assets(release_id = release_id) |>
dplyr::filter(stringr::str_detect(string = filename,
pattern = paste0("(?i)", pal::fuse_regex(os), "(-(amd64|x86_64))?\\.(zip|tar\\.gz)"))) |>
dplyr::mutate(download_path = fs::path(path_tmp, filename))
# download assets to tmp dir
purrr::walk2(.x = assets$download_url,
.y = assets$download_path,
.f = \(url, path) utils::download.file(url = url,
destfile = path,
method = "auto",
mode = "wb",
cacheOK = TRUE,
quiet = TRUE))
# extract binaries to tmp dir
assets |>
dplyr::select(-download_url) |>
as.list() |>
purrr::pwalk(.f = \(filename, os, download_path) {
path_os_tmp <- fs::path(path_tmp, "pandoc", os)
# extract all files flat
if (endsWith(filename, ".zip")) {
zip::unzip(zipfile = download_path,
exdir = path_os_tmp,
junkpaths = TRUE)
} else {
utils::untar(tarfile = download_path,
exdir = path_os_tmp)
# since `untar()` has no "junkpaths"-like option, we flatten the dir structure ourselves
fs::dir_ls(path = path_os_tmp,
type = "file",
recurse = TRUE,
all = TRUE) |>
fs::file_move(new_path = path_os_tmp)
}
# delete archive and all extracted files but the Pandoc binary
fs::file_delete(download_path)
fs::dir_ls(path = path_os_tmp,
regexp = "[\\/]pandoc(\\.exe)?$",
all = TRUE,
invert = TRUE) |>
fs::file_delete()
})
# move binaries to final dir
fs::dir_create(path = fs::path(path, "pandoc"))
path_tmp |>
fs::path("pandoc") %T>%
fs::dir_copy(new_path = fs::path(path, "pandoc"),
overwrite = overwrite) %>%
fs::dir_delete()
invisible(path)
}
#' Get latest Pandoc release ID
#'
#' Uses [gh::gh()] to fetch [Pandoc](https://pandoc.org/)'s latest [GitHub release](https://docs.github.com/repositories/releasing-projects-on-github) ID via
#' [GitHub's REST API](https://docs.github.com/en/rest/reference/repos#get-the-latest-release).
#'
#' @return An integer scalar.
#' @family pandoc
#' @export
pandoc_release_id_latest <- function() {
rlang::check_installed("gh",
reason = pal::reason_pkg_required())
gh::gh(endpoint = "/repos/{owner}/{repo}/releases/latest", # nolint
owner = "jgm",
repo = "pandoc",
.method = "GET") %$%
id
}
#' Get latest Pandoc release version number
#'
#' Uses [gh::gh()] to fetch [Pandoc](https://pandoc.org/)'s latest [GitHub release](https://docs.github.com/repositories/releasing-projects-on-github) version
#' number via [GitHub's REST API](https://docs.github.com/en/rest/reference/repos#get-the-latest-release) and returns it as a [numeric
#' version][numeric_version()].
#'
#' @return `r pkgsnip::param_lbl("num_vrsn")`
#' @family pandoc
#' @export
pandoc_version_latest <- function() {
rlang::check_installed("gh",
reason = pal::reason_pkg_required())
gh::gh(endpoint = "/repos/{owner}/{repo}/releases/latest", # nolint
owner = "jgm",
repo = "pandoc",
.method = "GET") %$%
name |>
stringr::str_extract(pattern = "\\d+(\\.\\d+)*") |>
as.numeric_version()
}
#' List all available Pandoc releases
#'
#' Uses [gh::gh()] to fetch all available [GitHub releases](https://docs.github.com/repositories/releasing-projects-on-github) of [Pandoc](https://pandoc.org/)
#' via [GitHub's REST API](https://docs.github.com/en/rest/reference/repos#list-releases) and returns them as a [tibble][tibble::tbl_df] containing the two
#' columns `version_nr` and `release_id`.
#'
#' Values of the column `release_id` can be used as input to [download_pandoc_binaries()].
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family pandoc
#' @export
pandoc_releases <- function() {
rlang::check_installed("gh",
reason = pal::reason_pkg_required())
gh::gh(endpoint = "/repos/{owner}/{repo}/releases", # nolint
owner = "jgm",
repo = "pandoc",
.method = "GET",
.limit = Inf) |>
purrr::map(\(x) tibble::tibble(version_nr =
x$name |>
stringr::str_extract(pattern = "\\d+(\\.\\d+)*") |>
as.numeric_version(),
release_id = x$id)) |>
purrr::list_rbind() |>
dplyr::arrange(version_nr)
}
#' List Pandoc release assets
#'
#' Uses [gh::gh()] to fetch filenames, corresponding operating systems and download URLs of a specific [GitHub
#' release](https://docs.github.com/repositories/releasing-projects-on-github) of [Pandoc](https://pandoc.org/) via [GitHub's REST
#' API](https://docs.github.com/en/rest/reference/repos#list-release-assets) and returns them as a [tibble][tibble::tbl_df].
#'
#' @param release_id The GitHub release ID of the desired Pandoc release. Use [pandoc_releases()] to determine the release ID of a specific Pandoc version
#' number. An integer scalar.
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family pandoc
#' @export
pandoc_release_assets <- function(release_id = pandoc_release_id_latest()) {
rlang::check_installed("gh",
reason = pal::reason_pkg_required())
gh::gh(endpoint = "/repos/{owner}/{repo}/releases/{release_id}/assets", # nolint
owner = "jgm",
repo = "pandoc",
release_id = release_id,
.method = "GET") |>
purrr::map(\(x) tibble::tibble(filename = x$name,
os =
x$name |>
stringr::str_extract(pattern = "(?i)(linux|macos|windows|\\.deb$)") |>
stringr::str_to_lower() |>
stringr::str_replace(pattern = stringr::fixed(".deb"),
replacement = "linux"),
download_url = x$browser_download_url)) |>
purrr::list_rbind()
}
#' Download Pandoc template
#'
#' Downloads one of our [custom Pandoc templates](https://gitlab.com/salim_b/pandoc/templates) and returns it as a character scalar. The template is cached
#' using [pal::req_cached()], thus only re-downloaded if the local copy is outdated.
#'
#' @param tpl Template to download. One of
#' `r pal::fn_param_defaults(param = "tpl", fn = "pandoc_tpl") |> pal::wrap_chr("\x60") |> cli::ansi_collapse(last = " and ")`.
#'
#' @return The template as a character scalar.
#' @family pandoc
#' @export
#'
#' @examples
#' \dontrun{
#' salim::pandoc_tpl(tpl = "quarto_mod.latex") |>
#' brio::write_file(path = "quarto_mod.latex")}
pandoc_tpl <- function(tpl = "quarto_mod.latex") {
tpl <- rlang::arg_match(tpl)
(pal::req_cached(url = glue::glue("https://gitlab.com/salim_b/pandoc/templates/-/raw/main/{tpl}?ref_type=heads&inline=false")) |>
httr2::resp_body_string())
}
#' Assemble Quarto knitr figure chunk
#'
#' Assembles a [Quarto knitr figure chunk](https://quarto.org/docs/authoring/figures.html#computations).
#'
#' Use [substitute] together with [deparse1()] to convert \R expressions to a character scalar as expected by param `body`:
#'
#' ```r
#' deparse1(expr = substitute(do_something()),
#' collapse = "\n")
#' ```
#'
#' @param body \R code to insert into the code chunk's body. A character scalar.
#' @param label Unique code chunk label. Set as Quarto's [`label`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A
#' character scalar that starts with `"fig-"`.
#' @param fig_cap Figure caption. Set as Quarto's [`fig-cap`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character
#' scalar.
#' @param fig_subcap Figure subcaptions. Set as Quarto's [`fig-subcap`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A
#' character vector, or `NULL` to omit.
#' @param fig_column Quarto [article layout class](https://quarto.org/docs/authoring/article-layout.html#available-columns) for the figure output. Set as
#' Quarto's [`fig-column`](https://quarto.org/docs/reference/cells/cells-knitr.html#page-columns) code chunk option. One of
#' `r pal::as_md_val_list(qmd_layout_classes)`
#' @param fig_width Width of the plot (in inches), to be used in the graphics device. Set as Quarto's
#' [`fig-width`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A numeric scalar, or `NULL` to omit.
#' @param fig_height Height of the plot (in inches), to be used in the graphics device. Set as Quarto's
#' [`fig-height`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A numeric scalar, or `NULL` to omit.
#' @param fig_pos LaTeX figure position arrangement to be used in `\begin{figure}[]`. Set as Quarto's
#' [`fig-pos`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character scalar, or `NULL` to omit. Use `"false"` for
#' no figure position specifier, which is sometimes necessary with custom figure environments (such as `sidewaysfigure`).
#' @param fig_link Hyperlink target for the figure. Set as Quarto's [`fig-link`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk
#' option. A character scalar, or `NULL` to omit.
#' @param out_width Width of the plot in the output document, which can be different from its physical `fig_width`, i.e., plots can be scaled in the output
#' document. Set as Quarto's [`out-width`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character scalar, or `NULL`
#' to omit.
#' @param out_height Height of the plot in the output document, which can be different from its physical `fig_height`, i.e., plots can be scaled in the output
#' document. Set as Quarto's [`out-height`](https://quarto.org/docs/reference/cells/cells-knitr.html#figures) code chunk option. A character scalar, or `NULL`
#' to omit.
#'
#' @return A character scalar.
#' @family quarto
#' @export
#'
#' @examples
#' salim::quarto_fig_chunk(body = "plot(cars)",
#' label = "fig-mtcars",
#' fig_cap = "Default plot for dataset `cars`",
#' fig_column = "page") |>
#' cat()
quarto_fig_chunk <- function(body,
label,
fig_cap,
fig_subcap = NULL,
fig_column = "body",
fig_width = NULL,
fig_height = NULL,
fig_pos = "H",
fig_link = NULL,
out_width = NULL,
out_height = NULL) {
rlang::check_installed(pkg = "yaml",
reason = pal::reason_pkg_required())
checkmate::assert_string(body)
checkmate::assert_string(label,
pattern = "^fig-.+")
checkmate::assert_character(fig_cap,
any.missing = FALSE,
min.len = 1L,
null.ok = TRUE)
checkmate::assert_character(fig_subcap,
any.missing = FALSE,
null.ok = TRUE)
checkmate::assert_number(fig_width,
lower = 0.0,
null.ok = TRUE)
checkmate::assert_number(fig_height,
lower = 0.0,
null.ok = TRUE)
checkmate::assert_string(fig_pos,
null.ok = TRUE)
checkmate::assert_string(fig_link,
null.ok = TRUE)
checkmate::assert_string(out_width,
null.ok = TRUE)
checkmate::assert_string(out_height,
null.ok = TRUE)
fig_column <- rlang::arg_match(arg = fig_column,
values = qmd_layout_classes)
is_fig_cap_scalar <- length(fig_cap) == 1L
has_fig_subcap <- length(fig_subcap) > 0L
# convert to YAML array
if (has_fig_subcap) {
fig_subcap %<>% as_code_chunk_array()
}
# assemble code chunk
glue::glue(paste0(c("```{{r}}",
"#| label: {as_yaml_inline(label)}",
"#| fig-cap:",
as_code_chunk_array(fig_cap),
"#| fig-subcap:"[has_fig_subcap],
fig_subcap,
"#| fig-column: {fig_column}",
"#| fig-width: {as_yaml_inline(fig_width)}"[!is.null(fig_width)],
"#| fig-height: {as_yaml_inline(fig_height)}"[!is.null(fig_height)],
"#| fig-pos: {fig_pos}"[!is.null(fig_pos)],
"#| fig-link: {as_yaml_inline(fig_link)}"[length(fig_link) > 0L],
"#| out-width: {as_yaml_inline(out_width)}"[!is.null(out_width)],
"#| out-height: {as_yaml_inline(out_height)}"[!is.null(out_height)],
"",
"{body}",
"```",
"",
""),
collapse = "\n"))
}
#' Assemble Quarto knitr table chunk
#'
#' Assembles a [Quarto knitr table chunk](https://quarto.org/docs/authoring/tables.html#computations).
#'
#' Use [substitute] together with [deparse1()] to convert \R expressions to a character scalar as expected by param `body`:
#'
#' ```r
#' deparse1(expr = substitute(do_something()),
#' collapse = "\n")
#' ```
#'
#' @param body \R code to insert into the code chunk's body. A character scalar.
#' @param label Unique code chunk label. Set as Quarto's [`label`](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code chunk option. A
#' character scalar that starts with `"tbl-"`.
#' @param tbl_cap Table caption. Set as Quarto's [`tbl-cap`](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code chunk option. A character
#' scalar.
#' @param tbl_subcap Table subcaptions. Set as Quarto's [`tbl-subcap`](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code chunk option. A
#' character vector.
#' @param tbl_column Quarto [article layout class](https://quarto.org/docs/authoring/article-layout.html#available-columns) for the figure output. Set as
#' Quarto's [`tbl-column`](https://quarto.org/docs/reference/cells/cells-knitr.html#page-columns) code chunk option. One of
#' `r pal::as_md_val_list(qmd_layout_classes)`
#' @param tbl_colwidths Apply explicit table column widths for Markdown [grid tables](https://pandoc.org/MANUAL.html#extension-grid_tables) and [pipe
#' tables](https://pandoc.org/MANUAL.html#extension-pipe_tables) that are more than `columns` characters wide (72 by default).
#'
#' Some formats (e.g. HTML) do an excellent job automatically sizing table columns and so don’t benefit much from column width specifications. Other formats
#' (e.g. LaTeX) require table column sizes in order to correctly flow longer cell content (this is a major reason why tables > 72 columns wide are assigned
#' explicit widths by Pandoc).
#'
#' This can be specified as:
#'
#' - `"auto"`: Apply Markdown table column widths except when there is a hyperlink in the table (which tends to throw off automatic calculation of column
#' widths based on the Markdown text width of cells). `"auto"` is the default for HTML output formats.
#'
#' - `"true"`: Always apply Markdown table widths. `"true"` is the default for all non-HTML formats.
#'
#' - `"false"`: Never apply Markdown table widths.
#'
#' - A numeric vector (e.g. `c(40, 30, 30)`): Array of explicit width percentages.
#'
#' @return A character scalar.
#' @family quarto
#' @export
#'
#' @examples
#' salim::quarto_tbl_chunk(body = "knitr::kable(head(cars))",
#' label = "tbl-head-cars",
#' tbl_cap = "Head of dataset `cars`",
#' tbl_column = "margin") |>
#' cat()
quarto_tbl_chunk <- function(body,
label,
tbl_cap,
tbl_subcap = NULL,
tbl_colwidths = NULL,
tbl_column = "body") {
rlang::check_installed(pkg = "yaml",
reason = pal::reason_pkg_required())
checkmate::assert_string(body)
checkmate::assert_string(label,
pattern = "^tbl-.+")
checkmate::assert_string(tbl_cap)
checkmate::assert_character(tbl_subcap,
any.missing = FALSE,
null.ok = TRUE)
is_str_tbl_colwidths <- checkmate::test_choice(tbl_colwidths,
choices = c("auto", "true", "false"))
is_num_tbl_colwidths <- checkmate::test_numeric(tbl_colwidths,
min.len = 1L)
if (!(is.null(tbl_colwidths) || is_str_tbl_colwidths || is_num_tbl_colwidths)) {
cli::cli_abort('{.arg tbl_colwidths} must be either one of {.val {"auto"}}, {.val {"true"}} or {.val {"false"}}, or a numeric vector.')
}
tbl_column <- rlang::arg_match(arg = tbl_column,
values = qmd_layout_classes)
has_tbl_subcap <- length(tbl_subcap) > 0L
# convert to YAML array
if (has_tbl_subcap) {
tbl_subcap %<>% as_code_chunk_array()
}
# assemble code chunk
glue::glue(paste0(c("```{{r}}",
"#| label: {as_yaml_inline(label)}",
"#| tbl-cap:",
as_code_chunk_array(tbl_cap),
"#| tbl-subcap:"[has_tbl_subcap],
tbl_subcap,
"#| tbl-column: {tbl_column}",
"#| tbl-colwidths: {tbl_colwidths}"[is_str_tbl_colwidths],
"#| tbl-colwidths:"[is_num_tbl_colwidths],
as_code_chunk_array(tbl_colwidths)[is_num_tbl_colwidths],
"",
"{body}",
"```",
"",
""),
collapse = "\n"))
}
#' Generate Quarto knitr code chunk snippets from structured data
#'
#' Generates Quarto Markdown (`.qmd`) file snippets with knitr [figure][quarto_fig_chunk] or [table][quarto_tbl_chunk] code chunks from structured `data`.
#'
#' The generated `.qmd` files are intended to be included in other Quarto documents via the built-in
#' [`include`](https://quarto.org/docs/authoring/includes.html) shortcode.
#'
#' # Input `data`
#'
#' All `data` columns of type character are [cli::pluralize()]d, meaning literal curly brackets (`{` and `}`) need to be escaped by doubling them (to `{{` and
#' `}}`).
#'
#' The column names of `data` can either correspond to [quarto_fig_chunk()]/[quarto_tbl_chunk()]'s argument names (in [snake
#' case](https://en.wikipedia.org/wiki/Snake_case)), to [knitr's figure chunk option names](https://yihui.org/knitr/options/#plots) (period-separared) or
#' directly to Quarto's
#' [figure](https://quarto.org/docs/reference/cells/cells-knitr.html#figures)/[table](https://quarto.org/docs/reference/cells/cells-knitr.html#tables) code
#' chunk option names (in [kebab case](https://en.wikipedia.org/wiki/Letter_case#Kebab_case)) – they will be converted as needed.
#'
#' Additional column names are silently ignored, except for the optional iteration variable columns `itr_vars` (of type list) and `itr_vars_r` (of type
#' character).
#'
#' # Iteration variables
#'
#' Specifying iteration variables allows to produce multiple code chunks per `data` row. The iteration variables can be referred to in the other columns via
#' [cli::pluralize()]'s string interpolation syntax (i.e. R code in curly brackets).
#'
#' The `itr_vars` column must be a list of named lists (or `NULL` for no iteration on the respective rows). The `itr_vars_r` column allows to specify `itr_vars`
#' as a string of R code (which must yield a list of named lists / `NULL`s when parsed and executed).
#'
#' @param data Input data as returned by [read_quarto_chunk_data()]. A dataframe where column names correspond to chunk options supported by
#' [quarto_fig_chunk()] or [quarto_tbl_chunk()] plus the optional iteration variable columns `itr_vars` and `itr_vars_r`. Columns `body`, `label` and
#' `fig_cap`/`tbl_cap` are mandatory. See section *Input `data`* for details.
#' @param env Environment to evaluate iterations in (see section *Iteration variables* for details).
#'
#' @return `data`, invisibly.
#' @family quarto
#' @export
#'
#' @examples
#' # data row without iterations
#' tibble::tibble(label = "fig-cars",
#' fig_cap = "Today's ({lubridate::today()}) top figure",
#' fig_column = "page",
#' fig_height = 8L,
#' body = "plot(cars)") |>
#' salim::quarto_chunks()
#'
#' # data row with iteration variables specified directly as `itr_vars`
#' tibble::tibble(itr_vars = list(list(v = "cyl"),
#' list(v = "disp"),
#' list(v = "hp")),
#' label = "fig-mpg-by-{v}",
#' fig_cap = "Motor Trend Car Road Tests: mpg per {v}",
#' fig_column = "screen",
#' fig_height = 8L,
#' body = "plot(x = mtcars$mpg, y = mtcars${v})") |>
#' salim::quarto_chunks()
#'
#' # data row with iteration variables specified indirectly as `itr_vars_r` code
#' tibble::tibble(itr_vars_r = "purrr::map(colnames(mtcars)[5:7], \\(x) list(v = x))",
#' label = "fig-mpg-by-{v}",
#' fig_cap = "Motor Trend Car Road Tests: mpg per {v}",
#' fig_column = "screen",
#' fig_height = 8L,
#' body = "plot(x = mtcars$mpg, y = mtcars${v})") |>
#' salim::quarto_chunks()
quarto_chunks <- function(data,
env = parent.frame()) {
checkmate::assert_data_frame(data,
all.missing = FALSE,
min.cols = 2L)
# normalize names
data %<>% magrittr::set_colnames(value = stringr::str_replace_all(string = colnames(.),
pattern = "[-.]",
replacement = "_"))
# ensure mandatory cols are present
if (!("body" %in% colnames(data))) cli::cli_abort("{.arg data} must contain a column {.var body}.")
if (!("label" %in% colnames(data))) cli::cli_abort("{.arg data} must contain a column {.var label}.")
if (!("fig_cap" %in% colnames(data))) cli::cli_abort("{.arg data} must contain a column {.var fig_cap}.")
# ensure mandatory vals aren't NA
if (anyNA(data$body)) cli::cli_abort("{.arg data} column {.var body} mustn't contain {.val {NA}} values.")
if (anyNA(data$label)) cli::cli_abort("{.arg data} column {.var label} mustn't contain {.val {NA}} values.")
if (anyNA(data$fig_cap)) cli::cli_abort("{.arg data} column {.var fig_cap} mustn't contain {.val {NA}} values.")
# add empty `itr_vars` col if it's missing
if (!("itr_vars" %in% colnames(data))) {
data %<>% tibble::add_column(itr_vars = rep(x = list(NULL),
times = nrow(.)))
}
# expand `itr_vars_r` to `itr_vars` (one-to-many rows)
if ("itr_vars_r" %in% colnames(data)) {
data %<>%
purrr::pmap(\(itr_vars, itr_vars_r, ...) {
if (!is.na(itr_vars_r)) {
if (!is.null(itr_vars)) {
cli::cli_abort("A {.arg data} row cannot have both {.var itr_vars} and {.var itr_vars_r} set at the same time.")
}
itr_vars <- eval(parse(text = itr_vars_r),
envir = env)
} else {
itr_vars <- list(itr_vars)
}
tibble::tibble(itr_vars = itr_vars,
...)
}) %>%
purrr::list_rbind()
}
# ensure lbls are unique
## exclude iterated lbls
dupl_lbls <- stringr::str_subset(string = data$label,
pattern = "\\{[^{].*?\\}",
negate = TRUE)
ix_dupl_lbls <- which(duplicated(dupl_lbls))
if (length(ix_dupl_lbls) > 0L) {
cli::cli_abort("Labels in column {.var label} must be unique, which the following label{?s} {?is/are} not: {.val {unique(dupl_lbls[ix_dupl_lbls])}}")
}
## ensure lbls and itr_vars congruency
has_itr_lbl <- stringr::str_detect(string = data$label,
pattern = "\\{[^{].*?\\}")
has_itr_col <- !purrr::map_lgl(data$itr_vars,
is.null)
if (any(has_itr_lbl & !has_itr_col)) {
cli::cli_abort("All {.arg data} rows with a {.arg label} to be iterated must have proper {.var itr_vars} set.")
}
data |>
purrr::pmap(\(...) {
args <- rlang::list2(...)
# interpolate chunk opts
if (!is.null(args$itr_vars)) {
if (!rlang::is_named(args$itr_vars)) {
cli::cli_abort("Elements of column {.var itr_vars} must be named lists.")
}
args %<>% purrr::map(\(arg) {
if (is.character(arg)) {
rlang::inject(cli::pluralize(arg,
!!!args$itr_vars,
.envir = env))
} else {
arg
}
})
}
fn <- switch(stringr::str_extract(string = args$label,
pattern = "^.{3}"),
fig = quarto_fig_chunk,
tbl = quarto_tbl_chunk,
cli::cli_abort("Labels must start with either {.val fig-} or {.val tbl-}."))
chunk_opts <- args[names(args) %in% methods::formalArgs(fn)]
rlang::list2(!!chunk_opts$label := rlang::inject(fn(!!!chunk_opts)))
}) |>
purrr::list_flatten()
}
#' Read in Quarto code chunk data
#'
#' Reads in a [TOML](https://toml.io/en/latest) file containing structured figure or table code chunk data, suited to be fed to [quarto_chunks()].
#'
#' @param path Path to the TOML file containing structured figure or table code chunk data. A character scalar.
#'
#' @return `r pkgsnip::return_lbl("tibble")`
#' @family quarto
#' @export
read_quarto_chunk_data <- function(path) {
pal::toml_read(input = path) |>
purrr::imap(\(val, key) {
rlang::inject(tibble::tibble(!!!val)) %>%
magrittr::set_colnames(value = stringr::str_replace_all(string = colnames(.),
pattern = "[-.]",
replacement = "_"))
}) |>
purrr::list_rbind()
}
#' Level up R
#'
#' Checks whether the installed R version is >= a cached reference version. Intended to level up the R version in use between multiple users of the same code
#' (e.g. contributors to a specific R project).
#'
#' If the file `path_min_vrsn` exists, it is checked whether the installed R version is greater than or equal to the version number stored in that file, and if
#' not, an alert is displayed.
#'
#' If `update_min_vrsn` is set to `TRUE` and the file `path_min_vrsn` doesn't exist or contains an R version string that's lower than the currently installed
#' version of R, `path_min_vrsn` is overwritten with the currently installed R version string.
#'
#' @param path_min_vrsn Path to the cached R version string.
#' @param update_min_vrsn Whether or not to overwrite `path_min_vrsn` with the currently installed R version string *iff* the latter is higher than the former.
#'
#' @return Currently installed R version as a [numeric version][as.package_version], invisibly.
#' @family dev_env
#' @export
lvl_up_r <- function(path_min_vrsn,
update_min_vrsn = FALSE) {
checkmate::assert_flag(update_min_vrsn)
if (fs::file_exists(path_min_vrsn)) {
min_vrsn <-
path_min_vrsn |>
brio::read_lines(n = 1L) |>
as.package_version()
} else {
min_vrsn <- as.package_version("0.0")
}
current_vrsn <-
R.Version() %$%
glue::glue("{major}.{minor}") |>
as.package_version()
if (isTRUE(current_vrsn < min_vrsn)) {
cli::cli_alert_warning(paste0(
"Your version of {.pkg R} is out of date. Please update to version {.val {min_vrsn}} or above. The latest stable release is available at ",
"{.url https://cloud.r-project.org/}.", pkg_mgr_hint("R")
))
}
if (update_min_vrsn && current_vrsn > min_vrsn) {
brio::write_lines(text = current_vrsn,
path = path_min_vrsn)
}
invisible(current_vrsn)
}
#' Level up RStudio
#'
#' Checks whether the currently running [RStudio](https://rstudio.com/products/rstudio/) version is >= a cached reference version. Intended to level up the
#' RStudio version in use between multiple users of the same code (e.g. contributors to a specific R project).
#'
#' If the file `path_min_vrsn` exists, it is checked whether RStudio is running, and if so, whether its version number is greater than or equal to the version
#' number stored in that file. If this is not the case, an alert is displayed.
#'
#' If `update_min_vrsn` is set to `TRUE` and the file `path_min_vrsn` doesn't exist or contains an RStudio version string that's lower than the currently
#' running version of RStudio, `path_min_vrsn` is overwritten with the currently running RStudio version string.
#'
#' Note that since **RStudio must be running for `lvl_up_rstudio()` to have any effect**, it can't be directly called in a (project-level)
#' [`.Rprofile`](https://support.rstudio.com/hc/en-us/articles/360047157094-Managing-R-with-Rprofile-Renviron-Rprofile-site-Renviron-site-rsession-conf-and-repos-conf)
#' startup script. Instead, the [`rstudio.sessionInit`](https://docs.rstudio.com/ide/server-pro/r_sessions/session_startup_scripts.html) hook can be used.
#' Example:
#'
#' ```r
#' setHook(hookName = "rstudio.sessionInit",
#' value = function(newSession) {
#' if (newSession)
#' salim::lvl_up_rstudio(path_min_vrsn = ".RStudio_version",
#' update_min_vrsn = TRUE)
#' },
#' action = "append")
#' ```
#'
#' @param path_min_vrsn Path to the cached RStudio version string.
#' @param update_min_vrsn Whether or not to overwrite `path_min_vrsn` with the currently running RStudio version string *iff* the latter is higher than the
#' former.
#'
#' @return Currently running RStudio version as a [numeric version][as.package_version], or `NULL` if RStudio is not running, invisibly.
#' @family dev_env
#' @export
lvl_up_rstudio <- function(path_min_vrsn,
update_min_vrsn = FALSE) {
checkmate::assert_flag(update_min_vrsn)
rlang::check_installed("rstudioapi",
reason = pal::reason_pkg_required())
current_vrsn <- NULL
# skip if RStudio is not running
if (rstudioapi::isAvailable()) {
if (fs::file_exists(path_min_vrsn)) {
min_vrsn <-
path_min_vrsn |>
brio::read_lines(n = 1L) |>
as.package_version()
} else {
min_vrsn <- as.package_version("0.0")
}
current_vrsn <-
rstudioapi::versionInfo() |>
purrr::chuck("version")
if (isTRUE(current_vrsn < min_vrsn)) {
cli::cli_alert_warning(paste0(
"Your version of {.pkg RStudio} is out of date. Please update to version {.val {min_vrsn}} or above. The latest version is available at ",
"{.url https://rstudio.com/products/rstudio/download/#download}.", pkg_mgr_hint("RStudio")
))
}
if (update_min_vrsn && current_vrsn > min_vrsn) {
brio::write_lines(text = current_vrsn,
path = path_min_vrsn)
}
}
invisible(current_vrsn)
}
#' Level up Quarto
#'
#' Checks whether the installed [Quarto](https://quarto.org/) version is >= a cached reference version. Intended to level up the Quarto version in use between
#' multiple users of the same code (e.g. contributors to a specific Quarto project).
#'
#' @param path_min_vrsn Path to the cached Quarto version string.
#' @param update_min_vrsn Whether or not to overwrite `path_min_vrsn` with the currently installed Quarto version string *iff* the latter is higher than the
#' former.
#'
#' @return Currently installed Quarto version as a [numeric version][numeric_version], invisibly.
#' @family dev_env
#' @export
lvl_up_quarto <- function(path_min_vrsn,
update_min_vrsn = FALSE) {
checkmate::assert_flag(update_min_vrsn)
rlang::check_installed("quarto",
reason = pal::reason_pkg_required())
if (fs::file_exists(path_min_vrsn)) {
min_vrsn <-
path_min_vrsn |>
brio::read_lines(n = 1L) |>
as.package_version()
} else {
min_vrsn <- as.package_version("0.0")
}
current_vrsn <-
quarto::quarto_path() |>
system2(args = "--version",
stdout = TRUE,
stderr = TRUE) |>
as.package_version()
if (isTRUE(current_vrsn < min_vrsn)) {
cli::cli_alert_warning(paste0(
"Your version of {.pkg Quarto} is out of date. Please update to version {.val {min_vrsn}} or above. The latest stable release is available at ",
"{.url https://quarto.org/docs/get-started/}.", pkg_mgr_hint("Quarto")
))
}
if (update_min_vrsn && current_vrsn > min_vrsn) {
brio::write_lines(text = current_vrsn,
path = path_min_vrsn)
}
invisible(current_vrsn)
}
#' Update R packages from rpkg.dev
#'
#' Installs/updates \R packages from [rpkg.dev](https://gitlab.com/rpkg.dev) to the latest (development) version.
#'
#' @param pkgs R pkgs to be updated. A subset of:
#' `r pal::fn_param_defaults(fn = "update_rpkgs", param = "pkgs") |> pal::wrap_chr("\x60") |> pal::as_md_list()`
#' @param from_cran Whether or not to install `pkgs` from a [CRAN](https://en.wikipedia.org/wiki/R_package#Comprehensive_R_Archive_Network_(CRAN)) repository
#' if possible. The repository URLs set in the [`repos`][options] \R option are used by default, with fallback to `https://cloud.r-project.org/`. If `FALSE`,
#' the latest *development* versions are always installed, regardless of whether `pkgs` are available on CRAN or not.
#'
#' @return `pkgs`, invisibly.
#' @family dev_env
#' @export
update_rpkgs <- function(pkgs = c("pal",
"pkgpins",
"pkgpurl",
"pkgsnip",
"plotlee",
"qstnr",
"rstd",
"swissmuni",
"tocr",
"yay"),
from_cran = FALSE) {
rlang::check_installed("remotes",
reason = pal::reason_pkg_required())
pkgs <- rlang::arg_match(pkgs,
multiple = TRUE)
purrr::walk(pkgs,
\(x) {
if (pal::is_pkg_cran(x)) {
utils::install.packages(pkgs = x,
repos = getOption("repos",
default = "https://cloud.r-project.org/"))
} else {
remotes::install_gitlab(repo = paste0("rpkg.dev/", x), # nolint: paste_linter
upgrade = FALSE)
}
})
invisible(pkgs)
}
#' Update Salim B's R packages
#'
#' Installs/updates all of [Salim B's R packages](https://gitlab.com/salim_b/r/pkgs) to the latest (development) version.
#'
#' @inheritParams update_rpkgs
#' @param pkgs R pkgs to be updated. A subset of:
#' `r pal::fn_param_defaults(fn = "update_salims_pkgs", param = "pkgs") |> pal::wrap_chr("\x60") |> pal::as_md_list()`
#'
#' @return `pkgs`, invisibly.
#' @family dev_env
#' @export
update_salims_pkgs <- function(pkgs = c("salim",
"swissparty"),
from_cran = FALSE) {
rlang::check_installed("remotes",
reason = pal::reason_pkg_required())
pkgs <- rlang::arg_match(pkgs,
multiple = TRUE)
purrr::walk(pkgs,
\(x) {
if (pal::is_pkg_cran(x)) {
utils::install.packages(pkgs = x,
repos = getOption("repos",
default = "https://cloud.r-project.org/"))
} else {
remotes::install_gitlab(repo = paste0("salim_b/r/pkgs/", x), # nolint: paste_linter
upgrade = FALSE)
}
})
invisible(pkgs)
}
#' Update R packages from the Centre for Democracy Studies Aarau (ZDA)
#'
#' Installs/updates all of the [R packages from the Centre for Democracy Studies Aarau (ZDA)](https://gitlab.com/zdaarau/rpkgs) to the latest (development)
#' version.
#'
#' @inheritParams update_rpkgs
#' @param pkgs R pkgs to be updated. A subset of:
#' `r pal::fn_param_defaults(fn = "update_zdaarau_pkgs", param = "pkgs") |> pal::wrap_chr("\x60") |> pal::as_md_list()`
#'
#' @return `pkgs`, invisibly.
#' @family dev_env
#' @export
update_zdaarau_pkgs <- function(pkgs = c("rdb.report",
"fokus",
"rdb",
"swissevote"),
from_cran = FALSE) {
rlang::check_installed("remotes",
reason = pal::reason_pkg_required())
pkgs <- rlang::arg_match(pkgs,
multiple = TRUE)
checkmate::assert_flag(from_cran)
purrr::walk(pkgs,
\(x) {
if (from_cran && pal::is_pkg_cran(x)) {
utils::install.packages(pkgs = x,
repos = getOption("repos",
default = "https://cloud.r-project.org/"))
} else {
remotes::install_gitlab(repo = paste0("zdaarau/rpkgs/", x), # nolint: paste_linter
upgrade = FALSE)
}
})
invisible(pkgs)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.