ARROW-11513: [R] Bindings for sub/gsub

r/R/dplyr.R

@@ -422,6 +422,10 @@ build_function_list <- function(FUN) {
         both = FUN("utf8_trim_whitespace", string)
       )
     },
+    sub = arrow_r_string_replace_function(FUN, 1L),
+    gsub = arrow_r_string_replace_function(FUN, -1L),
+    str_replace = arrow_stringr_string_replace_function(FUN, 1L),
+    str_replace_all = arrow_stringr_string_replace_function(FUN, -1L),
     between = function(x, left, right) {
       x >= left & x <= right
     },
@@ -434,6 +438,88 @@ build_function_list <- function(FUN) {
   )
 }
 
+arrow_r_string_replace_function <- function(FUN, max_replacements) {
+  function(pattern, replacement, x, ignore.case = FALSE, fixed = FALSE) {
+    if (ignore.case) {
+      # Prepend "(?i)" to the regex for case insensitivity
+      if (fixed) {
+        # Arrow lacks native support for case-insensitive literal string
+        # replacement, so we use the regular expression engine (RE2) to do this.
+        # https://github.com/google/re2/wiki/Syntax
+        #
+        # Everything between "\Q" and "\E" is treated as literal text.
+        #
+        # If the search text contains any literal "\E" strings, make them
+        # lowercase so they won't signal the end of the literal text:
+        pattern <- gsub("\\E", "\\e", pattern, fixed = TRUE)
+        pattern <- paste0("(?i)\\Q", pattern, "\\E")
+        # Escape single backslashes in the regex replacement text so they are
+        # interpreted as literal backslashes:
+        replacement <- gsub("\\", "\\\\", replacement, fixed = TRUE)
+      } else {
+        pattern <- paste0("(?i)", pattern)
+      }
+    }
+    FUN(
+      ifelse(fixed && !ignore.case, "replace_substring", "replace_substring_regex"),
+      x,
+      options = list(
+        pattern = pattern,
+        replacement = replacement,
+        max_replacements = max_replacements
+      )
+    )
+  }
+}
+
+arrow_stringr_string_replace_function <- function(FUN, max_replacements) {
+  function(string, pattern, replacement) {
+    # Assign stringr pattern modifier functions locally
+    fixed <- function(pattern, ignore_case = FALSE, ...) {
+      check_dots(...)
+      list(pattern = pattern, fixed = TRUE, ignore_case = ignore_case)
+    }
+    regex <- function(pattern, ignore_case = FALSE, ...) {
+      check_dots(...)
+      list(pattern = pattern, fixed = FALSE, ignore_case = ignore_case)
+    }
+    coll <- boundary <- function(...) {
+      stop(
+        "Pattern modifier `",
+        match.call()[[1]],
+        "()` is not supported in Arrow",
+        call. = FALSE
+      )
+    }
+    check_dots <- function(...) {
+      dots <- list(...)
+      if (length(dots)) {
+        warning(
+          "Ignoring pattern modifier ",
+          ngettext(length(dots), "argument ", "arguments "),
+          "not supported in Arrow: ",
+          oxford_paste(names(dots)),
+          call. = FALSE
+        )
+      }
+    }
+    ensure_opts <- function(opts) {
+      if (is.character(opts)) {
+        opts <- list(pattern = opts, fixed = TRUE, ignore_case = FALSE)
+      }
+      opts
+    }
+    opts <- ensure_opts(eval(enexpr(pattern)))
+    arrow_r_string_replace_function(FUN, max_replacements)(
+      pattern = opts$pattern,
+      replacement = replacement,
+      x = string,
+      ignore.case = opts$ignore_case,
+      fixed = opts$fixed
+    )
+  }
+}
+
 # We'll populate these at package load time.
 dplyr_functions <- NULL
 init_env <- function () {

r/src/compute.cpp

@@ -189,6 +189,17 @@ std::shared_ptr<arrow::compute::FunctionOptions> make_compute_options(
     return make_cast_options(options);
   }
 
+  if (func_name == "replace_substring" || func_name == "replace_substring_regex") {
+    using Options = arrow::compute::ReplaceSubstringOptions;
+    int64_t max_replacements = -1;
+    if (!Rf_isNull(options["max_replacements"])) {
+      max_replacements = cpp11::as_cpp<int64_t>(options["max_replacements"]);
+    }
+    return std::make_shared<Options>(cpp11::as_cpp<std::string>(options["pattern"]),
+                                     cpp11::as_cpp<std::string>(options["replacement"]),
+                                     max_replacements);
+  }
+
   return nullptr;
 }
 

r/tests/testthat/test-dplyr-string-functions.R

@@ -0,0 +1,180 @@
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements.  See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership.  The ASF licenses this file
+# to you under the Apache License, Version 2.0 (the
+# "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
+#
+# Unless required by applicable law or agreed to in writing,
+# software distributed under the License is distributed on an
+# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+# KIND, either express or implied.  See the License for the
+# specific language governing permissions and limitations
+# under the License.
+
+library(dplyr)
+library(stringr)
+
+test_that("sub and gsub", {
+  df <- tibble(x = c("Foo", "bar"))
+
+  for(fixed in c(TRUE, FALSE)) {
+
+    expect_dplyr_equal(
+      input %>%
+        transmute(x = sub("Foo", "baz", x, fixed = fixed)) %>%
+        collect(),
+      df
+    )
+    expect_dplyr_equal(
+      input %>%
+        transmute(x = sub("^B.+", "baz", x, ignore.case = FALSE, fixed = fixed)) %>%
+        collect(),
+      df
+    )
+    expect_dplyr_equal(
+      input %>%
+        transmute(x = sub("Foo", "baz", x, ignore.case = FALSE, fixed = fixed)) %>%
+        collect(),
+      df
+    )
+
+  }
+})
+
+test_that("sub and gsub with ignore.case = TRUE and fixed = TRUE", {
+  df <- tibble(x = c("Foo", "bar"))
+
+  # base::sub() and base::gsub() ignore ignore.case = TRUE with a warning when
+  # fixed = TRUE, so we can't use expect_dplyr_equal() for these tests
+  expect_equal(
+    df %>%
+      Table$create() %>%
+      transmute(x = sub("O", "u", x, ignore.case = TRUE, fixed = TRUE)) %>%
+      collect(),
+    tibble(x = c("Fuo", "bar"))
+  )
+  expect_equal(
+    df %>%
+      Table$create() %>%
+      transmute(x = gsub("o", "u", x, ignore.case = TRUE, fixed = TRUE)) %>%
+      collect(),
+    tibble(x = c("Fuu", "bar"))
+  )
+  expect_equal(
+    df %>%
+      Table$create() %>%
+      transmute(x = sub("^B.+", "baz", x, ignore.case = TRUE, fixed = TRUE)) %>%
+      collect(),
+    df # unchanged
+  )
+
+})
+
+test_that("str_replace and str_replace_all", {
+  df <- tibble(x = c("Foo", "bar"))
+
+  library(stringr)
+
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = str_replace_all(x, regex("^F"), "baz")) %>%
+      collect(),
+    df
+  )
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = str_replace(x, regex("^f[A-Z]{2}", ignore_case = TRUE), "baz")) %>%
+      collect(),
+    df
+  )
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = str_replace_all(x, fixed("o"), "u")) %>%
+      collect(),
+    df
+  )
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = str_replace(x, fixed("O"), "u")) %>%
+      collect(),
+    df
+  )
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = str_replace(x, fixed("O", ignore_case = TRUE), "u")) %>%
+      collect(),
+    df
+  )
+
+})
+
+test_that("backreferences", {
+  df <- tibble(x = c("Foo", "bar"))
+
+  expect_dplyr_equal(
+    input %>%
+      transmute(desc = sub(
+        "(?:https?|ftp)://([^/\r\n]+)(/[^\r\n]*)?",
+        "path `\\2` on server `\\1`",
+        url
+        )
+      ) %>%
+      collect(),
+    tibble(url = "https://arrow.apache.org/docs/r/")
+  )
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = str_replace(x, regex("^(\\w)o(.*)", ignore_case = TRUE), "\\1\\2p")) %>%
+      collect(),
+    df
+  )
+})
+
+test_that("edge cases", {
+
+  # in case-insensitive fixed replace, test that "\\E" in the search string and
+  # backslashes in the replacement string are interpreted literally.
+  # this test does not use expect_dplyr_equal() because base::sub() does not
+  # support ignore.case = TRUE when fixed = TRUE.
+  expect_equal(
+    tibble(x = c("\\Q\\e\\D")) %>%
+      Table$create() %>%
+      transmute(x = sub("\\E", "\\L", x, ignore.case = TRUE, fixed = TRUE)) %>%
+      collect(),
+    tibble(x = c("\\Q\\L\\D"))
+  )
+
+  # test that a user's "(?i)" prefix does not break the "(?i)" prefix that's
+  # added in case-insensitive regex replace
+  expect_dplyr_equal(
+    input %>%
+      transmute(x = sub("(?i)^[abc]{3}$", "123", x, ignore.case = TRUE, fixed = FALSE)) %>%
+      collect(),
+    tibble(x = c("ABC"))
+  )
+
+})
+
+test_that("errors and warnings", {
+  df <- tibble(x = c("Foo", "bar"))
+
+  # This condition generates an error, but abandon_ship() catches the error,
+  # issues a warning, and pulls the data into R
+  expect_warning(
+    df %>%
+      Table$create() %>%
+      mutate(x = str_replace_all(x, coll("o", locale = "en"), "ó")) %>%
+      collect(),
+    "not supported"
+  )
+  expect_warning(
+    df %>%
+      Table$create() %>%
+      transmute(x = str_replace_all(x, regex("o", multiline = TRUE), "u")),
+    "Ignoring pattern modifier argument not supported in Arrow: \"multiline\""
+  )
+})