Refactor keep_names() and copy_names().

This enables many functions to finish with
if (keep_names(string, pattern)) copy_names(string, out) else out

Author: jonovik

R/count.R

@@ -44,6 +44,5 @@ str_count <- function(string, pattern = "") {
     coll  = stri_count_coll(string, pattern, opts_collator = opts(pattern)),
     regex = stri_count_regex(string, pattern, opts_regex = opts(pattern))
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }

R/detect.R

@@ -50,10 +50,7 @@ str_detect <- function(string, pattern, negate = FALSE) {
     regex = stri_detect_regex(string, pattern, negate = negate, opts_regex = opts(pattern))
   )
 
-  if (length(out) == length(string)) {
-    names(out) <- names(string)
-  }
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' Detect the presence/absence of a match at the start/end
@@ -93,8 +90,7 @@ str_starts <- function(string, pattern, negate = FALSE) {
       stri_detect_regex(string, pattern2, negate = negate, opts_regex = opts(pattern))
     }
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @rdname str_starts
@@ -113,8 +109,7 @@ str_ends <- function(string, pattern, negate = FALSE) {
       stri_detect_regex(string, pattern2, negate = negate, opts_regex = opts(pattern))
     }
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' Detect a pattern in the same way as `SQL`'s `LIKE` and `ILIKE` operators
@@ -176,8 +171,7 @@ str_like <- function(string, pattern, ignore_case = deprecated()) {
 
   pattern <- regex(like_to_regex(pattern), ignore_case = FALSE)
   out <- stri_detect_regex(string, pattern, opts_regex = opts(pattern))
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @export
@@ -191,8 +185,7 @@ str_ilike <- function(string, pattern) {
 
   pattern <- regex(like_to_regex(pattern), ignore_case = TRUE)
   out <- stri_detect_regex(string, pattern, opts_regex = opts(pattern))
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 like_to_regex <- function(pattern) {

R/extract.R

@@ -41,8 +41,7 @@
 str_extract <- function(string, pattern, group = NULL) {
   if (!is.null(group)) {
     out <- str_match(string, pattern)[, group + 1]
-    if (length(out) == length(string)) names(out) <- names(string)
-    return(out)
+    return(if (keep_names(string, pattern)) copy_names(string, out) else out)
   }
 
   check_lengths(string, pattern)
@@ -54,8 +53,7 @@ str_extract <- function(string, pattern, group = NULL) {
     coll  = stri_extract_first_coll(string, pattern, opts_collator = opt),
     regex = stri_extract_first_regex(string, pattern, opts_regex = opt)
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @rdname str_extract
@@ -77,10 +75,5 @@ str_extract_all <- function(string, pattern, simplify = FALSE) {
     regex = stri_extract_all_regex(string, pattern,
       simplify = simplify, omit_no_match = TRUE, opts_regex = opt)
   )
-  if (simplify) {
-    if (nrow(out) == length(string)) rownames(out) <- names(string)
-  } else {
-    if (length(out) == length(string)) names(out) <- names(string)
-  }
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }

R/locate.R

@@ -44,8 +44,7 @@ str_locate <- function(string, pattern) {
     coll  = stri_locate_first_coll(string, pattern, opts_collator = opts(pattern)),
     regex = stri_locate_first_regex(string, pattern, opts_regex = opts(pattern))
   )
-  if (is.matrix(out) && nrow(out) == length(string)) rownames(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @rdname str_locate
@@ -61,8 +60,7 @@ str_locate_all <- function(string, pattern) {
     regex = stri_locate_all_regex(string, pattern, omit_no_match = TRUE, opts_regex = opts),
     coll  = stri_locate_all_coll(string, pattern, omit_no_match = TRUE, opts_collator = opts)
   )
-  if (is.list(out) && length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 

R/match.R

@@ -58,8 +58,7 @@ str_match <- function(string, pattern) {
     pattern,
     opts_regex = opts(pattern)
   )
-  if (is.matrix(out) && nrow(out) == length(string)) rownames(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @rdname str_match
@@ -75,6 +74,5 @@ str_match_all <- function(string, pattern) {
     omit_no_match = TRUE,
     opts_regex = opts(pattern)
   )
-  if (is.list(out) && length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }

R/pad.R

@@ -37,6 +37,5 @@ str_pad <- function(string, width, side = c("left", "right", "both"), pad = " ",
     right = stri_pad_right(string, width, pad = pad, use_length = !use_width),
     both = stri_pad_both(string, width, pad = pad, use_length = !use_width)
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (length(out) == length(string)) copy_names(string, out) else out
 }

R/replace.R

@@ -86,8 +86,7 @@ str_replace <- function(string, pattern, replacement) {
     regex = stri_replace_first_regex(string, pattern, fix_replacement(replacement),
       opts_regex = opts(pattern))
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @export
@@ -119,8 +118,7 @@ str_replace_all <- function(string, pattern, replacement) {
     regex = stri_replace_all_regex(string, pattern, fix_replacement(replacement),
       vectorize_all = vec, opts_regex = opts(pattern))
   )
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 is_replacement_fun <- function(x) {

R/split.R

@@ -77,13 +77,7 @@ str_split <- function(string, pattern, n = Inf, simplify = FALSE) {
     coll  = stri_split_coll(string, pattern, n = n, simplify = simplify, opts_collator = opts(pattern))
   )
 
-  if (is.list(out) && length(out) == length(string)) {
-    names(out) <- names(string)
-  } else if (is.matrix(out) && nrow(out) == length(string)) {
-    rownames(out) <- names(string)
-  }
-
-  out
+  if (keep_names(string, pattern)) copy_names(string, out) else out
 }
 
 #' @export
@@ -113,8 +107,7 @@ str_split_i <- function(string, pattern, i) {
   if (i > 0) {
     out <- str_split(string, pattern, simplify = NA, n = i + 1)
     col <- out[, i]
-    if (length(col) == length(string)) names(col) <- names(string)
-    col
+    if (keep_names(string, pattern)) copy_names(string, col) else col
   } else if (i < 0) {
     i <- abs(i)
     pieces <- str_split(string, pattern)
@@ -127,8 +120,7 @@ str_split_i <- function(string, pattern, i) {
       }
     }
     out <- map_chr(pieces, last)
-    if (length(out) == length(string)) names(out) <- names(string)
-    out
+    if (keep_names(string, pattern)) copy_names(string, out) else out
   } else {
     cli::cli_abort(tr_("{.arg i} must not be 0."))
   }

R/sub.R

@@ -69,8 +69,7 @@ str_sub <- function(string, start = 1L, end = -1L) {
   } else {
     stri_sub(string, from = start, to = end)
   }
-  if (length(out) == length(string)) names(out) <- names(string)
-  out
+  if (length(out) == length(string)) copy_names(string, out) else out
 }
 
 
@@ -95,6 +94,5 @@ str_sub_all <- function(string, start = 1L, end = -1L) {
   } else {
     stri_sub_all(string, from = start, to = end)
   }
-  if (is.list(out) && length(out) == length(string)) names(out) <- names(string)
-  out
+  if (length(out) == length(string)) copy_names(string, out) else out
 }

R/utils.R

@@ -31,38 +31,18 @@ tr_ <- function(...) {
 }
 
 copy_names <- function(from, to) {
-  set_names(to, names(from))
-}
+  nm <- names(from)
+  if (is.null(nm)) return(to)
 
-#' Preserve names based on inputs
-#'
-#' Decides whether to propagate `names(string)` to `out` based on the
-#' relationship between `string` and `pattern`, then applies those names to
-#' the appropriate structure.
-#'
-#' Names are preserved when `pattern` is missing, has length 1, or has the
-#' same length as `string`. For matrix outputs, row names are set; for vector
-#' or list outputs, names are set.
-#'
-#' @param out The result to potentially name; a vector, list, or matrix.
-#' @param string The primary input character vector whose names may be copied.
-#' @param pattern Optional pattern input used to decide if names should be
-#'   preserved.
-#' @return `out`, with `names(out)` or `rownames(out)` set from
-#'   `names(string)` when appropriate.
-#' @keywords internal
-#' @noRd
-keep_names <- function(out, string, pattern = NULL) {
-  nm <- names(string)
-  if (is.null(nm)) return(out)
-
-  keep <- is.null(pattern) || length(pattern) == 1L || length(pattern) == length(string)
-  if (!keep) return(out)
-
-  if (is.matrix(out)) {
-    rownames(out) <- nm
+  if (is.matrix(to)) {
+    rownames(to) <- nm
+    to
   } else {
-    names(out) <- nm
+    set_names(to, nm)
   }
-  out
+}
+
+keep_names <- function(string, pattern) {
+  if (is.null(names(string))) return(FALSE)
+  length(pattern) == 1L || length(pattern) == length(string)
 }