Nothing
#' Storage R6 Object
#'
#' @description
#' Provides a simple indexing interface for list elements based on R6.
#' Basically, it allows to store items in a list and to regain them based on
#' identifiers defined by the user.
#'
#' @section Setting identifiers:
#' An identifier is a \code{character}, typically a binary property. Identifiers
#' can be negated by placing an exclamation mark (\code{"!"}) in front of them.
#' Identifiers that have been assigned to other elements previously do not need
#' to be specified again for new elements; instead, a default value can be used.
#' This default value can be defined either globally for all cases (via the
#' \code{$missing_identifier} field) or separately for each specific case (via
#' the method argument).
#'
#' @section User confirmation:
#' If desired, the user can be asked for confirmation when adding, extracting,
#' or removing elements using identifiers. This behavior can be set globally
#' through the \code{$confirm} field or customized separately for each specific
#' case via the method argument.
#'
#' @param identifier \[`character()`\]\cr
#' Pne or more identifiers (the identifier \code{"all"} is reserved to select
#' all elements).
#'
#' @param ids \[`integer()`\]\cr
#' One or more ids.
#'
#' @param logical \[`character(1)`\]\cr
#' In the case that multiple identifiers are selected, how should they be
#' combined? Options are:
#' - \code{"and"} (the default): the identifiers are combined with logical and
#' (all identifiers must be `TRUE`)
#' - \code{"or"}: the identifiers are combined with logical or (at least one
#' identifier must be `TRUE`)
#'
#' @param confirm \[`logical(1)`\]\cr
#' Prompted for confirmation?
#'
#' @param missing_identifier \[`logical(1)` | NA\]\cr
#' The value for not specified identifiers.
#'
#' @return
#' The output depends on the method:
#' - \code{$new()} returns a \code{Storage} object.
#' - \code{$add()}, \code{$remove()}, and \code{$print()} invisibly return the
#' \code{Storage} object (to allow for method chaining)
#' - \code{$get()} returns the requested element(s)
#' - \code{$number()} returns an \code{integer}
#' - \code{$indices()} return an \code{integer} \code{vector}
#'
#' @keywords indexing
#' @family package helpers
#' @export
#'
#' @examples
#' ### 1. Create a `Storage` object:
#' my_storage <- Storage$new()
#'
#' # 2. Add elements along with identifiers:
#' my_storage$
#' add(42, c("number", "rational"))$
#' add(pi, c("number", "!rational"))$
#' add("fear of black cats", c("text", "!rational"))$
#' add("wearing a seat belt", c("text", "rational"))$
#' add(mean, "function")
#'
#' # 3. What elements are stored?
#' print(my_storage)
#'
#' # 4. Extract elements based on identifiers:
#' my_storage$get("rational")
#' my_storage$get("!rational")
#' my_storage$get(c("text", "!rational"))
#' my_storage$get("all") # get all elements
#' my_storage$get(c("text", "!text"))
#' my_storage$get(c("text", "!text"), logical = "or")
#'
#' # 5. Extract elements based on ids:
#' my_storage$get(ids = 4:5)
#' my_storage$get(ids = 4:5, id_names = TRUE) # add the ids as names
Storage <- R6::R6Class(
classname = "Storage",
lock_class = TRUE,
cloneable = FALSE,
public = list(
#' @description
#' Initializing a \code{Storage} object.
initialize = function() {
### elements are saved in a list
private$elements <- list()
### ids are saved in a data.frame with identifiers in columns
private$ids <- data.frame()
},
#' @description
#' Adding an element.
#' @param x \[`any()`\]\cr
#' An object to be saved.
add = function(x, identifier, confirm = interactive() & self$confirm,
missing_identifier = self$missing_identifier) {
### input checks
if (missing(x)) {
stop("please specify the object 'x' to be added", call. = FALSE)
}
if (missing(identifier)) {
stop("please specify at least one entry for 'identifier'", call. = FALSE)
}
private$check_input(
identifier = identifier, confirm = confirm,
missing_identifier = missing_identifier
)
if (any(c("all", "!all") %in% identifier)) {
stop("the identifier \"all\" is reserved", call. = FALSE)
}
### inform user about action and request confirmation
if (confirm) {
private$user_confirm(
action = paste0("add a <", class(x), ">"),
identifier = identifier, missing_identifier = missing_identifier,
complete = TRUE
)
}
### add element
private$add_element(x, identifier, missing_identifier)
invisible(self)
},
#' @description
#' Getting elements.
#' @param id_names \[`logical(1)`\]\cr
#' Name the elements according to their ids?
get = function(
identifier = character(), ids = integer(), logical = "and",
confirm = interactive() & self$confirm,
missing_identifier = self$missing_identifier,
id_names = FALSE
) {
### input checks
private$check_input(
identifier = identifier, confirm = confirm, ids = ids,
missing_identifier = missing_identifier, logical = logical
)
if (length(identifier) == 0 && length(ids) == 0) {
if (!self$hide_warnings) {
warning(
"please specify either 'identifier' or 'ids'",
call. = FALSE, immediate. = FALSE
)
}
return(list())
}
### inform user about action and request confirmation
if (confirm) {
private$user_confirm(
action = "extract", identifier = identifier, ids = ids,
missing_identifier = missing_identifier, complete = FALSE,
logical = logical
)
}
### get elements
private$get_element(
identifier = identifier, ids = ids, id_names = id_names,
logical = logical
)
},
#' @description
#' removing elements
#' @param shift_ids \[`logical(1)`\]\cr
#' Shift ids when in-between elements are removed?
remove = function(
identifier = character(), ids = integer(), logical = "and",
confirm = interactive() & self$confirm,
missing_identifier = self$missing_identifier, shift_ids = TRUE
) {
### input checks
private$check_input(
identifier = identifier, confirm = confirm, ids = ids,
missing_identifier = missing_identifier, logical = logical
)
checkmate::assert_flag(shift_ids)
if (length(identifier) == 0 && length(ids) == 0) {
if (!self$hide_warnings) {
warning(
"please specify either 'identifier' or 'ids'",
call. = FALSE, immediate. = FALSE
)
}
return(list())
}
### inform user about action and request confirmation
if (confirm) {
private$user_confirm(
action = "remove", identifier = identifier, ids = ids,
missing_identifier = missing_identifier, complete = FALSE,
logical = logical
)
}
### remove elements
if (length(identifier) > 0 && length(ids) > 0) {
ids <- private$merge_ids(
ids,
private$get_ids(identifier = identifier, logical = logical),
logical = logical
)
} else if (length(identifier) > 0) {
ids <- private$get_ids(identifier = identifier, logical = logical)
}
if (shift_ids) {
private$elements[ids] <- NULL
private$ids <- private$ids[-ids, ]
} else {
private$elements[ids] <- list(NULL)
private$ids[ids, ] <- NA
}
invisible(self)
},
#' @description
#' Computing the number of identified elements.
number = function(
identifier = "all", missing_identifier = self$missing_identifier,
logical = "and", confirm = FALSE
) {
### input checks
private$check_input(
identifier = identifier, missing_identifier = missing_identifier,
confirm = confirm, logical = logical
)
### inform user about action and request confirmation
if (confirm) {
private$user_confirm(
action = "count", identifier = identifier,
missing_identifier = missing_identifier, complete = FALSE,
logical = logical
)
}
### perform action
length(self$indices(identifier, confirm = confirm, logical = logical))
},
#' @description
#' Returning indices based on defined identifiers.
indices = function(
identifier = "all", logical = "and",
confirm = interactive() & self$confirm)
{
### input checks
private$check_input(
identifier = identifier, logical = logical, confirm = confirm
)
### inform user about action and request confirmation
if (confirm) {
private$user_confirm(
action = "get indices of",
identifier = identifier, missing_identifier = missing_identifier,
complete = FALSE, logical = logical
)
}
### perform action
private$get_ids(identifier = identifier, logical = logical)
},
#' @description
#' Printing details of the saved elements.
#' @param ...
#' Currently not used.
print = function(...) {
nelements <- length(private$elements)
if (nelements > 0) {
cat("number of elements:", self$number(), "\n")
cat("identifiers used:", self$identifier, "\n")
} else {
cat("no elements saved yet")
}
invisible(self)
}
),
active = list(
#' @field identifier \[`character()`\]\cr
#' The identifiers used.
identifier = function(value) {
if (missing(value)) {
colnames(private$ids)
} else {
stop("read only")
}
},
#' @field confirm \[`logical(1)`\]\cr
#' The default value for confirmations.
confirm = function(value) {
if (missing(value)) {
private$confirm_default
} else {
checkmate::assert_flag(value)
private$confirm_default <- value
}
},
#' @field missing_identifier \[`logical(1)`\]\cr
#' The default value for not specified identifiers.
missing_identifier = function(value) {
if (missing(value)) {
private$missing_default
} else {
checkmate::assert_flag(value, na.ok = TRUE)
private$missing_default <- value
}
},
#' @field hide_warnings \[`logical(1)`\]\cr
#' Hide warnings (for example if unknown identifiers are selected)?
hide_warnings = function(value) {
if (missing(value)) {
private$.hide_warnings
} else {
checkmate::assert_flag(value, na.ok = TRUE)
private$.hide_warnings <- value
}
}
),
private = list(
elements = NULL,
ids = NULL,
confirm_default = FALSE,
missing_default = NA,
.hide_warnings = FALSE,
check_input = function(identifier = NULL, confirm = NULL, ids = NULL, missing_identifier = NULL,
logical = NULL) {
### check 'identifier' input
if (!is.null(identifier)) {
checkmate::assert_character(identifier, any.missing = FALSE)
}
### check 'confirm' input
checkmate::assert_flag(confirm)
### check 'ids' input
if (!is.null(ids)) {
checkmate::assert_integerish(ids, lower = 1, any.missing = FALSE)
} else if (length(identifier) == 0) {
stop("need at least one identifier", call. = FALSE)
}
### check 'logical' input
if (!is.null(logical)) {
checkmate::assert_choice(logical, choices = c("and", "or"))
}
### check 'missing_identifier' input
if (!is.null(missing_identifier)) {
checkmate::assert_flag(missing_identifier, na.ok = TRUE)
}
},
check_identifier_known = function(identifier, logical) {
checkmate::assert_character(identifier, any.missing = FALSE, min.len = 1)
checkmate::assert_choice(logical, c("and", "or"))
identifier_translated <- names(private$translate_identifier(identifier))
unknown <- which(!identifier_translated %in% c("all", self$identifier))
if (length(unknown) > 0) {
if (!self$hide_warnings) {
warning(
paste0(
"I do not know the identifier(s) '",
paste(identifier[unknown], collapse = "', '"), "'."
),
call. = FALSE, immediate. = FALSE
)
}
if (logical == "and") {
if (!self$hide_warnings) {
warning(
"Because 'logical = \"and\", no element is selected.",
call. = FALSE, immediate. = FALSE
)
}
return(integer())
} else if (logical == "or") {
if (!self$hide_warnings) {
warning(
"Because 'logical = \"or\", I will ignore them.",
call. = FALSE, immediate. = FALSE
)
}
identifier <- identifier[-unknown]
} else {
unknown_error()
}
}
return(identifier)
},
user_confirm = function(action = character(), identifier = character(), ids = integer(),
missing_identifier = self$missing_identifier, complete = TRUE,
logical = "and") {
checkmate::assert_flag(complete)
cat("You are about to", action)
if (any(identifier == "all")) {
cat(" all elements.\n")
} else {
cat(" element(s)")
if (length(ids) > 0) {
if (length(ids) == 1) {
cat(" with id\n")
} else {
cat(" with ids\n")
}
print(ids)
if (length(identifier) > 0) {
cat("and ")
}
} else {
cat(" ")
}
if (length(identifier) > 0) {
if (length(identifier) == 1) {
cat("with identifier:\n")
} else {
if (logical == "and") {
cat("with all these identifiers:\n")
} else if (logical == "or") {
cat("with at least one of these identifiers:\n")
} else {
unknown_error()
}
}
identifier_bool <- private$translate_identifier(identifier)
if (complete) {
identifier_bool <- private$complete_identifier_bool(
identifier_bool = identifier_bool,
missing_identifier = missing_identifier
)
}
print(identifier_bool)
}
}
confirmation <- user_confirm("Is that alright?", default = TRUE)
if (!confirmation) {
stop("Okay, then no.", call. = FALSE)
return(invisible(self))
}
},
add_identifier = function(identifier, missing_identifier) {
checkmate::assert_character(identifier, any.missing = FALSE, min.len = 1)
stopifnot(length(intersect(identifier, self$identifier)) == 0)
if (nrow(private$ids) == 0) {
private$ids[1, ] <- NA
private$ids[, identifier] <- NA
private$ids <- private$ids[0, ]
} else {
private$ids[, identifier] <- missing_identifier
}
},
add_element = function(x, identifier, missing_identifier) {
identifier_bool <- private$translate_identifier(identifier)
new_identifier <- setdiff(names(identifier_bool), self$identifier)
if (length(new_identifier) > 0) {
private$add_identifier(new_identifier, missing_identifier)
}
id <- private$next_id()
private$elements[[id]] <- x
private$ids[id, ] <- self$missing_identifier
private$ids[id, names(identifier_bool)] <- identifier_bool
},
next_id = function() {
length(private$elements) + 1
},
get_element = function(identifier, ids, id_names, logical) {
checkmate::assert_flag(id_names)
if (length(identifier) > 0 && length(ids) > 0) {
ids <- private$merge_ids(
ids,
private$get_ids(identifier = identifier, logical = logical),
logical = logical
)
} else if (length(identifier) > 0) {
ids <- private$get_ids(identifier = identifier, logical = logical)
}
structure(
private$elements[ids],
names = if (id_names) ids
)
},
translate_identifier = function(identifier) {
identifier_translated <- logical(0)
for (value in identifier) {
if (startsWith(value, "!")) {
identifier_translated[substring(value, first = 2)] <- FALSE
} else {
identifier_translated[value] <- TRUE
}
}
return(identifier_translated)
},
complete_identifier_bool = function(identifier_bool, missing_identifier) {
identifier_bool[setdiff(self$identifier, names(identifier_bool))] <-
missing_identifier
return(identifier_bool)
},
get_ids = function(identifier, logical) {
### check for unknown identifier
identifier <- private$check_identifier_known(
identifier = identifier, logical = logical
)
### check for identifier and inverse identifier
for (i in identifier) {
i_inverse <- ifelse(startsWith(i, "!"), substring(i, first = 2), paste0("!", i))
if (i %in% identifier && i_inverse %in% identifier) {
if (logical == "and") {
identifier <- integer()
break
} else {
identifier <- identifier[-which(identifier %in% c(i, i_inverse))]
if (length(identifier) == 0) {
identifier <- "all"
break
}
}
}
}
### no identifiers selected
if (length(identifier) == 0) {
return(integer())
}
### all identifiers selected
if ("all" %in% identifier) {
if (length(identifier) == 1 || logical == "or") {
return(seq_along(private$elements))
} else {
identifier <- identifier[-which(identifier == "all")]
}
}
### extract ids
identifier_bool <- private$translate_identifier(identifier)
comparison <- if (logical == "and") {
identical
} else {
function(x, y) any(x == y)
}
ids <- apply(
private$ids[names(identifier_bool)],
1,
comparison,
identifier_bool
)
sort(unique(which(ids)))
},
merge_ids = function(..., logical) {
ids <- list(...)
if (logical == "and") {
ids <- Reduce(intersect, ids)
} else if (logical == "or") {
ids <- unique(unlist(ids))
} else {
unknown_error()
}
checkmate::assert_integerish(ids, lower = 1, any.missing = FALSE)
if (length(ids) == 0) {
return(integer())
} else {
sort(ids)
}
}
)
)
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.