MINOR: [R] progress towards removing Assertthat dependency

r/NAMESPACE

@@ -429,7 +429,6 @@ export(write_to_raw)
 export(write_tsv_dataset)
 importFrom(R6,R6Class)
 importFrom(assertthat,assert_that)
-importFrom(assertthat,is.string)
 importFrom(bit64,integer64)
 importFrom(glue,glue)
 importFrom(methods,as)
@@ -461,8 +460,12 @@ importFrom(rlang,call2)
 importFrom(rlang,call_args)
 importFrom(rlang,call_name)
 importFrom(rlang,caller_env)
+importFrom(rlang,check_bool)
 importFrom(rlang,check_dots_empty)
 importFrom(rlang,check_dots_empty0)
+importFrom(rlang,check_number_decimal)
+importFrom(rlang,check_number_whole)
+importFrom(rlang,check_string)
 importFrom(rlang,dots_list)
 importFrom(rlang,dots_n)
 importFrom(rlang,enexpr)

r/R/array.R

@@ -461,7 +461,7 @@ StructArray$create <- function(...) {
 
 #' @export
 `$.StructArray` <- function(x, name, ...) {
-  assert_that(is.string(name))
+  check_string(name)
   if (name %in% ls(x)) {
     get(name, x)
   } else {

r/R/arrow-datum.R

@@ -29,9 +29,7 @@ ArrowDatum <- R6Class(
       call_function("cast", self, options = opts)
     },
     SortIndices = function(descending = FALSE) {
-      assert_that(is.logical(descending))
-      assert_that(length(descending) == 1L)
-      assert_that(!is.na(descending))
+      check_bool(descending, allow_na = FALSE)
       call_function(
         "sort_indices",
         self,
@@ -285,8 +283,7 @@ filter_rows <- function(x, i, keep_na = TRUE, ...) {
 #' @importFrom utils head
 #' @export
 head.ArrowDatum <- function(x, n = 6L, ...) {
-  assert_is(n, c("numeric", "integer"))
-  assert_that(length(n) == 1)
+  check_number_decimal(n)
   len <- NROW(x)
   if (n < 0) {
     # head(x, negative) means all but the last n rows
@@ -306,8 +303,7 @@ head.ArrowDatum <- function(x, n = 6L, ...) {
 #' @importFrom utils tail
 #' @export
 tail.ArrowDatum <- function(x, n = 6L, ...) {
-  assert_is(n, c("numeric", "integer"))
-  assert_that(length(n) == 1)
+  check_number_decimal(n)
   if (!is.integer(n)) {
     n <- floor(n)
   }

r/R/arrow-package.R

@@ -6,7 +6,7 @@
 # "License"); you may not use this file except in compliance
 # with the License.  You may obtain a copy of the License at
 #
-#   http://www.apache.org/licenses/LICENSE-2.0
+#   https://www.apache.org/licenses/LICENSE-2.0
 #
 # Unless required by applicable law or agreed to in writing,
 # software distributed under the License is distributed on an
@@ -19,15 +19,15 @@
 #' @importFrom R6 R6Class
 #' @importFrom purrr as_mapper map map2 map_chr map2_chr map_dbl map_dfr map_int map_lgl keep imap imap_chr
 #' @importFrom purrr compact flatten reduce walk
-#' @importFrom assertthat assert_that is.string
+#' @importFrom assertthat assert_that
 #' @importFrom rlang list2 %||% is_false abort dots_n warn enquo quo_is_null enquos is_integerish quos quo
 #' @importFrom rlang eval_tidy new_data_mask syms env new_environment env_bind set_names exec
 #' @importFrom rlang is_bare_character quo_get_expr quo_get_env quo_set_expr .data seq2 is_interactive
 #' @importFrom rlang expr caller_env is_character quo_name is_quosure enexpr enexprs as_quosure
 #' @importFrom rlang is_list call2 is_empty as_function as_label arg_match is_symbol is_call call_args
 #' @importFrom rlang quo_set_env quo_get_env is_formula quo_is_call f_rhs parse_expr f_env new_quosure
 #' @importFrom rlang new_quosures expr_text caller_env check_dots_empty check_dots_empty0 dots_list is_string inform
-#' @importFrom rlang is_bare_list call_name
+#' @importFrom rlang is_bare_list call_name check_string check_number_whole check_number_decimal check_bool
 #' @importFrom tidyselect vars_pull eval_select eval_rename
 #' @importFrom glue glue
 #' @importFrom bit64 integer64

r/R/arrow-tabular.R

@@ -153,7 +153,7 @@ as.data.frame.ArrowTabular <- function(x, row.names = NULL, optional = FALSE, ..
 
 #' @export
 `$.ArrowTabular` <- function(x, name, ...) {
-  assert_that(is.string(name))
+  check_string(name)
   if (name %in% ls(x)) {
     get(name, x)
   } else {
@@ -166,7 +166,9 @@ as.data.frame.ArrowTabular <- function(x, row.names = NULL, optional = FALSE, ..
   if (!is.character(i) && !is.numeric(i)) {
     stop("'i' must be character or numeric, not ", class(i), call. = FALSE)
   }
-  assert_that(length(i) == 1, !is.na(i))
+  if (length(i) != 1 || is.na(i)) {
+    stop("i must be length 1 and not NA", call. = FALSE)
+  }
 
   if (is.null(value)) {
     if (is.character(i)) {
@@ -209,7 +211,7 @@ as.data.frame.ArrowTabular <- function(x, row.names = NULL, optional = FALSE, ..
 
 #' @export
 `$<-.ArrowTabular` <- function(x, i, value) {
-  assert_that(is.string(i))
+  check_string(i)
   # We need to check if `i` is in names in case it is an active binding (e.g.
   # `metadata`, in which case we use assign to change the active binding instead
   # of the column in the table)

r/R/compression.R

@@ -47,7 +47,7 @@ Codec <- R6Class(
   )
 )
 Codec$create <- function(type = "gzip", compression_level = NA) {
-  if (is.string(type)) {
+  if (is_string(type)) {
     type <- util___Codec__Create(
       compression_from_name(type),
       compression_level
@@ -104,7 +104,7 @@ compression_from_name <- function(name) {
 CompressedOutputStream <- R6Class("CompressedOutputStream", inherit = OutputStream)
 CompressedOutputStream$create <- function(stream, codec = "gzip", compression_level = NA) {
   codec <- Codec$create(codec, compression_level = compression_level)
-  if (is.string(stream)) {
+  if (is_string(stream)) {
     stream <- FileOutputStream$create(stream)
   }
   assert_is(stream, "OutputStream")
@@ -118,7 +118,7 @@ CompressedOutputStream$create <- function(stream, codec = "gzip", compression_le
 CompressedInputStream <- R6Class("CompressedInputStream", inherit = InputStream)
 CompressedInputStream$create <- function(stream, codec = "gzip", compression_level = NA) {
   codec <- Codec$create(codec, compression_level = compression_level)
-  if (is.string(stream)) {
+  if (is_string(stream)) {
     stream <- ReadableFile$create(stream)
   }
   assert_is(stream, "InputStream")

r/R/compute.R

@@ -44,8 +44,10 @@
 #' @include chunked-array.R
 #' @include scalar.R
 call_function <- function(function_name, ..., args = list(...), options = empty_named_list()) {
-  assert_that(is.string(function_name))
-  assert_that(is.list(options), !is.null(names(options)))
+  check_string(function_name)
+  if (!is.list(options) || is.null(names(options))) {
+    stop("options must be a named list.", call. = FALSE)
+  }
 
   datum_classes <- c("Array", "ChunkedArray", "RecordBatch", "Table", "Scalar")
   valid_args <- map_lgl(args, ~ inherits(., datum_classes))

r/R/csv.R

@@ -440,7 +440,7 @@ csv_read_options <- function(
   encoding = "UTF-8",
   skip_rows_after_names = 0L
 ) {
-  assert_that(is.string(encoding))
+  check_string(encoding)
 
   options <- csv___ReadOptions__initialize(
     list(
@@ -647,13 +647,11 @@ csv_write_options <- function(
   quoting_style <- match(quoting_style, quoting_style_opts) - 1L
 
   assert_that(is.logical(include_header))
-  assert_that(is_integerish(batch_size, n = 1, finite = TRUE), batch_size > 0)
-  assert_that(is.character(delimiter))
-  assert_that(is.character(null_string))
-  assert_that(!is.na(null_string))
-  assert_that(length(null_string) == 1)
+  check_number_whole(batch_size, min = 1, allow_infinite = FALSE)
+  check_string(delimiter)
+  check_string(null_string, allow_na = FALSE)
   assert_that(!grepl('"', null_string), msg = "na argument must not contain quote characters.")
-  assert_that(is.character(eol))
+  check_string(eol)
 
   csv___WriteOptions__initialize(
     list(

r/R/dataset-factory.R

@@ -293,7 +293,7 @@ fsf_options <- function(factory_options, partitioning) {
         call. = FALSE
       )
     } else {
-      assert_that(is.string(factory_options$partition_base_dir))
+      check_string(factory_options$partition_base_dir)
     }
   }
 

r/R/dplyr-funcs-string.R

@@ -292,7 +292,7 @@ register_bindings_string_regex <- function() {
     "stringr::str_count",
     function(string, pattern) {
       opts <- get_stringr_pattern_options(enquo(pattern))
-      if (!is.string(pattern)) {
+      if (!is_string(pattern)) {
         arrow_not_supported("`pattern` must be a length 1 character vector; other values")
       }
       arrow_fun <- ifelse(opts$fixed, "count_substring", "count_substring_regex")
@@ -422,7 +422,7 @@ register_bindings_string_regex <- function() {
   })
 
   register_binding("base::strsplit", function(x, split, fixed = FALSE, perl = FALSE, useBytes = FALSE) {
-    assert_that(is.string(split))
+    check_string(split)
 
     arrow_fun <- ifelse(fixed, "split_pattern", "split_pattern_regex")
     # warn when the user specifies both fixed = TRUE and perl = TRUE, for
@@ -622,7 +622,7 @@ register_bindings_string_other <- function() {
   register_binding("stringr::str_pad", function(string, width, side = c("left", "right", "both"), pad = " ") {
     assert_that(is_integerish(width))
     side <- match.arg(side)
-    assert_that(is.string(pad))
+    check_string(pad)
 
     if (side == "left") {
       pad_func <- "utf8_lpad"

r/R/dplyr-funcs-type.R

@@ -78,7 +78,7 @@ register_bindings_type_cast <- function() {
   })
 
   register_binding("methods::is", function(object, class2) {
-    if (is.string(class2)) {
+    if (is_string(class2)) {
       switch(
         class2,
         # for R data types, pass off to is.*() functions

r/R/dplyr-summarize.R

@@ -146,7 +146,7 @@ do_arrow_summarize <- function(.data, ..., .groups = NULL) {
       # But we don't support anything that returns multiple rows now
       .groups <- "drop_last"
     } else {
-      assert_that(is.string(.groups))
+      check_string(.groups)
     }
     if (.groups == "drop_last") {
       out$group_by_vars <- head(.data$group_by_vars, -1)

r/R/expression.R

@@ -75,7 +75,7 @@ Expression <- R6Class(
   )
 )
 Expression$create <- function(function_name, ..., args = list(...), options = empty_named_list()) {
-  assert_that(is.string(function_name))
+  check_string(function_name)
   # Make sure all inputs are Expressions
   args <- lapply(args, function(x) {
     if (!inherits(x, "Expression")) {
@@ -99,7 +99,7 @@ Expression$create <- function(function_name, ..., args = list(...), options = em
 
 #' @export
 `$.Expression` <- function(x, name, ...) {
-  assert_that(is.string(name))
+  check_string(name)
   if (name %in% ls(x)) {
     get(name, x)
   } else {
@@ -111,7 +111,7 @@ get_nested_field <- function(expr, name) {
   if (expr$is_field_ref()) {
     # Make a nested field ref
     # TODO(#33756): integer (positional) field refs are supported in C++
-    assert_that(is.string(name))
+    check_string(name)
     out <- compute___expr__nested_field_ref(expr, name)
   } else {
     # Use the struct_field kernel if expr is a struct:
@@ -149,7 +149,7 @@ get_nested_field <- function(expr, name) {
 
 Expression$field_ref <- function(name) {
   # TODO(#33756): allow construction of field ref from integer
-  assert_that(is.string(name))
+  check_string(name)
   compute___expr__field_ref(name)
 }
 Expression$scalar <- function(x) {

r/R/extension.R

@@ -227,11 +227,11 @@ ExtensionType$new <- function(xp) {
 }
 
 ExtensionType$create <- function(storage_type, extension_name, extension_metadata = raw(), type_class = ExtensionType) {
-  if (is.string(extension_metadata)) {
+  if (is_string(extension_metadata)) {
     extension_metadata <- charToRaw(enc2utf8(extension_metadata))
   }
-
-  assert_that(is.string(extension_name), is.raw(extension_metadata))
+  check_string(extension_name)
+  assert_that(is.raw(extension_metadata))
   assert_is(storage_type, "DataType")
   assert_is(type_class, "R6ClassGenerator")
 

r/R/feather.R

@@ -76,7 +76,7 @@ write_feather <- function(
 ) {
   # Handle and validate options before touching data
   version <- as.integer(version)
-  assert_that(version %in% 1:2)
+  check_number_whole(version, min = 1, max = 2)
 
   if (isTRUE(compression)) {
     compression <- "default"
@@ -88,7 +88,7 @@ write_feather <- function(
   # TODO(ARROW-17221): if (missing(compression)), we could detect_compression(sink) here
   compression <- match.arg(compression)
   chunk_size <- as.integer(chunk_size)
-  assert_that(chunk_size > 0)
+  check_number_whole(chunk_size, min = 1)
   if (compression == "default") {
     if (version == 2 && codec_is_available("lz4")) {
       compression <- "lz4"

r/R/field.R

@@ -84,7 +84,7 @@ Field <- R6Class(
   )
 )
 Field$create <- function(name, type, metadata = NULL, nullable = TRUE) {
-  assert_that(inherits(name, "character"), length(name) == 1L)
+  check_string(name)
   type <- as_type(type, name)
   f <- Field__initialize(enc2utf8(name), type, nullable)
   if (!is.null(metadata)) {

r/R/filesystem.R

@@ -367,7 +367,7 @@ FileSystem <- R6Class(
   )
 )
 FileSystem$from_uri <- function(uri) {
-  assert_that(is.string(uri))
+  check_string(uri)
   fs___FileSystemFromUri(uri)
 }
 
@@ -377,7 +377,9 @@ get_paths_and_filesystem <- function(x, filesystem = NULL) {
   if (inherits(x, "SubTreeFileSystem")) {
     return(list(fs = x$base_fs, path = x$base_path))
   }
-  assert_that(is.character(x))
+  if (!is.character(x)) {
+    stop("x must be a character vector.", call. = FALSE)
+  }
   are_urls <- are_urls(x)
   if (any(are_urls)) {
     if (!all(are_urls)) {
@@ -412,12 +414,14 @@ get_paths_and_filesystem <- function(x, filesystem = NULL) {
 # variant of the above function that asserts that x is either a scalar string
 # or a SubTreeFileSystem
 get_path_and_filesystem <- function(x, filesystem = NULL) {
-  assert_that(is.string(x) || inherits(x, "SubTreeFileSystem"))
+  if (!is_string(x) && !inherits(x, "SubTreeFileSystem")) {
+    stop("x must be a string or SubTreeFileSystem.")
+  }
   get_paths_and_filesystem(x, filesystem)
 }
 
-is_url <- function(x) is.string(x) && grepl("://", x)
-is_http_url <- function(x) is_url(x) && grepl("^http", x)
+is_url <- function(x) is_string(x) && grepl("://", x)
+is_http_url <- function(x) is_url(x) && startsWith(x, "http")
 are_urls <- function(x) if (!is.character(x)) FALSE else grepl("://", x)
 
 #' @usage NULL
@@ -538,7 +542,7 @@ default_s3_options <- list(
 #'
 #' @export
 s3_bucket <- function(bucket, ...) {
-  assert_that(is.string(bucket))
+  check_string(bucket)
   args <- list2(...)
 
   # If user specifies args, they must specify region as arg, env var, or config
@@ -573,7 +577,7 @@ s3_bucket <- function(bucket, ...) {
 #' bucket <- gs_bucket("arrow-datasets")
 #' @export
 gs_bucket <- function(bucket, ...) {
-  assert_that(is.string(bucket))
+  check_string(bucket)
   args <- list2(...)
 
   fs <- exec(GcsFileSystem$create, !!!args)
@@ -755,7 +759,7 @@ AzureFileSystem$create <- function(account_name, ...) {
 #' )
 #' @export
 az_container <- function(container_path, ...) {
-  assert_that(is.string(container_path))
+  check_string(container_path)
   args <- list2(...)
 
   fs <- exec(AzureFileSystem$create, !!!args)
@@ -798,7 +802,7 @@ SubTreeFileSystem$create <- function(base_path, base_fs = NULL) {
 #' @export
 `$.SubTreeFileSystem` <- function(x, name, ...) {
   # This is to allow delegating methods/properties to the base_fs
-  assert_that(is.string(name))
+  check_string(name)
   if (name %in% ls(envir = x)) {
     get(name, x)
   } else if (name %in% ls(envir = x$base_fs)) {