ARROW-9856: [R] Add bindings for string compute functions

ci/scripts/PKGBUILD

@@ -25,6 +25,8 @@ arch=("any")
 url="https://arrow.apache.org/"
 license=("Apache-2.0")
 depends=("${MINGW_PACKAGE_PREFIX}-aws-sdk-cpp"
+         "${MINGW_PACKAGE_PREFIX}-libutf8proc"
+         "${MINGW_PACKAGE_PREFIX}-re2"
          "${MINGW_PACKAGE_PREFIX}-thrift"
          "${MINGW_PACKAGE_PREFIX}-snappy"
          "${MINGW_PACKAGE_PREFIX}-zlib"
@@ -103,9 +105,7 @@ build() {
     -DARROW_SNAPPY_USE_SHARED=OFF \
     -DARROW_USE_GLOG=OFF \
     -DARROW_WITH_LZ4=ON \
-    -DARROW_WITH_RE2=OFF \
     -DARROW_WITH_SNAPPY=ON \
-    -DARROW_WITH_UTF8PROC=OFF \
     -DARROW_WITH_ZLIB=ON \
     -DARROW_WITH_ZSTD=ON \
     -DARROW_ZSTD_USE_SHARED=OFF \

ci/scripts/r_windows_build.sh

@@ -96,8 +96,8 @@ cp $MSYS_LIB_DIR/mingw64/lib/lib{thrift,snappy}.a $DST_DIR/${RWINLIB_LIB_DIR}/x6
 cp $MSYS_LIB_DIR/mingw32/lib/lib{thrift,snappy}.a $DST_DIR/${RWINLIB_LIB_DIR}/i386
 
 # These are from https://dl.bintray.com/rtools/mingw{32,64}/
-cp $MSYS_LIB_DIR/mingw64/lib/lib{zstd,lz4,crypto,aws*}.a $DST_DIR/lib/x64
-cp $MSYS_LIB_DIR/mingw32/lib/lib{zstd,lz4,crypto,aws*}.a $DST_DIR/lib/i386
+cp $MSYS_LIB_DIR/mingw64/lib/lib{zstd,lz4,crypto,utf8proc,re2,aws*}.a $DST_DIR/lib/x64
+cp $MSYS_LIB_DIR/mingw32/lib/lib{zstd,lz4,crypto,utf8proc,re2,aws*}.a $DST_DIR/lib/i386
 
 # Create build artifact
 zip -r ${DST_DIR}.zip $DST_DIR

dev/tasks/homebrew-formulae/autobrew/apache-arrow.rb

@@ -57,9 +57,7 @@ def install
       -DARROW_USE_GLOG=OFF
       -DARROW_VERBOSE_THIRDPARTY_BUILD=ON
       -DARROW_WITH_LZ4=ON
-      -DARROW_WITH_RE2=OFF
       -DARROW_WITH_SNAPPY=ON
-      -DARROW_WITH_UTF8PROC=OFF
       -DARROW_WITH_ZLIB=ON
       -DARROW_WITH_ZSTD=ON
       -DCMAKE_UNITY_BUILD=OFF

r/DESCRIPTION

@@ -46,6 +46,7 @@ Suggests:
     pkgload,
     reticulate,
     rmarkdown,
+    stringr,
     testthat,
     tibble
 LinkingTo: cpp11 (>= 0.2.0)

r/NAMESPACE

@@ -284,6 +284,7 @@ importFrom(rlang,is_false)
 importFrom(rlang,is_integerish)
 importFrom(rlang,list2)
 importFrom(rlang,new_data_mask)
+importFrom(rlang,new_environment)
 importFrom(rlang,quo_is_null)
 importFrom(rlang,quos)
 importFrom(rlang,set_names)

r/R/arrow-package.R

@@ -18,7 +18,7 @@
 #' @importFrom R6 R6Class
 #' @importFrom purrr as_mapper map map2 map_chr map_dfr map_int map_lgl keep
 #' @importFrom assertthat assert_that is.string
-#' @importFrom rlang list2 %||% is_false abort dots_n warn enquo quo_is_null enquos is_integerish quos eval_tidy new_data_mask syms env env_bind as_label set_names exec is_bare_character
+#' @importFrom rlang list2 %||% is_false abort dots_n warn enquo quo_is_null enquos is_integerish quos eval_tidy new_data_mask syms env new_environment env_bind as_label set_names exec is_bare_character
 #' @importFrom tidyselect vars_select
 #' @useDynLib arrow, .registration = TRUE
 #' @keywords internal

r/R/dplyr.R

@@ -238,31 +238,50 @@ filter.arrow_dplyr_query <- function(.data, ..., .preserve = FALSE) {
 }
 filter.Dataset <- filter.ArrowTabular <- filter.arrow_dplyr_query
 
+# Helper to assemble the functions that go in the NSE data mask
+# The only difference between the Dataset and the Table/RecordBatch versions
+# is that they use a different wrapping function (FUN) to hold the unevaluated
+# expression.
+build_function_list <- function(FUN) {
+  wrapper <- function(operator) {
+    force(operator)
+    function(e1, e2) FUN(operator, e1, e2)
+  }
+
+  c(
+    lapply(set_names(names(.array_function_map)), wrapper),
+    # TODO: lapply also for the arrow spellings?
+    # See list_compute_functions()
+    # (would want to do these first, and then modifyList with the R ones
+    # in case of name collision)
+    # Would need to generalize FUN to accept ... args
+    str_trim = function(string, side = c("both", "left", "right")) {
+      side <- match.arg(side)
+      switch(
+        side,
+        left = FUN("utf8_ltrim_whitespace", string),
+        right = FUN("utf8_rtrim_whitespace", string),
+        both = FUN("utf8_trim_whitespace", string)
+      )
+    }
+  )
+}
+
+# Create these once, at package build time
+dataset_function_list <- build_function_list(build_dataset_expression)
+array_function_list <- build_function_list(build_array_expression)
+
 # Create a data mask for evaluating a filter expression
 filter_mask <- function(.data) {
-  f_env <- env()
-
-  # Insert functions/operators and field references
-  # TODO: define functions in env once, outside of this function
-  # filter_env <- env(parent = if (data_is_dataset) function_env1 else function_env2)
   if (query_on_dataset(.data)) {
-    comp_func <- function(operator) {
-      force(operator)
-      function(e1, e2) build_dataset_expression(operator, e1, e2)
-    }
+    f_env <- new_environment(dataset_function_list)
     var_binder <- function(x) Expression$field_ref(x)
   } else {
-    comp_func <- function(operator) {
-      force(operator)
-      function(e1, e2) build_array_expression(operator, e1, e2)
-    }
+    f_env <- new_environment(array_function_list)
     var_binder <- function(x) .data$.data[[x]]
   }
 
-  # First add the functions
-  func_names <- set_names(names(.array_function_map))
-  env_bind(f_env, !!!lapply(func_names, comp_func))
-  # Then add the column references
+  # Add the column references
   # Renaming is handled automatically by the named list
   data_pronoun <- lapply(.data$selected_columns, var_binder)
   env_bind(f_env, !!!data_pronoun)

r/R/expression.R

@@ -51,8 +51,8 @@ Ops.array_expression <- function(e1, e2) {
 }
 
 build_array_expression <- function(.Generic, e1, e2, ...) {
-  if (.Generic %in% names(.unary_function_map)) {
-    expr <- array_expression(.unary_function_map[[.Generic]], e1)
+  if (.Generic %in% names(.unary_function_map) || nargs() == 2L) {
+    expr <- array_expression(.unary_function_map[[.Generic]] %||% .Generic, e1)
   } else {
     e1 <- .wrap_arrow(e1, .Generic)
     e2 <- .wrap_arrow(e2, .Generic)
@@ -79,7 +79,7 @@ build_array_expression <- function(.Generic, e1, e2, ...) {
       return(build_array_expression("-", e1, base))
     }
 
-    expr <- array_expression(.binary_function_map[[.Generic]], e1, e2, ...)
+    expr <- array_expression(.binary_function_map[[.Generic]] %||% .Generic, e1, e2, ...)
   }
   expr
 }
@@ -110,7 +110,14 @@ cast_array_expression <- function(x, to_type, safe = TRUE, ...) {
 .unary_function_map <- list(
   "!" = "invert",
   "is.na" = "is_null",
-  "is.nan" = "is_nan"
+  "is.nan" = "is_nan",
+  "nchar" = "binary_length",
+  "tolower" = "utf8_lower",
+  "toupper" = "utf8_upper",
+  # stringr spellings of those
+  "str_length" = "binary_length",
+  "str_to_lower" = "utf8_lower",
+  "str_to_upper" = "utf8_upper"
 )
 
 .binary_function_map <- list(
@@ -228,8 +235,8 @@ Expression$scalar <- function(x) {
 }
 
 build_dataset_expression <- function(.Generic, e1, e2, ...) {
-  if (.Generic %in% names(.unary_function_map)) {
-    expr <- Expression$create(.unary_function_map[[.Generic]], e1)
+  if (.Generic %in% names(.unary_function_map) || nargs() == 2L) {
+    expr <- Expression$create(.unary_function_map[[.Generic]] %||% .Generic, e1)
   } else if (.Generic == "%in%") {
     # Special-case %in%, which is different from the Array function name
     expr <- Expression$create("is_in", e1,
@@ -260,7 +267,7 @@ build_dataset_expression <- function(.Generic, e1, e2, ...) {
       return(e1 - e2 * ( e1 %/% e2 ))
     }
 
-    expr <- Expression$create(.binary_function_map[[.Generic]], e1, e2, ...)
+    expr <- Expression$create(.binary_function_map[[.Generic]] %||% .Generic, e1, e2, ...)
   }
   expr
 }

r/configure.win

@@ -50,7 +50,7 @@ AWS_LIBS="-laws-cpp-sdk-config -laws-cpp-sdk-transfer -laws-cpp-sdk-identity-man
 # NOTE: If you make changes to the libraries below, you should also change
 # ci/scripts/r_windows_build.sh and ci/scripts/PKGBUILD
 PKG_CFLAGS="-I${RWINLIB}/include -DARROW_STATIC -DPARQUET_STATIC -DARROW_DS_STATIC -DARROW_R_WITH_ARROW"
-PKG_LIBS="-L${RWINLIB}/lib"'$(subst gcc,,$(COMPILED_BY))$(R_ARCH) '"-L${RWINLIB}/lib"'$(R_ARCH) '"-lparquet -larrow_dataset -larrow -larrow_bundled_dependencies -lthrift -lsnappy -lz -lzstd -llz4 ${MIMALLOC_LIBS} ${OPENSSL_LIBS}"
+PKG_LIBS="-L${RWINLIB}/lib"'$(subst gcc,,$(COMPILED_BY))$(R_ARCH) '"-L${RWINLIB}/lib"'$(R_ARCH) '"-lparquet -larrow_dataset -larrow -larrow_bundled_dependencies -lutf8proc -lre2 -lthrift -lsnappy -lz -lzstd -llz4 ${MIMALLOC_LIBS} ${OPENSSL_LIBS}"
 
 # S3 support only for Rtools40 (i.e. R >= 4.0)
 "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e 'R.version$major >= 4' | grep TRUE >/dev/null 2>&1

r/inst/build_arrow_static.sh

@@ -61,9 +61,7 @@ ${CMAKE} -DARROW_BOOST_USE_SHARED=OFF \
     -DARROW_WITH_BROTLI=${ARROW_WITH_BROTLI:-$ARROW_DEFAULT_PARAM} \
     -DARROW_WITH_BZ2=${ARROW_WITH_BZ2:-$ARROW_DEFAULT_PARAM} \
     -DARROW_WITH_LZ4=${ARROW_WITH_LZ4:-$ARROW_DEFAULT_PARAM} \
-    -DARROW_WITH_RE2=OFF \
     -DARROW_WITH_SNAPPY=${ARROW_WITH_SNAPPY:-$ARROW_DEFAULT_PARAM} \
-    -DARROW_WITH_UTF8PROC=OFF \
     -DARROW_WITH_ZLIB=${ARROW_WITH_ZLIB:-$ARROW_DEFAULT_PARAM} \
     -DARROW_WITH_ZSTD=${ARROW_WITH_ZSTD:-$ARROW_DEFAULT_PARAM} \
     -DCMAKE_BUILD_TYPE=Release \

r/src/compute.cpp

@@ -199,4 +199,9 @@ SEXP compute__CallFunction(std::string func_name, cpp11::list args, cpp11::list
   return from_datum(std::move(out));
 }
 
+// [[arrow::export]]
+std::vector<std::string> list_compute_functions() {
+  return arrow::compute::GetFunctionRegistry()->GetFunctionNames();
+}
+
 #endif

r/tests/testthat/helper-data.R

@@ -63,6 +63,49 @@ example_with_times <- tibble::tibble(
   posixlt_tz = as.POSIXlt(lubridate::ymd_hms("2018-10-07 19:04:05", tz = "US/Eastern") + 1:10)
 )
 
+verses <- list(
+  # Since we tend to test with dataframes with 10 rows, here are verses from
+  # "Milonga del moro judío", by Jorge Drexler. They are décimas, 10-line
+  # poems with a particular meter and rhyme scheme.
+  # (They also have non-ASCII characters, which is nice for testing)
+  c(
+    "Por cada muro, un lamento",
+    "En Jerusalén la dorada",
+    "Y mil vidas malgastadas",
+    "Por cada mandamiento",
+    "Yo soy polvo de tu viento",
+    "Y aunque sangro de tu herida",
+    "Y cada piedra querida",
+    "Guarda mi amor más profundo",
+    "No hay una piedra en el mundo",
+    "Que valga lo que una vida"
+  ),
+  c(
+    "No hay muerto que no me duela",
+    "No hay un bando ganador",
+    "No hay nada más que dolor",
+    "Y otra vida que se vuela",
+    "La guerra es muy mala escuela",
+    "No importa el disfraz que viste",
+    "Perdonen que no me aliste",
+    "Bajo ninguna bandera",
+    "Vale más cualquier quimera",
+    "Que un trozo de tela triste"
+  ),
+  c(
+    "Y a nadie le di permiso",
+    "Para matar en mi nombre",
+    "Un hombre no es más que un hombre",
+    "Y si hay Dios, así lo quiso",
+    "El mismo suelo que piso",
+    "Seguirá, yo me habré ido",
+    "Rumbo también del olvido",
+    "No hay doctrina que no vaya",
+    "Y no hay pueblo que no se haya",
+    "Creído el pueblo elegido"
+  )
+)
+
 make_big_string <- function() {
   # This creates a character vector that would exceed the capacity of BinaryArray
   rep(purrr::map_chr(2047:2050, ~paste(sample(letters, ., replace = TRUE), collapse = "")), 2^18)

r/tests/testthat/test-dataset.R

@@ -492,7 +492,7 @@ test_that("filter() with %in%", {
     tibble(int = df1$int[c(3, 4, 6)], part = 1)
   )
 
-# ARROW-9606: bug in %in% filter on partition column with >1 partition columns
+  # ARROW-9606: bug in %in% filter on partition column with >1 partition columns
   ds <- open_dataset(hive_dir)
   expect_equivalent(
     ds %>%
@@ -503,6 +503,25 @@ test_that("filter() with %in%", {
   )
 })
 
+test_that("filter() with strings", {
+  ds <- open_dataset(dataset_dir, partitioning = schema(part = uint8()))
+  expect_equivalent(
+    ds %>%
+      select(chr, part) %>%
+      filter(chr == "b", part == 1) %>%
+      collect(),
+    tibble(chr = "b", part = 1)
+  )
+
+  expect_equivalent(
+    ds %>%
+      select(chr, part) %>%
+      filter(toupper(chr) == "B", part == 1) %>%
+      collect(),
+    tibble(chr = "b", part = 1)
+  )
+})
+
 test_that("filter() with .data", {
   ds <- open_dataset(dataset_dir, partitioning = schema(part = uint8()))
   expect_equivalent(