Nothing
#' @include zzz.R
#' @include generics.R
#'
NULL
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Class definitions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' A Mixin for Keyed objects
#'
#' A mixin (virtual class) for enabling keyed objects; provides consistent
#' behavior for getting, setting, and validating keys
#'
#' @template slot-key
#'
#' @keywords internal
#'
#' @exportClass KeyMixin
#'
#' @aliases KeyMixin
#'
#' @family key
#'
setClass(
Class = 'KeyMixin',
contains = 'VIRTUAL',
slots = list(key = 'character')
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Regex Pattern for Keys
#'
#' @return Returns the regex pattern for keys
#' (\dQuote{\Sexpr[stage=build]{SeuratObject:::.KeyPattern()}})
#'
#' @keywords internal
#'
#' @export
#'
#' @family key
#'
.KeyPattern <- \() '^[a-zA-Z][a-zA-Z0-9]*_$'
#' Generate a Random Key
#'
#' @inheritParams RandomName
#'
#' @return Returns a valid key
#'
#' @keywords internal
#'
#' @export
#'
#' @family key
#'
#' @examples
#' set.seed(42L)
#' .RandomKey()
#'
.RandomKey <- \(length = 7L, ...) Key(
object = RandomName(
length = length,
chars = c(letters, LETTERS, seq.int(from = 0L, to = 9L)),
...
),
quiet = TRUE
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for Seurat-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @param object An object
#' @param ... Ignored
#' @param quiet Suppress warnings when updating characters to keys
#' @param value A key to set
#'
#' @details \code{Key.character}: Update a character to a key
#'
#' @return \code{Key.character}: \code{object} but as a syntactically-valid key
#'
#' @rdname KeyMixin-class
#' @method Key character
#' @export
#'
Key.character <- \(object, ..., quiet = FALSE) withCallingHandlers(
expr = UpdateKey(key = object),
updatedKeyWarning = \(cnd) tryInvokeRestart(r = ifelse(
test = isTRUE(x = quiet),
yes = 'muffleWarning',
no = RandomName()
))
)
#' @details \code{Key.KeyMixin}: Get the key of a keyed object
#'
#' @return \code{Key.KeyMixin}: The key from \code{object}; if no key set,
#' returns \code{NULL}
#'
#' @rdname KeyMixin-class
#' @method Key KeyMixin
#' @export
#'
Key.KeyMixin <- function(object, ...) {
key <- slot(object = object, name = 'key')
if (!length(x = key)) {
key <- NULL
}
return(key)
}
#' @details \code{Key<-}: Set the key of a keyed object
#'
#' @return \code{Key<-}: \code{object} with the key set to \code{value}
#'
#' @rdname KeyMixin-class
#' @method Key<- KeyMixin
#' @export
#'
"Key<-.KeyMixin" <- function(object, ..., value) {
slot(object = object, name = 'key') <- Key(object = value, ...)
validObject(object = object)
return(object)
}
#' @method Key NULL
#' @export
#'
Key.NULL <- \(object, ...) NULL
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for R-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internal
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Check Usage of Existing Keys
#'
#' Check key usage against existing keys to ensure key uniqueness
#'
#' @param key Existing key to check usage of; if missing, creates a
#' key from \code{name}
#' @param existing A vector of existing keys to match against \code{key}
#' @param name Name of object that \code{key} is used for; if provided and
#' \code{existing} is named, the entry of \code{existing} for \code{name} is
#' removed from the check
#'
#' @return A key guaranteed to be unique in the context of \code{existing}
#'
#' @keywords internal
#'
#' @noRd
#'
.CheckKey <- function(key, existing = NULL, name = NULL) {
if (rlang::is_missing(x = key) || !length(x = key) || !nzchar(x = key)) {
key <- Key(object = tolower(name) %||% RandomName(), quiet = TRUE)
}
key <- Key(object = key, quiet = TRUE)
if (!is.null(x = names(x = existing)) && !is.null(x = name)) {
existing <- existing[setdiff(x = names(x = existing), y = name)]
}
if (key %in% existing) {
old <- key
key <- Key(object = tolower(x = name %||% RandomName()), quiet = TRUE)
i <- 1L
n <- 5L
while (key %in% existing) {
key <- Key(object = RandomName(length = n), quiet = TRUE)
i <- i + 1L
if (!i %% 7L) {
n <- n + 2L
}
}
warn(
message = paste(
"Key",
sQuote(x = old),
"taken, using",
sQuote(x = key),
"instead"
),
class = 'existingKeyWarning'
)
}
return(key)
}
#' Internal Key Methods
#'
#' Internal key methods for classes that inherit from \code{\link{KeyMixin}};
#' these functions are designed to be used as the body for methods for
#' \code{Key()} and \code{Key<-()} when an immediate public method is required.
#' Generally speaking, classes that inherit from \code{KeyMixin} should use the
#' \code{KeyMixin} methods for \code{Key()} and \code{Key<-()}
#'
#' @inheritParams Key
#'
#' @inherit Key return
#'
#' @keywords internal
#'
#' @noRd
#'
.Key <- function(object, ...) {
CheckDots(...)
return(NextMethod())
}
#' @rdname dot-Key
#'
#' @noRd
#'
".Key<-" <- function(object, ..., value) {
CheckDots(...)
object <- UpdateSlots(object = object)
object <- NextMethod()
return(object)
}
#' Update a Key
#'
#' @param key A character to become a Seurat Key
#'
#' @return An updated Key that's valid for Seurat
#'
#' @keywords internal
#'
#' @family key
#'
#' @noRd
#'
UpdateKey <- function(key) {
key.msg <- 'Keys should be one or more alphanumeric characters followed by an underscore'
if (isTRUE(x = grepl(pattern = .KeyPattern(), x = key))) {
return(key)
}
new.key <- regmatches(
x = key,
m = gregexpr(pattern = '[[:alnum:]]+', text = key)
)
new.key <- paste0(paste(unlist(x = new.key), collapse = ''), '_')
if (new.key == '_') {
new.key <- paste0(RandomName(length = 3), '_')
}
warn(
message = paste0(
key.msg,
", setting key from ",
key,
" to ",
new.key
),
class = 'updatedKeyWarning'
)
return(new.key)
}
.MetaKey <- Key(object = 'md', quiet = TRUE)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# S4 methods
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' Key Validity
#'
#' Validation of \code{\link{KeyMixin}} objects is handled by
#' \code{\link[methods]{validObject}}
#'
#' @section Key Validation:
#' Keys must be a one-length character vector; a key must be composed of one
#' of the following:
#' \itemize{
#' \item An empty string (eg. \dQuote{\code{''}}) where \code{nchar() == 0}
#' \item An string composed of one or more alphanumeric values
#' (both lower- and upper-case) that ends with an underscore
#' (\dQuote{\code{_}}); the first character must be a letter
#' }
#' Keys that are not empty strings are validated with the regex
#' \dQuote{\code{\Sexpr[stage=build]{SeuratObject:::.KeyPattern()}}}
#'
#' @importFrom rlang is_scalar_character
#'
#' @keywords internal
#'
#' @name Key-validity
#'
#' @family key
#'
setValidity(
Class = 'KeyMixin',
method = function(object) {
if (isFALSE(x = getOption(x = "Seurat.object.validate", default = TRUE))) {
warn(
message = paste("Not validating", class(x = object)[1L], "objects"),
class = 'validationWarning'
)
return(TRUE)
}
valid <- NULL
key <- Key(object = object)
# Ensure key has length of 1
if (!is.null(x = key) && .GetSeuratCompat() >= '5.0.0') {
if (!is_scalar_character(x = key)) {
valid <- c(valid, "Keys must be a one-length character vector")
} else if (is_na(x = key)) {
valid <- c(valid, "Keys may not be 'NA'")
} else if (nzchar(x = key) && !grepl(pattern = .KeyPattern(), x = key)) {
# Ensure proper key composition
valid <- c(
valid,
paste("Keys must match the pattern", sQuote(x = .KeyPattern()))
)
}
}
return(valid %||% TRUE)
}
)
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.