Zap all sapply fix #319

gesistsa · Sep 3, 2023 · ed11b52 · ed11b52
1 parent 14e3bb0
commit ed11b52
Show file tree

Hide file tree

Showing 5 changed files with 25 additions and 29 deletions.
diff --git a/R/export_methods.R b/R/export_methods.R
@@ -86,7 +86,7 @@ export_delim <- function(file, x, fwrite = TRUE, sep = "\t", row.names = FALSE,
     })
     dat <- do.call(cbind, dat)
     n <- nchar(dat[1,]) + c(rep(nchar(sep), ncol(dat)-1), 0)
-    col_classes <- sapply(x, class)
+    col_classes <- vapply(x, class, character(1))
     col_classes[col_classes == "factor"] <- "integer"
     dict <- cbind.data.frame(variable = names(n),
                              class = col_classes,

diff --git a/R/fwf2.R b/R/fwf2.R
@@ -1,6 +1,5 @@
 #' @importFrom utils read.table
-read.fwf2 <- function (file, widths, header = FALSE, sep = "\t", skip = 0, n = -1, quote = "", stringsAsFactors = FALSE, ...) 
-{
+read.fwf2 <- function (file, widths, header = FALSE, sep = "\t", skip = 0, n = -1, quote = "", stringsAsFactors = FALSE, ...) {
     doone <- function(x) {
         x <- substring(x, first, last)
         x[!nzchar(x)] <- NA_character_
@@ -21,7 +20,7 @@ read.fwf2 <- function (file, widths, header = FALSE, sep = "\t", skip = 0, n = -
         open(file, "rt")
         on.exit(close(file), add = TRUE)
     }
-    if (skip) 
+    if (skip)
         readLines(file, n = skip)
     if (header) {
         headerline <- readLines(file, n = 1L)
@@ -31,8 +30,8 @@ read.fwf2 <- function (file, widths, header = FALSE, sep = "\t", skip = 0, n = -
     nread <- length(raw)
     if (recordlength > 1L && nread%%recordlength) {
         raw <- raw[1L:(nread - nread%%recordlength)]
-        warning(sprintf(ngettext(nread%%recordlength, "last record incomplete, %d line discarded", 
-            "last record incomplete, %d lines discarded"), 
+        warning(sprintf(ngettext(nread%%recordlength, "last record incomplete, %d line discarded",
+            "last record incomplete, %d lines discarded"),
             nread%%recordlength), domain = NA)
     }
     if (recordlength > 1L) {
@@ -42,9 +41,10 @@ read.fwf2 <- function (file, widths, header = FALSE, sep = "\t", skip = 0, n = -
     st <- c(1L, 1L + cumsum(widths))
     first <- st[-length(st)][!drop]
     last <- cumsum(widths)[!drop]
-    if(header)
-        text <- c(headerline, sapply(raw, doone))
-    else
-        text <- sapply(raw, doone)
+    if(header) {
+        text <- c(headerline, vapply(raw, doone, character(1)))
+    } else {
+        text <- vapply(raw, doone, character(1))
+    }
     read.table(text = text, header = header, sep = sep, quote = quote, stringsAsFactors = stringsAsFactors, ...)
 }
diff --git a/R/gather_attrs.R b/R/gather_attrs.R
@@ -37,7 +37,7 @@ gather_attrs <- function(x) {
         }
         rm(f)
     }
-    if (any(sapply(varattrs, length))) {
+    if (any(vapply(varattrs, length, integer(1)))) {
         attrnames <- sort(unique(unlist(lapply(varattrs, names))))
         outattrs <- stats::setNames(lapply(attrnames, function(z) {
             stats::setNames(lapply(varattrs, `[[`, z), names(x))

diff --git a/R/import_list.R b/R/import_list.R
@@ -38,7 +38,7 @@ function(file,
         setclass <- NULL
     }
     strip_exts <- function(file) {
-      sapply(file, function(x) tools::file_path_sans_ext(basename(x)))
+      vapply(file, function(x) tools::file_path_sans_ext(basename(x)), character(1))
     }
     if (length(file) > 1) {
         names(file) <- strip_exts(file)
@@ -65,9 +65,9 @@ function(file,
                 if (missing(which)) {
                     which <- seq_along(tables)
                 }
-                whichnames <- sapply(xml2::xml_attrs(tables[which]),
-                  function(x) if ("class" %in% names(x)) x["class"] else ""
-                )
+                whichnames <- vapply(xml2::xml_attrs(tables[which]),
+                                     function(x) if ("class" %in% names(x)) x["class"] else "",
+                                     FUN.VALUE = character(1))
                 names(which) <- whichnames
             } else if (get_ext(file) %in% c("xls","xlsx")) {
                 .check_pkg_availability("readxl")

diff --git a/R/import_methods.R b/R/import_methods.R
@@ -394,20 +394,16 @@ function(file,
 
 # This is a helper function for .import.rio_html
 extract_html_row <- function(x, empty_value) {
-  # Both <th> and <td> are valid for table data, and <th> may be used when
-  # there is an accented element (e.g. the first row of the table)
-  to_extract <- x[names(x) %in% c("th", "td")]
-  # Insert a value into cells that eventually will become empty cells (or they
-  # will be dropped and the table will not be generated).  Note that this more
-  # complex code for finding the length is required because of html like
-  # <td><br/></td>
-  unlist_length <-
-    sapply(
-      lapply(to_extract, unlist),
-      length
-    )
-  to_extract[unlist_length == 0] <- list(empty_value)
-  unlist(to_extract)
+    ## Both <th> and <td> are valid for table data, and <th> may be used when
+    ## there is an accented element (e.g. the first row of the table)
+    to_extract <- x[names(x) %in% c("th", "td")]
+    ## Insert a value into cells that eventually will become empty cells (or they
+    ## will be dropped and the table will not be generated).  Note that this more
+    ## complex code for finding the length is required because of html like
+    ## <td><br/></td>
+    unlist_length <- vapply(lapply(to_extract, unlist), length, integer(1))
+    to_extract[unlist_length == 0] <- list(empty_value)
+    unlist(to_extract)
 }
 
 #' @importFrom utils type.convert