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

NEWS.md

@@ -41,6 +41,9 @@
 
 1. `as.integer64.integer64` returns a plain `integer64` vector stripped of any attributes. This is consistent with R like behavior, e.g. `as.integer.integer`.
 
+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.
@@ -59,6 +62,7 @@
 1. `sortfin(integer64(), 1:10)` no longer segfaults (#164).
 1. `orderfin(as.integer64(10:1), 1:3, 8:11)` enforces that `table` be sorted by `order` instead of segfaulting (#166).
 1. `ordertab()` no longer segfaults when `nunique` is smaller than the actual number of unique values (#168).
+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
@@ -821,92 +822,158 @@ str.integer64 <- function(object,
   invisible()
 }
 
-#' @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_
-        }
+# TODO(#59): With the PR(#209) to add a generic for table() a similar function is used. This here is better so that it shall replace the other.
+choose_sys_call = function(function_names, name_to_display=NULL) {
+  sc = sys.calls()
+  sc_length = length(sc)
+  if (sc_length == 1L || length(function_names) == 0L) return(sc[[1L]])
+  sc_char = vapply(sc, function(el) if (is.function(el[[1L]])) "" else rev(as.character(el[[1L]]))[1L], "")
+  sel = rev(which(sc_char == function_names[length(function_names)]))[1L]
+  if (is.na(sel)) 
+    sel = 1L
+  for (i in rev(seq_along(function_names))[-1L]) {
+    if (sel == 1L || sc_char[sel - 1L] != function_names[i])
+      break
+    sel = sel - 1L
+  }
+  sc = sc[[sel]]
+  if (!is.null(name_to_display))
+    sc[[1L]] = as.name(name_to_display)
+  sc
+}
+withCallingHandlers_and_choose_call = function(expr, function_names, name_to_display=NULL) {
+  wch = str2lang("withCallingHandlers(expr, error=error, warning=warning)")
+  wch[[2L]] = sys.call()[[2L]] # expr
+  wch[[3L]] = {function(function_names, name_to_display) 
+    function(e) {stop(errorCondition(e$message, call=choose_sys_call(function_names, name_to_display)))}
+  }(function_names, name_to_display)
+  wch[[4L]] = {function(function_names, name_to_display) 
+    function(w) {
+      warning(warningCondition(w$message, call=choose_sys_call(function_names, name_to_display)))
+      invokeRestart("muffleWarning")
     }
-    # End NA-handling from Leonardo Silvestri
-    oldClass(ret) <- cl
-    remcache(ret)
-    ret
+  }(function_names, name_to_display)
+  eval(wch, envir=parent.frame())
 }
 
-
-`[.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_
+#' @rdname extract.replace.integer64
+#' @export
+`[.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
+  withCallingHandlers_and_choose_call({ret = do.call("[", c(list(x=x), args))}, c("[", "[.integer64"))  
+  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
+      }
+    }
+  } 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))
+    withCallingHandlers_and_choose_call({ret = do.call("[<-", c(list(x=x), args))}, c("[<-", "[<-.integer64"))  
+  } else {
+    args$value = as.integer64(value)
+    oldClass(x) = NULL
+    withCallingHandlers_and_choose_call({ret = do.call("[<-", c(list(x=x), args))}, c("[<-", "[<-.integer64"))  
+    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
+  withCallingHandlers_and_choose_call({ret = do.call("[[", c(list(x=x), args))}, c("[[", "[[.integer64"))  
+  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))
+    withCallingHandlers_and_choose_call({ret = do.call("[[<-", c(list(x=x), args))}, c("[[<-", "[[<-.integer64"))  
+  } else {
+    args$value = as.integer64(value)
+    oldClass(x) = NULL
+    withCallingHandlers_and_choose_call({ret = do.call("[[<-", c(list(x=x), args))}, c("[[<-", "[[<-.integer64"))  
+    oldClass(ret) = "integer64"
+  }
   ret
 }
 

R/zzz.R

@@ -8,6 +8,27 @@
 # */
 
 # nocov start
+.onLoad = function(libname, pkgname) {
+
+  ns = parent.env(environment())
+
+  if (getRversion() < "3.6.0") {
+    # backport condition constructors from R 3.6.0
+    errorCondition = function(message, ..., class = NULL, call = NULL) 
+      structure(list(message = as.character(message), call = call, ...), class = c(class, "error", "condition"))
+    assign("errorCondition", errorCondition, envir = ns, inherits = FALSE)
+
+    warningCondition = function(message, ..., class = NULL, call = NULL) 
+      structure(list(message = as.character(message), call = call, ...), class = c(class, "warning", "condition"))
+    assign("warningCondition", warningCondition, envir = ns, inherits = FALSE)
+
+    str2lang = function(s) 
+      parse(text = s, keep.source=FALSE)[[1L]]
+    assign("str2lang", str2lang, envir = ns, inherits = FALSE)
+  }
+
+}
+
 .onUnload <- function(libpath) {
   library.dynam.unload("bit64", libpath)
 }

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

@@ -57,26 +57,26 @@ test_that("'range.integer64', multiplication, integer division, sqrt, power, and
   i64 = integer64(63L)
   i64[1L] = 1.0
   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]))