R CMD check
NOTES about undefined global objectscf. https://github.com/tidyverse/magrittr/issues/29#issuecomment-74313262.
utils::globalVariables(names = c(".", # other "download_url", "filename", "id", "name", "version_nr"))
pkg_mgr_hint
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
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
DEPRECATED: stringi::stri_datetime_format(format = c("date_short", "date_medium", "date_long", "date_full"), locale = "de-CH")
is superior in every regard!
TODO:
salim::prettify_date(ballot_date, locale = 'de')
, it results in
October 18, 2020
, i.e. doesn't even use the proper format string.NOTES:
Relevant SO question: What is a reliable way of getting allowed locale names in R?
Base R's conversion specifiers like %Y
are documented in ?strptime
.
#' 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
DEPRECATED, see above.
#' 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))) }
rank_nr
#' 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_n
Caveats:
German is only covered from 0 to 9.
No support for grammatical gender -- articles of definite descriptors are always feminine.
#' 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 }
n_ify
#' 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")) }
definite_article_de
#' 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")) } }
definite_article_de_declined
#' 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_definite_article_de
#' 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_noun_de
NOTES:
noun
to be declined in "indefinite" nominative, i.e. e.g. "weisser Mann", not "weisse Mann".#' 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 }
regex_spelling_normalization
#' 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"
TODO: Move these fns to dedicated pkg pndc? Then the pandoc templates at gitlab.com/salim_b/pandoc/templates should be moved inside the pndc pkg repo, but build-ignored.
download_pandoc_binaries
#' 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) }
pandoc_release_assets
#' 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() }
pandoc_tpl
#' 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()) }
ggplot2_geom_defaults
#' 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)) } }
ggplot2_theme
NOTES:
The roxygen2 documentation of certain params like axis.title*
or legend.spacing*
can't be inherited since they are documented in groups, i.e. in single
@param
tag per group upstream and roxygen2 only matches inherited param doc by the
complete param sequence, i.e. has no proper support for this usecase.
The latest upstream documentation for these param sets can be retrieved via:
``` r yay::gh_text_file(path = "R/theme.R", owner = "tidyverse", name = "ggplot2") |> pal::roxy_blocks(text = _) |> pal::roxy_tag_value(obj_name = "theme", tag_names = "param", param_name = "axis.title,axis.title.x,axis.title.y,axis.title.x.top,axis.title.x.bottom,axis.title.y.left,axis.title.y.right") |> cat()
yay::gh_text_file(path = "R/theme.R", owner = "tidyverse", name = "ggplot2") |> pal::roxy_blocks(text = _) |> pal::roxy_tag_value(obj_name = "theme", tag_names = "param", param_name = "axis.text,axis.text.x,axis.text.y,axis.text.x.top,axis.text.x.bottom,axis.text.y.left,axis.text.y.right,axis.text.theta,axis.text.r") |> cat()
yay::gh_text_file(path = "R/theme.R", owner = "tidyverse", name = "ggplot2") |> pal::roxy_blocks(text = _) |> pal::roxy_tag_value(obj_name = "theme", tag_names = "param", param_name = "legend.spacing,legend.spacing.x,legend.spacing.y") |> cat() ```
#' 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
ggplot2_theme_html
NOTES:
ggplot2::theme_minimal()
already makes plot background transparent. The explicit way to make plot background transparent would be
r
ggplot2::theme(panel.background = ggplot2::element_rect(fill = "transparent",
color = NA_character_), # needed to avoid black panel outline
plot.background = ggplot2::element_rect(fill = "transparent",
color = NA_character_), # needed to avoid black plot outline
legend.background = ggplot2::element_rect(fill = "transparent"),
legend.box.background = ggplot2::element_rect(fill = "transparent"),
legend.key = ggplot2::element_rect(fill = "transparent"))
But either way, the image exported via printing the plot in a knitr code chunk of a Quarto document does not have a transparent but a white background. 😑
Thus we need to explicitly set the background color .color_bg
.
#' 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 }
plotly_layout
#' 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, ...) }
lvl_up_r
#' 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) }
lvl_up_rstudio
#' 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) }
lvl_up_quarto
#' 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_rpkgs
#' 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_salims_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_zdaarau_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.