change extraction and replace methods to be more consistent to base R

NEWS.md

@@ -39,13 +39,17 @@
    Because there was no recorded direct usage for any of these, I am opting to just rip the band-aid
    off and un-export them in this release as opposed to waiting a full cycle more to do so.
 
+1. A replacement in an integer64 vector using `[<-` or `[[<-` with a character leads to an R consistent 
+   coercion of the integer64 object to a character object.
+
 ## NEW FEATURES
 
 1. `anyNA` gets an `integer64` method. Thanks @hcirellu.
 
 ## BUG FIXES
 
 1. `min.integer64`, `max.integer64` and `range.integer64` now support `na.rm=TRUE` correctly when combining across mutliple inputs like `min(x, NA_integer64_, na.rm=TRUE)` (#142).
+1. `[.integer64` now runs faster and correctly regarding `NA` and arrays. (#176)
 
 ## NOTES
 

R/integer64.R

@@ -104,14 +104,15 @@ NULL
 #' Methods to extract and replace parts of an integer64 vector.
 #'
 #' @param x an atomic vector
-#' @param i indices specifying elements to extract
+#' @param i,j indices specifying elements to extract
+#' @param drop relevant for matrices and arrays. If TRUE the result is coerced to the lowest possible dimension.
 #' @param value an atomic vector with values to be assigned
 #' @param ... further arguments to the [NextMethod()]
 #'
 #' @note
 #'   You should not subscript non-existing elements and not use `NA`s as subscripts.
 #'   The current implementation returns `9218868437227407266` instead of `NA`.
-#' @returns A vector or scalar of class 'integer64'
+#' @returns A vector, matrix, array or scalar of class 'integer64'
 #' @keywords classes manip
 #' @seealso [`[`][base::Extract] [integer64()]
 #' @examples
@@ -846,90 +847,122 @@ str.integer64 <- function(object,
 
 #' @rdname extract.replace.integer64
 #' @export
-`[.integer64` <- function(x, i, ...) {
-    cl <- oldClass(x)
-    ret <- NextMethod()
-    # Begin NA-handling from Leonardo Silvestri
-    if (!missing(i)) {
-        if (inherits(i, "character")) {
-          na_idx <- union(which(!(i %in% names(x))), which(is.na(i)))
-          if (length(na_idx))
-                ret[na_idx] <- NA_integer64_
-        } else {
-      ni <- length(i)
-      nx <- length(x)
-      if (inherits(i, "logical")) {
-            if (ni>nx) {
-              na_idx <- is.na(i) | (i & seq_along(i)>nx)
-              na_idx <- na_idx[is.na(i) | i]
-            } else {
-          i <- i[is.na(i) | i]
-          na_idx <- rep_len(is.na(i), length(ret))
-            }
-          } else if (ni && min(i, na.rm=TRUE)>=0L) {
-            i <- i[is.na(i) | i>0L]
-            na_idx <- is.na(i) | i>length(x)
-          } else {
-            na_idx <- FALSE
-          }
-          if (any(na_idx))
-                ret[na_idx] <- NA_integer64_
-        }
+`[.integer64` = function(x, i, j, ..., drop=TRUE) {
+  args = lapply(as.list(sys.call())[-(1:2)], {function(el) {
+    if(is.symbol(el) && el == substitute()) return(el)
+    el = eval(el, parent.frame(3L))   
+    if (is.integer64(el))
+      el = as.integer(el)
+    el
+  }})
+  args$drop = FALSE
+  if (length(args) == 1L) return(x)
+  oldClass(x) = NULL
+  ret = do.call("[", c(list(x=x), args))
+  NA_integer64_real = NA_integer64_
+  oldClass(NA_integer64_real) = NULL
+
+  # NA handling
+  if (length(dim(ret)) <= 1L) {
+    # vector mode
+    if (!is.symbol(args[[1L]]) || args[[1L]] != substitute()) {
+      arg1Value = args[[1L]]
+      if (is.logical(arg1Value)) {
+        ret[is.na(arg1Value[arg1Value])] = NA_integer64_real
+      } else if (is.character(arg1Value)) {
+        ret[is.na(arg1Value) | arg1Value == "" | !arg1Value %in% names(x)] = NA_integer64_real
+      } else if (anyNA(arg1Value) || suppressWarnings(max(arg1Value, na.rm=TRUE)) > length(x)) {
+        arg1Value = arg1Value[arg1Value != 0]
+        ret[which(is.na(arg1Value) | arg1Value > length(x))] = NA_integer64_real
+      }
     }
-    # End NA-handling from Leonardo Silvestri
-    oldClass(ret) <- cl
-    remcache(ret)
-    ret
-}
-
-
-`[.integer64` <- function(x, i, ...) {
-  cl <- oldClass(x)
-  ret <- NextMethod()
-  # Begin NA-handling from Leonardo Silvestri
-  if (!missing(i)) {
-    if (inherits(i, "character")) {
-      na_idx <- union(which(!(i %in% names(x))), which(is.na(i)))
-      if (length(na_idx))
-        ret[na_idx] <- NA_integer64_
-    } else {
-      na_idx <- is.na(rep(TRUE, length(x))[i])
-      if (any(na_idx))
-        ret[na_idx] <- NA_integer64_
+  } else {
+    # array/matrix mode
+    dimSelect = args[seq_along(dim(x))]
+    for (ii in seq_along(dimSelect)) {
+      if (is.symbol(dimSelect[[ii]]) && dimSelect[[ii]] == substitute()) next
+      dsValue = dimSelect[[ii]]
+      if (is.logical(dsValue) && anyNA(dsValue)) {
+        naIndex = which(is.na(seq_len(dim(x)[ii])[dsValue]))
+      } else {
+        naIndex = which(is.na(dsValue[dsValue != 0L]))
+      }
+      if (length(naIndex)) {
+        setArgs = rep(list(substitute()), length(dimSelect))
+        setArgs[[ii]] = naIndex
+        ret = do.call("[<-", c(list(x=ret), setArgs, list(value=NA_integer64_real)))
+      }
     }
   }
-  # End NA-handling from Leonardo Silvestri
-  oldClass(ret) <- cl
-  remcache(ret)
+
+  # dimension handling
+  if (!isFALSE(drop) && !is.null(dim(ret))) {
+    newDim = dim(ret)[dim(ret) != 1L]
+    dim(ret) = {if (length(newDim)) newDim else NULL}
+    if(length(dim(ret)) <= 1L)
+      dim(ret) = NULL
+  }
+
+  oldClass(ret) = "integer64"
   ret
 }
 
 #' @rdname extract.replace.integer64
 #' @export
-`[<-.integer64` <- function(x, ..., value) {
-  cl <- oldClass(x)
-  value <- as.integer64(value)
-  ret <- NextMethod()
-  oldClass(ret) <- cl
+`[<-.integer64` = function(x, ..., value) {
+  sc = as.list(sys.call())
+  args = lapply(sc[-c(1:2, length(sc))], {function(el) {
+    if(is.symbol(el) && el == substitute()) return(el)
+    el = eval(el, parent.frame(3L))   
+    if (is.integer64(el))
+      el = as.integer(el)
+    el
+  }})
+  if (is.character(value) || is.complex(value) || (is.double(value) && class(value)[1L] != "numeric")) {
+    args$value = value
+    x = structure(as(x, class(value)[1L]), dim = dim(x), dimnames = dimnames(x))
+    ret = do.call("[<-", c(list(x=x), args))
+  } else {
+    args$value = as.integer64(value)
+    oldClass(x) = NULL
+    ret = do.call("[<-", c(list(x=x), args))
+    oldClass(ret) = "integer64"
+  }
   ret
 }
 
 #' @rdname extract.replace.integer64
 #' @export
-`[[.integer64` <- function(x, ...) {
-  cl <- oldClass(x)
-  ret <- NextMethod()
-  oldClass(ret) <- cl
+`[[.integer64` = function(x, ...) {
+  args = lapply(list(...), {function(el) {
+    if (is.integer64(el))
+      el = as.integer(el)
+    el
+  }})
+  oldClass(x) = NULL
+  ret = do.call("[[", c(list(x=x), args))
+  oldClass(ret) = "integer64"
   ret
 }
 
 #' @rdname extract.replace.integer64
 #' @export
-`[[<-.integer64` <- function(x, ..., value) {
-  cl <- oldClass(x)
-  value <- as.integer64(value)
-  ret <- NextMethod()
-  oldClass(ret) <- cl
+`[[<-.integer64` = function(x, ..., value) {
+  args = lapply(list(...), {function(el) {
+    if (is.integer64(el))
+      el = as.integer(el)
+    el
+  }})
+  if (is.character(value) || is.complex(value) || (is.double(value) && class(value)[1L] != "numeric")) {
+    args$value = value
+    x = structure(as(x, class(value)[1L]), dim = dim(x), dimnames = dimnames(x))
+    ret = do.call("[[<-", c(list(x=x), args))
+  } else {
+    value = as.integer64(value)
+    oldClass(x) = NULL
+    ret = do.call("[[<-", c(list(x=x), args, list(value=value)))
+    oldClass(ret) = "integer64"
+  }
   ret
 }
 

tests/testthat/helper.R

@@ -1,13 +1,15 @@
 # TODO(#45): use matrix() directly
-matrix64 = function(x, nrow=1L, ncol=1L, byrow=FALSE) {
+matrix64 = function(x, nrow=1L, ncol=1L, byrow=FALSE, dimnames=NULL) {
   x = as.integer64(x)
   if (byrow) {
     dim(x) = c(ncol, nrow)
-    t(x)
+    x = t(x)
+    dimnames(x) = dimnames
   } else {
     dim(x) = c(nrow, ncol)
-    x
+    dimnames(x) = dimnames
   }
+  x
 }
 
 array64 = function(x, dim) {

tests/testthat/test-bit64-package.R

@@ -55,28 +55,28 @@ test_that("Minus and plus edge cases and 'rev'", {
 
 test_that("'range.integer64', multiplication, integer division, sqrt, power, and log", {
   i64 = integer64(63L)
-  i64[1L] = 1.0
+  i64[1L] = 1L
   for (i in 2:63)
-    i64[i] = 2.0 * i64[i-1L]
+    i64[i] = 2L * i64[i-1L]
   expect_true(identical.integer64(i64 * rev(i64), rep(i64[63L], 63L)))
   for (i in 63:2)
-    i64[i-1L] = i64[i] %/% 2.0
+    i64[i-1L] = i64[i] %/% 2L
   expect_true(identical.integer64(i64 * rev(i64), rep(i64[63L], 63L)))
   for (i in 63:2)
-    i64[i-1L] = i64[i] / 2.0
+    i64[i-1L] = as.integer64(i64[i] / 2L)
   expect_true(identical.integer64(i64 * rev(i64), rep(i64[63L], 63L)))
   expect_true(identical.integer64(
     c(
-      -i64[63L] - (i64[63L] - 1.0),
-      i64[63L] + (i64[63L] - 1.0)
+      -i64[63L] - (i64[63L] - 1L),
+      i64[63L] + (i64[63L] - 1L)
     ),
     lim.integer64()
   ))
 
-  expect_true(identical.integer64(i64[-1L] %/%2.0 * as.integer64(2L), i64[-1L]))
-  expect_true(identical.integer64(i64[-1L] %/%2L * as.integer64(2L), i64[-1L]))
-  expect_true(identical.integer64(i64[-1L] / 2.0 * as.integer64(2L), i64[-1L]))
+  expect_true(identical.integer64(i64[-1L] %/% 2.0 * as.integer64(2L), i64[-1L]))
+  expect_true(identical.integer64(i64[-1L] %/% 2L * as.integer64(2L), i64[-1L]))
   expect_true(identical.integer64(i64[-1L] / 2.0 * as.integer64(2L), i64[-1L]))
+  expect_true(identical.integer64(i64[-1L] / 2L * as.integer64(2L), i64[-1L]))
 
   expect_true(identical.integer64(i64[-63L] * 2.0 %/% 2.0, i64[-63L]))
   expect_true(identical.integer64(i64[-63L] * 2L %/% 2L, i64[-63L]))