# 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"))
pkg_mgr_hint <- function(software = names(pkg_mgr_software)) {
software <- rlang::arg_match(software)
result <- ""
if (checkmate::test_os(os = "mac")) {
result %<>% paste0(pkg_mgr_prose(software = software,
pkg_mgrs = "brew"))
} else if (checkmate::test_os(os = "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 ", ., "."),
~ "")
}
this_pkg <- utils::packageName()
#' 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 `prettify_date()` 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 `prettify_datetime()` 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 the specified Pandoc release.
#'
#' @inheritParams pandoc_release_assets
#' @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`.
#'
#' @return `path` invisibly.
#' @family pandoc
#' @seealso GitHub release functions: [yay::gh_releases()], [yay::gh_release_latest()]
#' @export
download_pandoc_binaries <- function(release_id = yay::gh_release_latest(owner = "jgm",
name = "pandoc")$id,
os = c("linux", "macos", "windows"),
path = "bin/",
overwrite = TRUE) {
rlang::check_installed("yay",
reason = pal::reason_pkg_required())
rlang::check_installed("waldo",
reason = pal::reason_pkg_required())
checkmate::assert_subset(os,
choices = eval(formals()$os),
empty.ok = FALSE)
checkmate::assert_path_for_output(path,
overwrite = TRUE)
checkmate::assert_flag(overwrite)
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)
}
#' 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 identifier of the desired Pandoc release. Use
#' [`yay::gh_releases(owner = "jgm", name = "pandoc")`][yay::gh_releases] to determine the release identifier of a specific Pandoc version number. An
#' integer scalar.
#'
#' @return `r pkgsnip::param_lbl("tibble")`
#' @family pandoc
#' @seealso GitHub release functions: [yay::gh_releases()], [yay::gh_release_latest()]
#' @export
pandoc_release_assets <- function(release_id = yay::gh_release_latest(owner = "jgm",
name = "pandoc")$id) {
rlang::check_installed("yay",
reason = pal::reason_pkg_required())
rlang::check_installed("gh",
reason = pal::reason_pkg_required())
checkmate::assert_count(release_id,
positive = TRUE)
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())
}
#' Set common ggplot2 geom defaults
#'
#' Sets common ggplot2 geom default settings (currently only font `family`). Convenience wrapper around [ggplot2::update_geom_defaults()].
#'
#' Note that `ggplot2_geom_defaults()` must be invoked *before* plots are created to have any effect.
#'
#' @param family Font family to use in text geoms.
#'
#' @return `NULL`, invisibly.
#' @family plot_theme
#' @export
ggplot2_geom_defaults <- function(family) {
rlang::check_installed("ggplot2",
reason = pal::reason_pkg_required())
ggplot2::update_geom_defaults(geom = "text",
new = list(family = family))
if (pal::is_pkg_installed(pkg = "ggrepel")) {
ggplot2::update_geom_defaults(geom = ggrepel::GeomTextRepel,
new = list(family = family))
}
}
#' Apply common theme to ggplot2 chart
#'
#' Applies common [theming][ggplot2::theme] to a [ggplot2][ggplot2::ggplot2-package] chart. It's based on [ggplot2::theme_minimal()].
#'
#' @inheritParams ggplot2::theme_minimal
#' @inheritParams ggplot2::theme
#' @param axis.title.x,axis.title.y Labels of axes ([ggplot2::element_text()]). Specify all axes' labels (`axis.title`), labels by plane (using `axis.title.x`
#' or `axis.title.y`), or individually for each axis (using `axis.title.x.bottom`, `axis.title.x.top`, `axis.title.y.left`, `axis.title.y.right`).
#' `axis.title.*.*` inherits from `axis.title.*` which inherits from `axis.title`, which in turn inherits from `text`.
#' @param axis.text Tick labels along axes ([ggplot2::element_text()]). Specify all axis tick labels (`axis.text`), tick labels by plane (using `axis.text.x` or
#' `axis.text.y`), or individually for each axis (using `axis.text.x.bottom`, `axis.text.x.top`, `axis.text.y.left`, `axis.text.y.right`). `axis.text.*.*`
#' inherits from `axis.text.*` which inherits from `axis.text`, which in turn inherits from `text`.
#' @param legend.spacing Spacing between legends (`unit`). `legend.spacing.x` & `legend.spacing.y` inherit from `legend.spacing` or can be specified separately.
#' @param ... Further arguments passed on to [ggplot2::theme()].
#'
#' @return An object of class [`theme`][ggplot2::theme].
#' @family plot_theme
#' @export
#'
#' @examples
#' sysfonts::font_add_google(name = "Alegreya Sans")
#' showtext::showtext_auto()
#'
#' ggplot2::ggplot(data = mtcars,
#' mapping = ggplot2::aes(x = mpg,
#' y = cyl)) +
#' ggplot2::geom_point() +
#' salim::ggplot2_theme(base_size = 12)
# nolint start: object_name_linter.
ggplot2_theme <- function(base_size = 11L,
base_family = pal::pkg_config_val(key = "font_family_body",
pkg = this_pkg),
base_line_size = base_size / 22L,
base_rect_size = base_size / 22L,
axis.title.x = ggplot2::element_text(margin = ggplot2::margin(t = 20L, r = 0L, b = 0L, l = 0L),
inherit.blank = TRUE),
axis.title.y = ggplot2::element_text(margin = ggplot2::margin(t = 0L, r = 20L, b = 0L, l = 0L),
inherit.blank = TRUE),
axis.text = ggplot2::element_text(color = "#000",
inherit.blank = TRUE),
legend.box.margin = ggplot2::margin(),
legend.box.spacing = ggplot2::element_blank(),
legend.margin = ggplot2::margin(),
legend.position = "bottom",
legend.spacing = grid::unit(x = 0.0,
units = "npc"),
plot.margin = ggplot2::margin(),
...) {
rlang::check_installed("ggplot2",
reason = pal::reason_pkg_required())
ggplot2::theme_minimal(base_size = base_size,
base_family = base_family,
base_line_size = base_line_size,
base_rect_size = base_rect_size) +
ggplot2::theme(axis.title.x = axis.title.x,
axis.title.y = axis.title.y,
axis.text = axis.text,
legend.box.margin = legend.box.margin,
legend.box.spacing = legend.box.spacing,
legend.margin = legend.margin,
legend.position = legend.position,
legend.spacing = legend.spacing,
plot.margin = plot.margin,
...)
}
# nolint end
#' Add common HTML-specific theme to ggplot2 chart
#'
#' Dynamically adds common HTML-specific [theming][ggplot2::theme] to a [ggplot2][ggplot2::ggplot2-package] chart. It depends on the current [knitr output
#' format][knitr::pandoc_to] whether the additional HTML-specific theming is actually added or not.
#'
#' Note that `ggplot2_theme_html()` must be evaluated *during* [knitting][knitr::knit] to work properly.
#'
#' @param .color_text Text color to use for all text elements ([ggplot2::element_text()]) when the knitr output format [is HTML][knitr::is_html_output()].
#' @param .color_bg Background color to use when the knitr output format [is HTML][knitr::is_html_output()].
#' @param .color_grid Grid color to use when the knitr output format [is HTML][knitr::is_html_output()].
#' @param ... Further arguments passed on to [ggplot2::theme()] when the knitr output format [is HTML][knitr::is_html_output()].
#'
#' @return An object of class [`theme`][ggplot2::theme].
#' @family plot_theme
#' @export
#'
#' @examples
#' sysfonts::font_add_google(name = "Alegreya Sans")
#' showtext::showtext_auto()
#'
#' ggplot2::ggplot(data = mtcars,
#' mapping = ggplot2::aes(x = mpg,
#' y = cyl)) +
#' ggplot2::geom_point() +
#' salim::ggplot2_theme() +
#' salim::ggplot2_theme_html()
ggplot2_theme_html <- function(.color_text = pal::pkg_config_val(key = "plot_color_body",
pkg = this_pkg),
.color_bg = pal::pkg_config_val(key = "plot_color_bg",
pkg = this_pkg),
.color_grid = pal::pkg_config_val(key = "plot_color_grid",
pkg = this_pkg),
...) {
checkmate::assert_string(.color_text)
checkmate::assert_string(.color_bg)
checkmate::assert_string(.color_grid)
rlang::check_installed("ggplot2",
reason = pal::reason_pkg_required())
rlang::check_installed("knitr",
reason = pal::reason_pkg_required())
result <- ggplot2::theme()
if (knitr::is_html_output()) {
result <- result + ggplot2::theme(line = ggplot2::element_line(color = .color_text,
inherit.blank = TRUE),
rect = ggplot2::element_rect(color = .color_text,
inherit.blank = TRUE),
text = ggplot2::element_text(color = .color_text,
inherit.blank = TRUE),
axis.text = ggplot2::element_text(color = .color_text,
inherit.blank = TRUE),
legend.background = ggplot2::element_rect(fill = .color_bg,
color = NA_character_),
legend.box.background = ggplot2::element_rect(fill = .color_bg,
color = NA_character_),
legend.key = ggplot2::element_rect(fill = .color_bg,
color = NA_character_),
panel.background = ggplot2::element_rect(fill = .color_bg,
color = NA_character_),
panel.grid = ggplot2::element_line(color = .color_grid),
plot.background = ggplot2::element_rect(fill = .color_bg,
color = NA_character_),
...)
}
result
}
#' Apply common layout to Plotly chart
#'
#' Applies common [layout][plotly::layout] configuration to a [Plotly][plotly::plot_ly] chart.
#'
#' @inheritParams plotlee::simplify_trace_ids
#' @param font [Global font](https://plotly.com/r/reference/layout/#layout-font). Fonts used in traces and other layout components inherit from the global font.
#' @param paper_bgcolor [Background color of the paper](https://plotly.com/r/reference/layout/#layout-paper_bgcolor) where the graph is drawn.
#' @param plot_bgcolor [Background color of the plotting area](https://plotly.com/r/reference/layout/#layout-plot_bgcolor) in-between x and y axes.
#' @param xaxis [X-axis configuration](https://plotly.com/r/reference/layout/#layout-xaxis).
#' @param yaxis [Y-axis configuration](https://plotly.com/r/reference/layout/#layout-yaxis).
#' @param ... Further [layout configuration](https://plotly.com/r/reference/layout/) arguments.
#'
#' @return `r pkgsnip::return_lbl("plotly_obj")`
#' @family plot_theme
#' @export
#'
#' @examples
#' plotly::plot_ly(data = mtcars,
#' type = "bar",
#' x = ~mpg) |>
#' salim::plotly_layout(font = list(color = pal::pkg_config_val(key = "plot_color_body",
#' pkg = "salim")))
plotly_layout <- function(p,
font = list(color = pal::pkg_config_val(key = "plot_color_body",
pkg = this_pkg),
family = pal::pkg_config_val(key = "font_family_body",
pkg = this_pkg)),
paper_bgcolor = pal::pkg_config_val(key = "plot_color_bg",
pkg = this_pkg),
plot_bgcolor = paper_bgcolor,
xaxis = list(gridcolor = pal::pkg_config_val(key = "plot_color_grid",
pkg = this_pkg)),
yaxis = list(gridcolor = pal::pkg_config_val(key = "plot_color_grid",
pkg = this_pkg)),
...) {
rlang::check_installed("plotly",
reason = pal::reason_pkg_required())
plotly::layout(p = p,
font = font,
paper_bgcolor = paper_bgcolor,
plot_bgcolor = plot_bgcolor,
xaxis = xaxis,
yaxis = yaxis,
...)
}
#' 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://posit.co/download/rstudio-desktop/}.", 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("nocodb",
"pal",
"pkgdown.tpl",
"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.