[R] Define Math group generics

[asfimport]

Following ARROW-13280 we now support log, trigonometry, and other functions that are in the Math S3 generic, so we should define it like how we've already done for Ops.

Reporter: Neal Richardson / @nealrichardson
Assignee: Dewey Dunnington / @paleolimbot

PRs and other links:

• GitHub Pull Request #12432

_{Note: This issue was originally created as ARROW-13337. Please see the migration documentation for further details.}

[asfimport]

Dewey Dunnington / @paleolimbot:
When trying to do some math with decimal types, I noticed this as well. Many users will use the dplyr bindings (where these are accessible), but it's useful to do this on Arrays and Scalars, too, particularly for decimal types whose math isn't accessible anywhere else in R.

Some template code that might be helpful from carrow:

#' @export
Math.carrow_vctr <- function(x, ...) {
  switch(
    .Generic,
    abs =, sign =, sqrt =,
    floor =, ceiling =, trunc =,
    round =, signif =,
    exp =, log =, expm1 =, log1p =,
    cos =, sin =, tan =,
    cospi =, sinpi =, tanpi =,
    acos =, asin =, atan =,
    cosh =, sinh =, tanh =,
    acosh =, asinh =, atanh =,
    lgamma =, gamma =, digamma =, trigamma =,
    cumsum =, cumprod =, cummax =, cumin = {
      assert_arrow("Math group generics")
      array <- as_arrow_array(x)
      arrow_array <- from_carrow_array(array, arrow::Array)
      getNamespace("base")[[.Generic]](arrow_array)
    },
    stop(sprintf("Math generic '%s' not supported for carrow_vctr()", .Generic)) # nocov
  )
}

#' @export
Ops.carrow_vctr <- function(e1, e2) {
  if (missing(e2)) {
    switch(
      .Generic,
      "!" =, "+" =, "-" = {
        assert_arrow("Unary Ops group generics")
        array <- as_carrow_array(e1)
        arrow_array <- from_carrow_array(array, arrow::Array)
        result <- getNamespace("base")[[.Generic]](arrow_array)
        return(as_carrow_vctr(result))
      },
      # R catches these before we do with 'invalid unary operator'
      stop(sprintf("Unary '%s' not supported for carrow_vctr()", .Generic)) # nocov
    )
  }

  switch(
    .Generic,
    "+" =, "-" =, "*" =, "/" =, "^" =, "%%" =, "%/%" =,
    "&" =, "|" =, "!" =,
    "==" =, "!=" =, "<" =, "<=" =, ">=" =, ">" = {
      assert_arrow("Ops group generics")
      vctr1 <- as_carrow_vctr(e1)
      vctr2 <- as_carrow_vctr(e2)
      array1 <- as_carrow_array(vctr1)
      array2 <- as_carrow_array(vctr2)
      arrow_array1 <- from_carrow_array(array1, arrow::Array)
      arrow_array2 <- from_carrow_array(array2, arrow::Array)

      result <- getNamespace("base")[[.Generic]](arrow_array1, arrow_array2)
      as_carrow_vctr(result)
    },
    stop(sprintf("Ops generic '%s' not supported for carrow_vctr()", .Generic)) # nocov
  )
}

#' @export
Summary.carrow_vctr <- function(x, ..., na.rm = FALSE) {
  assert_arrow("Math group generics")
  switch(
    .Generic,
    all =, any =,
    sum =, prod =,
    min =, max =,
    range = {
      # make sure dots are empty because we ignore them
      stopifnot(...length() == 0L)

      array <- as_carrow_array(x)
      arrow_array <- from_carrow_array(array, arrow::Array)
      getNamespace("base")[[.Generic]](arrow_array, na.rm = na.rm)
    },
    stop(sprintf("Summary generic '%s' not supported for carrow_vctr()", .Generic)) # nocov
  )
}

#' @export
Complex.carrow_vctr <- function(z) {
  stop("Complex group generics are not supported for carrow_vctr", call. = FALSE)
}

And some tests that might be useful to copy:

test_that("Math generics work", {
  # none of these are implemented in Arrow, so none are here either
})

test_that("Ops numeric generics work", {
  skip_if_not_installed("arrow")

  v1 <- c(1:5, NA)
  v2 <- 6:11
  vctr1 <- as_carrow_vctr(v1)
  vctr2 <- as_carrow_vctr(v2)

  # unary expressions are broken in Arrow so these don't work
  # expect_identical(
  #   from_carrow_array(as_carrow_array(+vctr1)),
  #   +v1
  # )
  #
  # expect_identical(
  #   from_carrow_array(as_carrow_array(-vctr1)),
  #   -v1
  # )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 + vctr2)),
    v1 + v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 - vctr2)),
    v1 - v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 * vctr2)),
    v1 * v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 / vctr2)),
    v1 / v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 ^ vctr2)),
    as.integer(v1 ^ v2)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 %% vctr2)),
    v1 %% v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 %/% vctr2)),
    v1 %/% v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 + vctr2)),
    v1 + v2
  )
})

test_that("Ops logical generics work", {
  skip_if_not_installed("arrow")
  skip("until logical conversion is improved")

  v1 <- c(TRUE, TRUE, FALSE, FALSE, NA, NA, NA)
  v2 <- c(TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, NA)
  vctr1 <- as_carrow_vctr(v1)
  vctr2 <- as_carrow_vctr(v2)

  expect_identical(
    from_carrow_array(as_carrow_array(!vctr1)),
    !v1
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 & vctr2)),
    v1 & v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 & vctr2)),
    v1 | v2
  )
})

test_that("Ops comparison generics work", {
  skip_if_not_installed("arrow")
  skip("until logical conversion is improved")

  v1 <- c(1, 2, 3, 4, 5, 1, NA, 3, NA, 5, NA)
  v2 <- c(5, 4, 3, 2, 1, NA, 4, NA, 2, 1, NA)
  vctr1 <- as_carrow_vctr(v1)
  vctr2 <- as_carrow_vctr(v2)

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 == vctr2)),
    v1 == v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 != vctr2)),
    v1 != v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 < vctr2)),
    v1 < v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 <= vctr2)),
    v1 <= v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 >= vctr2)),
    v1 >= v2
  )

  expect_identical(
    from_carrow_array(as_carrow_array(vctr1 > vctr2)),
    v1 > v2
  )
})

test_that("Summary numeric generics work", {
  skip_if_not_installed("arrow")

  v1 <- c(1:5, NA)
  vctr1 <- as_carrow_vctr(v1)

  expect_identical(
    from_carrow_array(as_carrow_array(sum(vctr1, na.rm = TRUE))),
    as.double(sum(v1, na.rm = TRUE))
  )

  expect_identical(
    from_carrow_array(as_carrow_array(sum(vctr1, na.rm = FALSE))),
    as.double(sum(v1, na.rm = FALSE))
  )

  expect_identical(
    from_carrow_array(as_carrow_array(min(vctr1, na.rm = TRUE))),
    min(v1, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(min(vctr1, na.rm = FALSE))),
    min(v1, na.rm = FALSE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(max(vctr1, na.rm = TRUE))),
    max(v1, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(max(vctr1, na.rm = FALSE))),
    max(v1, na.rm = FALSE)
  )

  skip("not all Summary generics are implemented in Arrow")

  expect_identical(
    from_carrow_array(as_carrow_array(range(vctr1, na.rm = TRUE))),
    range(v1, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(range(vctr1, na.rm = FALSE))),
    range(v1, na.rm = FALSE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(prod(vctr1, na.rm = TRUE))),
    prod(v1, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(prod(vctr1, na.rm = FALSE))),
    prod(v1, na.rm = FALSE)
  )
})

test_that("Summary logical generics work", {
  skip_if_not_installed("arrow")
  skip("until logical conversion is fixed")

  v1 <- c(FALSE, FALSE, NA)
  v2 <- c(TRUE, TRUE, NA)
  vctr1 <- as_carrow_vctr(v1)
  vctr2 <- as_carrow_vctr(v2)

  expect_identical(
    from_carrow_array(as_carrow_array(any(vctr1, na.rm = TRUE))),
    any(v1, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(any(vctr1, na.rm = FALSE))),
    any(v1, na.rm = FALSE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(any(vctr2, na.rm = TRUE))),
    any(v2, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(any(vctr2, na.rm = FALSE))),
    any(v2, na.rm = FALSE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(all(vctr1, na.rm = TRUE))),
    all(v1, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(all(vctr1, na.rm = FALSE))),
    all(v1, na.rm = FALSE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(all(vctr2, na.rm = TRUE))),
    all(v2, na.rm = TRUE)
  )

  expect_identical(
    from_carrow_array(as_carrow_array(all(vctr2, na.rm = FALSE))),
    all(v2, na.rm = FALSE)
  )
})

[asfimport]

Nicola Crane / @thisisnic:
Issue resolved by pull request 12432
#12432