Nothing
#' check if `potions` data exists already, and if not create it
#' @return an object of class `potions`
#' @keywords internal
#' @noRd
check_potions_storage <- function(){
current_list <- getOption("potions-pkg")
if(is.null(current_list)){
current_list <- create_potions()
}
return(current_list)
}
#' simple character check
#' @importFrom rlang abort
#' @keywords internal
#' @noRd
check_is_character <- function(x){
if(!inherits(x, "character")){
abort("Non-character value supplied")
}
}
#' simple length check
#' @importFrom rlang abort
#' @keywords internal
#' @noRd
check_length_one <- function(x){
if(length(x) > 1){abort("Argument of length-1 expected")}
}
#' simple filename check
#' @importFrom rlang abort
#' @keywords internal
#' @noRd
check_file <- function(x){
check_is_character(x)
check_length_one(x)
if(!file.exists(x)){
abort("File not found")
}
}
#' returns random slot name if one is not provided
#'
#' Note this is only called by `brew_interactive()`, meaning that case for
#' `.pkg` does not need to be checked.
#' @importFrom stringi stri_rand_strings
#' @keywords internal
#' @noRd
check_slot_name <- function(x){
if(missing(x)){
current_list <- getOption("potions-pkg")
if(is.null(current_list)){
result <- stri_rand_strings(n = 1, length = 10)
}else{
current_slot <- current_list$mapping$current_slot
if(is.null(current_slot)){
result <- stri_rand_strings(n = 1, length = 10)
}else{
result <- current_slot
}
}
}else{
result <- x
}
check_is_character(result) # for case where .slot is given, but is not a character
check_length_one(result)
return(result)
}
#' Is `potions` being called from within a package?
#'
#' At the point that `pour()` is called, this function will determine whether
#' the call is coming from within another package. If so, then this function
#' will flag TRUE, and `pour()` will call from
#' `getOption("potions-pkg")$packages[[data$mapping$packages]]`,
#' rather than the default for the interactive sessions which is
#' `getOption("potions-pkg")$slots[[data$mapping$current_slot]]`.
#' @param pkg A package name (string)
#' @param trace result from `rlang::trace_back()`
#' @keywords internal
#' @noRd
check_within_pkg <- function(trace){
data <- getOption("potions-pkg")
result <- list(within = FALSE)
if(!is.null(data)){ # data have been added
if(!is.null(data$mapping$packages)){ # names have been added to data$mapping$packages (usually by onLoad)
next_pkg <- rev(trace[trace != "potions"])[1] # get package above `potions` in `trace_back()`
# browser()
if(
length(next_pkg) > 0 && !is.na(next_pkg) # some package name exists that isn't NA
# i.e. you ARE within another package
){
if(any(data$mapping$packages == next_pkg)){ # i.e. the package you believe you are in has been registered with `potions`
result <- list(within = TRUE, pkg = next_pkg)
}
}
}
}
return(result)
}
#' Function used in `brew` to decide which .slot to use
#'
#' Note that by the point this function has been called, `check_within_pkg()`
#' has already returned `FALSE`. Ergo this should never return `.pkg` as an
#' option
#' @return a `list` with up to two entries
#' @keywords internal
#' @noRd
check_existing_slots <- function(){
lookup <- getOption("potions-pkg")
if(is.null(lookup)){
return(list(method = "all_empty"))
}else{
if(!is.null(lookup$mapping$current_slot)){
return(list(method = ".slot",
value = lookup$mapping$current_slot))
}else{
return(list(method = "all_empty")) # passes to .slot with random name
}
}
}
## NOTES on above logic
# x <- rev(trace_back()$namespace) # returns tree going upwards
# you can then see whether x[-1] (or x[x != "potions"])includes any of the package names stored in
# getOption("potions-package")[["mapping"]][["packages"]]
## AND sessionInfo(package = pkg_name) returns something sensible # NOTE: errors when missing
# if this is the case, then you are within a package and the default should be
# pour(pkg = "slot_name")
## note that in this case, pour() will default to package name, and index within it
# you will therefore need to add attr(x, "pkg") <- slot_name for clarity and debugging reasons
#' internal checks for `pour_package`
#' @importFrom rlang abort
#' @keywords internal
#' @noRd
check_pour_package <- function(.pkg){
# ensure a package name is given
if(missing(.pkg)){
abort("Argument `.pkg` is missing, with no default")
}
# check any data has been provided
all_data <- getOption("potions-pkg")
if(is.null(all_data)){
bullets <- c("No data stored by `potions`",
i = "try using `brew()")
abort(bullets)
}else{
# check package has been listed as having data
if(!any(all_data$mapping$packages == .pkg)){
abort(paste0("No data stored for package ", .pkg))
}else{
return(all_data$packages[[.pkg]])
}
}
}
#' Internal checks for `pour_interactive`
#'
#' Note that - unlike packages - slots can be set to run on default only. This
#' means that .slot is not always required
#' @importFrom rlang abort
#' @importFrom rlang inform
#' @importFrom purrr pluck
#' @keywords internal
#' @noRd
check_pour_interactive <- function(.slot){
# check any data has been provided
all_data <- getOption("potions-pkg")
if(is.null(all_data)){
bullets <- c("No data stored by `potions`",
i = "try using `brew()")
abort(bullets)
}else{
if(missing(.slot)){
if(length(all_data$slots) > 1){
if(any(names(all_data$slots) == all_data$mapping$current_slot)){
slot_name <- pluck(all_data, !!!list("mapping", "current_slot"))
pluck(all_data, !!!c("slots", slot_name))
}else{
bullets <- c("Multiple slots available, but `current_slot` is not named",
i = "please specify `.slot` to continue")
abort(bullets)
}
}else if(length(all_data$slots) == 1L){
return(all_data$slots[[1]])
}else{
bullets <- c("No data stored by `potions` using interactive mode",
i = "try using `brew()`")
inform(bullets)
return(NULL)
}
}else{ # i.e. `.slot` is given
if(any(names(all_data$slots) == .slot)){
return(all_data$slots[[.slot]])
}else{
bullets <- c("Named .slot is not stored by `potions`",
i = "please specify a valid `.slot` to continue")
abort(bullets)
}
}
}
}
#' check data provided to `potions`
#'
#' This function takes supplied `data` (typically a `list`) and `file` (a file
#' path, given as a string), and integrates them into a single `list`. It is
#' called by both `brew_package` and `brew_interactive`.
#' @importFrom purrr list_modify
#' @importFrom rlang abort
#' @keywords internal
#' @noRd
check_potions_data <- function(data, file){
if(length(data) > 0){
# first check whether dots were supplied as a list
# prevents case where `brew(list(x = 1))` returns `list(list(x = 1))`
if(length(data) == 1L && inherits(data[[1]], "list")){
data <- data[[1]]
}
## check for files, and if given, append
if(!missing(file)){
check_file(file)
x <- read_config(file)
data <- list_modify(data, x) # note priority given to x
}
# check whether all levels are named, and if not, abort
check_missing_names(data)
return(data)
}else{
return(NULL)
# abort("No data supplied to `brew()`")
}
}
#' code for checking for missing names
#' @importFrom rlang abort
#' @importFrom rrapply rrapply
#' @keywords internal
#' @noRd
check_missing_names <- function(x){
names_df <- rrapply(x, how = "melt")
names_df <- names_df[, grepl("^L[[:digit:]]{1,2}$", colnames(names_df)),
drop = FALSE]
# in the above, internal missing names are always either "" or "1"
result <- apply(names_df, 1, function(a){
any(nchar(a) < 1 | grepl("^[[:digit:]]{1,}$", a), na.rm = TRUE)})
# error if required
if(any(result)){
abort(c("Supplied lists contains entries with missing names",
i = "All entries to `brew()` must be named"))
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.