@@ -43,9 +43,7 @@ setClass(
4343# '
4444# ' @family key
4545# '
46- .KeyPattern <- function () {
47- return (' ^[a-zA-Z][a-zA-Z0-9]*_$'
48- }
46+ .KeyPattern <- \() ' ^[a-zA-Z][a-zA-Z0-9]*_$'
4947
5048# ' Generate a Random Key
5149# '
@@ -63,24 +61,22 @@ setClass(
6361# ' set.seed(42L)
6462# ' .RandomKey()
6563# '
66- .RandomKey <- function (length = 7L , ... ) {
67- return (Key(
68- object = RandomName(
69- length = length ,
70- chars = c(letters , LETTERS , seq.int(from = 0L , to = 9L )),
71- ...
72- ),
73- quiet = TRUE
74- ))
75- }
64+ .RandomKey <- \(length = 7L , ... ) Key(
65+ object = RandomName(
66+ length = length ,
67+ chars = c(letters , LETTERS , seq.int(from = 0L , to = 9L )),
68+ ...
69+ ),
70+ quiet = TRUE
71+ )
7672
7773# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7874# Methods for Seurat-defined generics
7975# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
8076
8177# ' @param object An object
82- # ' @param quiet Suppress warnings when updating characters to keys
8378# ' @param ... Ignored
79+ # ' @param quiet Suppress warnings when updating characters to keys
8480# ' @param value A key to set
8581# '
8682# ' @details \code{Key.character}: Update a character to a key
@@ -91,10 +87,14 @@ setClass(
9187# ' @method Key character
9288# ' @export
9389# '
94- Key.character <- function (object , quiet = FALSE , ... ) {
95- f <- ifelse(test = isTRUE(x = quiet ), yes = suppressWarnings , no = identity )
96- return (f(UpdateKey(key = object )))
97- }
90+ Key.character <- \(object , ... , quiet = FALSE ) withCallingHandlers(
91+ expr = UpdateKey(key = object ),
92+ updatedKeyWarning = \(cnd ) tryInvokeRestart(r = ifelse(
93+ test = isTRUE(x = quiet ),
94+ yes = ' muffleWarning'
95+ no = RandomName()
96+ ))
97+ )
9898
9999# ' @details \code{Key.KeyMixin}: Get the key of a keyed object
100100# '
@@ -130,9 +130,7 @@ Key.KeyMixin <- function(object, ...) {
130130# ' @method Key NULL
131131# ' @export
132132# '
133- Key.NULL <- function (object , ... ) {
134- return (NULL )
135- }
133+ Key.NULL <- \(object , ... ) NULL
136134
137135# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
138136# Methods for R-defined generics
@@ -142,6 +140,57 @@ Key.NULL <- function(object, ...) {
142140# Internal
143141# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
144142
143+ # ' Check Usage of Existing Keys
144+ # '
145+ # ' Check key usage against existing keys to ensure key uniqueness
146+ # '
147+ # ' @param key Existing key to check usage of; if missing, creates a
148+ # ' key from \code{name}
149+ # ' @param existing A vector of existing keys to match against \code{key}
150+ # ' @param name Name of object that \code{key} is used for; if provided and
151+ # ' \code{existing} is named, the entry of \code{existing} for \code{name} is
152+ # ' removed from the check
153+ # '
154+ # ' @return A key guaranteed to be unique in the context of \code{existing}
155+ # '
156+ # ' @keywords internal
157+ # '
158+ # ' @noRd
159+ # '
160+ .CheckKey <- function (key , existing = NULL , name = NULL ) {
161+ if (rlang :: is_missing(x = key ) || ! length(x = key ) || ! nzchar(x = key )) {
162+ key <- Key(object = tolower(name ) %|| % RandomName(), quiet = TRUE )
163+ }
164+ key <- Key(object = key , quiet = TRUE )
165+ if (! is.null(x = names(x = existing )) && ! is.null(x = name )) {
166+ existing <- existing [setdiff(x = names(x = existing ), y = name )]
167+ }
168+ if (key %in% existing ) {
169+ old <- key
170+ key <- Key(object = tolower(x = name %|| % RandomName()), quiet = TRUE )
171+ i <- 1L
172+ n <- 5L
173+ while (key %in% existing ) {
174+ key <- Key(object = RandomName(length = n ), quiet = TRUE )
175+ i <- i + 1L
176+ if (! i %% 7L ) {
177+ n <- n + 2L
178+ }
179+ }
180+ warn(
181+ message = paste(
182+ " Key"
183+ sQuote(x = old ),
184+ " taken, using"
185+ sQuote(x = key ),
186+ " instead"
187+ ),
188+ class = ' existingKeyWarning'
189+ )
190+ }
191+ return (key )
192+ }
193+
145194# ' Internal Key Methods
146195# '
147196# ' Internal key methods for classes that inherit from \code{\link{KeyMixin}};
@@ -199,18 +248,21 @@ UpdateKey <- function(key) {
199248 if (new.key == ' _'
200249 new.key <- paste0(RandomName(length = 3 ), ' _'
201250 }
202- warning(
203- key.msg ,
204- " , setting key from "
205- key ,
206- " to "
207- new.key ,
208- call. = FALSE ,
209- immediate. = TRUE
251+ warn(
252+ message = paste0(
253+ key.msg ,
254+ " , setting key from "
255+ key ,
256+ " to "
257+ new.key
258+ ),
259+ class = ' updatedKeyWarning'
210260 )
211261 return (new.key )
212262}
213263
264+ .MetaKey <- Key(object = ' md' quiet = TRUE )
265+
214266# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
215267# S4 methods
216268# %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -224,7 +276,7 @@ UpdateKey <- function(key) {
224276# ' Keys must be a one-length character vector; a key must be composed of one
225277# ' of the following:
226278# ' \itemize{
227- # ' \item An empty string (eg. \dQuote{\code{''}}) where \code{nzchar () == 0}
279+ # ' \item An empty string (eg. \dQuote{\code{''}}) where \code{nchar () == 0}
228280# ' \item An string composed of one or more alphanumeric values
229281# ' (both lower- and upper-case) that ends with an underscore
230282# ' (\dQuote{\code{_}}); the first character must be a letter
@@ -262,42 +314,10 @@ setValidity(
262314 # Ensure proper key composition
263315 valid <- c(
264316 valid ,
265- paste0 (" Keys must match the pattern ' " , " ' "
317+ paste (" Keys must match the pattern" sQuote( x = .KeyPattern()) )
266318 )
267319 }
268320 }
269321 return (valid %|| % TRUE )
270322 }
271323)
272-
273- .CheckKey <- function (key , existing = NULL , name = NULL ) {
274- if (rlang :: is_missing(x = key ) || ! length(x = key ) || ! nzchar(x = key )) {
275- key <- Key(object = tolower(name ) %|| % RandomName(), quiet = TRUE )
276- }
277- if (! is.null(x = names(x = existing )) && ! is.null(x = name )) {
278- existing <- existing [setdiff(x = names(x = existing ), y = name )]
279- }
280- if (key %in% existing ) {
281- old <- key
282- key <- Key(object = tolower(x = name %|| % RandomName()), quiet = TRUE )
283- i <- 1L
284- n <- 5L
285- while (key %in% existing ) {
286- key <- Key(object = RandomName(length = n ), quiet = TRUE )
287- i <- i + 1L
288- if (! i %% 7L ) {
289- n <- n + 2L
290- }
291- }
292- warn(
293- message = paste(
294- " Key"
295- sQuote(x = old ),
296- " taken, using"
297- sQuote(x = key ),
298- " instead"
299- )
300- )
301- }
302- return (key )
303- }
0 commit comments