# drop_null --------------------------------------------------------------------
drop_null <- function(x) {
x[lengths(x) != 0]
}
# get_root_path ----------------------------------------------------------------
get_root_path <- function(pkg) {
if (is_installed(pkg)) {
find.package(pkg)
} else if (is_package(file.path(pkg))) {
pkg
} else if (is.character(pkg)) {
pkg # use pkg as guess anyway
# } else {
#
# "." # stick with default
}
}
# package_file -----------------------------------------------------------------
# Just a shortcut to system.file(..., package = pkg)
package_file <- function(pkg, ...) {
system.file(..., package = pkg)
}
# is_installed: is the package installed -------------------------
is_installed <- function(pkg) {
length(
find.package(
package = pkg,
quiet = TRUE
)
) > 0
}
# get_file ---------------------------------------------------------------------
## Like system.file, but pkg can instead be path to package root directory
get_file <- function(FILE, pkg = ".") {
path <- file.path(pkg, FILE)
if (file.exists(path)) {
path
} else {
package_file(pkg, FILE)
}
}
# is_IRI -----------------------------------------------------------------------
is_IRI <- function(string) {
## FIXME IRI can be many other things too,
#see https://github.com/dgerber/rfc3987 for more formal implementation
grepl("^http[s]?://", string)
}
# uses_git ---------------------------------------------------------------------
# from usethis cf https://github.com/r-lib/usethis/blob/2abb0422a97808cc573fa5900a8efcfed4c2d5b4/R/git.R#L68
# this is GPL-3 code
# now with gert not git2r
uses_git <- function(path) {
!is.null(tryCatch(gert::git_find(path), error = function(e){NULL}))
}
# get_url_status_code ----------------------------------------------------------
get_url_status_code <- function(url) {
if (is.null(url) || is.na(url)) {
return(NULL)
}
result <- try(crul::HttpClient$new(url)$get(), silent = TRUE)
message <- if (inherits(result,'try-error')) {
"No connection was possible"
} else if ((code <- result$status_code) == 200) {
"All good"
} else {
paste("Error code:", code)
}
data.frame(message = message, url = url)
}
# check_urls -------------------------------------------------------------------
check_urls <- function(urls) {
if (!pingr::is_online()) {
return("")
}
messages <- do.call(rbind, lapply(urls, get_url_status_code))
failed <- (messages$message != "All good")
if (any(failed)) {
paste("Problematic URLs\n", apply(messages[failed, ], 1, toString))
} else {
""
}
}
# whether_provider_badge -------------------------------------------------------
whether_provider_badge <- function(badges, provider_name) {
! is.null(provider_name) && (
(
provider_name == "Comprehensive R Archive Network (CRAN)" &&
any(grepl("CRAN", badges$text))
) || (
provider_name == "BioConductor" &&
any(grepl("bioconductor", badges$link))
)
)
}
# dot_to_package: convert pkg = "." to proper package path ------------------
dot_to_package <- function(pkg = ".") {
# https://github.com/r-lib/rprojroot/blob/master/R/root.R#L115:
.max_depth <- 10L
files <- c("DESCRIPTION", "NAMESPACE", "man", "R")
if (pkg == "." | !all(files %in% list.files(pkg))) {
pkg <- normalizePath(pkg)
if (!all(files %in% list.files(pkg))) {
for (i in seq_len(.max_depth)) {
pkg <- normalizePath(file.path(pkg, ".."))
if (all(files %in% list.files(pkg)))
return(pkg)
}
}
}
if (!all(files %in% list.files(pkg)))
stop("Unable to find root directory of an R package")
return(pkg)
}
# is_package: helper to find whether a path is a package project ---------------
is_package <- function(path) {
all(c("DESCRIPTION", "NAMESPACE", "man", "R") %in% dir(path))
}
# set_element ----------------------------------------------
set_element <- function(x, element, value) {
stopifnot(is.list(x))
x[[element]] <- value
x
}
# fails ------------------------------------------------------------------------
#' Does the Evaluation of an Expression Fail?
#'
#' @param expr expression to be evaluated within `try(\dots)`
#' @param silent passed to [try()], see there.
#' @return `TRUE` if evaluating `expr` failed and `FALSE` if
#' the evalutation of `expr` succeeded.
#' @noRd
fails <- function(expr, silent = TRUE) {
inherits(try(expr, silent = silent), "try-error")
}
# example_file -----------------------------------------------------------------
example_file <- function(...) {
package_file("codemetar", "examples", ...)
}
#' Check for Class "json" or Character
#'
#' @param x object to be checked for its class and mode
#' @return `TRUE` if `x` inherits from "json" or is of mode character,
#' otherwise `FALSE`
#' @noRd
is_json_or_character <- function(x) {
is(x, "json") || is.character(x)
}
# to_json_if -------------------------------------------------------------------
#' Convert to JSON if Condition is Met
#'
#' @param condition expression to be evaluated
#' @param x object to be converted to JSON
#' @param \dots further arguments passed to [jsonlite::toJSON()]
#' @importFrom jsonlite toJSON
#' @noRd
to_json_if <- function(condition, x, ...) {
call_if(condition, x, FUN = jsonlite::toJSON, ...)
}
# from_json_if -----------------------------------------------------------------
#' Convert from JSON if Condition is Met
#'
#' @param condition expression to be evaluated
#' @param x object passed to [jsonlite::fromJSON()] if
#' `condition` is met
#' @param \dots further arguments passed to [jsonlite::fromJSON()]
#' @importFrom jsonlite fromJSON
#' @noRd
from_json_if <- function(condition, x, ...) {
call_if(condition, x, jsonlite::fromJSON, ...)
}
# call_if ----------------------------------------------------------------------
#' Call Function if Condition is Met
#'
#' @param condition expression to be evaluated
#' @param FUN function to be called if `condition` is met
#' @param x first argument to be passed to `FUN` or not
#' @param \dots further arguments passed to `FUN`
#' @noRd
call_if <- function(condition, x, FUN, ...) {
if (condition) {
FUN(x, ...)
} else {
x
}
}
# bind df -----------------------
bind_df <- function(dfs) {
do.call("rbind", dfs)
}
# df -----------------------
df <- function(...) {
data.frame(
...,
stringsAsFactors = FALSE
)
}
# use_build_ignore -----------------------
# Adapted from https://github.com/r-lib/usethis/blob/85327feeec22ab2f6f46efcd2d3d0a4b010f132b/R/ignore.R#L23
use_build_ignore <- function(thing, path) {
thing <- escape_path(thing)
write_union(
file.path(
path,
".Rbuildignore"
),
thing
)
}
# write_union --------------------
# from https://github.com/r-lib/usethis/blob/368714a4f487dce4719ac8a002383d719f73cd64/R/write.R#L45
write_union <- function(path, lines) {
if (file.exists(path)) {
existing_lines <- readLines(path, encoding = "UTF-8", warn = FALSE)
} else {
existing_lines <- character()
}
new <- setdiff(lines, existing_lines)
if (length(new) == 0) {
return(invisible(FALSE))
}
all <- c(existing_lines, new)
base::writeLines(
all,
con = path,
useBytes = TRUE
)
}
# escape_path ------------------
# from https://github.com/r-lib/usethis/blob/85327feeec22ab2f6f46efcd2d3d0a4b010f132b/R/ignore.R#L31
escape_path <- function(x) {
x <- gsub("\\.", "\\\\.", x)
x <- gsub("/$", "", x)
paste0("^", x, "$")
}
# clean_str -----------------------
clean_str <- function(str) {
# Collapse to single char
str <- paste(str, collapse = " ")
if (length(str) == 0 || is.null(str) || is.na(str) ||
str == "NA") {
return(NULL)
}
clean <- gsub("[\n\r]", " ", str)
clean <- gsub("\\s+", " ", clean)
clean <- gsub("\\s+", " ", clean)
clean <- gsub("\\{", "", clean)
clean <- gsub("\\}", "", clean)
# Collapse to single char
clean <- paste(clean, collapse = " ")
if (clean == "") {
return(NULL)
}
clean
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.