c cbind rbind more consistent to base R (#253)

* extend c, cbind, and rbind

* consistent use of Rboolean (#251)

* R consistent integer division and modulo operation (#250)

* r consistent integer division

* tweak NEWS

---------

Co-authored-by: Michael Chirico <chiricom@google.com>

* fix test ancient

* add origin for as.{Date,POSIXct,POSIXlt} for ancient

* `stringsAsFactors=FALSE` for ancient

* fix ancient

* skip a test for ancient

* fix cbind tests for ancient

* skip cbind tests for ancient

* skip rbind tests for ancient

* fix target_class_and_sample_value for missing .bit64.suppressPromoteInteger64ToCharacterMessage

* merge target_class_and_sample_value in  target_class

* touch-ups to c()

* touch-ups to rbind,cbind

* missing ')'

* inherits() instead of class()

Co-authored-by: Michael Chirico <chiricom@google.com>

* remove eval(str2lang())

* another round of touch-up

* vestigial ')'

* missing '{'

* simplify (?) replacement helper for cbind

* more expect_same_error

* switch branch order

* fix updated logical condition for unnested branches

* revert unrelated switch to expect_same_error

* replace rbind helper too

* fix helper argument name

Co-authored-by: Michael Chirico <michaelchirico4@gmail.com>

* refactoring, add comments, add news

* extract replace_dimnames

* tweak NEWS

* fix deparse.level problems

* skip ancient test

* more canonical patrick (avoid expand.grid), don't test 4

* raw cases

* missing symmetric cases for difftime, factor, ordered

* explicitly ignore coercion warning before error

---------

Co-authored-by: Michael Chirico <chiricom@google.com>
Co-authored-by: Michael Chirico <michaelchirico4@gmail.com>

Author: hcirellu

NEWS.md

@@ -8,6 +8,8 @@
 
    All of these have observed downstream calls directly. If the call is in a CRAN/Bioconductor package, I'll be reaching out to help migrate onto the generic. This will probably take at least a year, so don't expect this to induce a CRAN release _per se_ until 2027 (although you should certainly aim to slip this in to your next release in the meantime).
 
+1. When integer64 and character are combined, the result will be character. This prevents loss of information, e.g. in `c(as.integer64(1L), "a")` and `c(as.integer64(1L), "999999999999999999999999")`. To try this in advance for `c.integer64`, `cbind.integer64`, `rbind.integer64`, `[.integer64<-`, `[[.integer64<-`, `union`, `intersect`, `setdiff`, `setdiff` and `is.element` one can set the option `bit64.promoteInteger64ToCharacter=TRUE`.
+
 ## BREAKING CHANGES
 
 1. {bit64} no longer `Depends` on {bit}; instead it `Imports` it. Please file an issue if this
@@ -58,6 +60,7 @@
 1. A replacement in an integer64 vector or array using `[<-` or `[[<-` with a complex or POSIXct leads to an R consistent coercion of the integer64 object to a complex or POSIXct object and not just an error. Thanks @hcirellu.
 1. `union`, `setdiff`, `intersect`, `setequal` and `is.element` get an overload to work correctly with `integer64` (#182).
 1. The methods of the 'Ops' group (e.g. `+`, `&`, `==`) now support dispatch for both arguments so that e.g. `difftime * integer64` works consistent to R (#179). Thanks @hcirellu. Note that this relies on `chooseOpsMethod()` and thus R 4.3.0.
+1. `c.integer64`, `cbind.integer64` and `rbind.integer64` now support combining with lists and recursion as `base::c`, `base::cbind` and `base::rbind` do (#252). In addition, by setting the option `bit64.promoteInteger64ToCharacter=TRUE` the methods return character if integer64 and character are combined. Thanks @hcirellu.
 
 ## BUG FIXES
 

R/integer64.R

@@ -224,11 +224,12 @@ NULL
 #' @param recursive logical. If `recursive = TRUE`, the function
 #'   recursively descends through lists (and pairlists) combining all
 #'   their elements into a vector.
+#' @param deparse.level integer controlling the construction of labels in the case of non-matrix-like arguments
 #'
 #' @returns
-#'   [c()] returns a integer64 vector of the total length of the input
+#'   [c()] returns a vector of the appropriate mode. This could be a integer64 vector or a list of objects  
 #'
-#'   [cbind()] and [rbind()] return a integer64 matrix
+#'   [cbind()] and [rbind()] return a matrix, data.frame or list with dimensions
 #'
 #' @note
 #' R currently only dispatches generic 'c' to method 'c.integer64' if the
@@ -1031,58 +1032,205 @@ position_args_with_int64_to_int_coercion = function(sys_call, eval_frame, skipLa
 
 #' @rdname c.integer64
 #' @export
-c.integer64 = function(..., recursive = FALSE) {
-  l = list(...)
-  for (k in seq_along(l)) {
-    if (recursive && is.list(l[[k]])) {
-      l[[k]] <- do.call(c.integer64, c(l[[k]], list(recursive = TRUE)))
-    } else {
-      if (!is.integer64(l[[k]])) {
-        nam <- names(l[[k]])
-        l[[k]] <- as.integer64(l[[k]])
-        names(l[[k]]) <- nam
+c.integer64 = function(..., recursive=FALSE) {
+  # This check can be dropped in the future when c.integer64 is not exported anymore
+  if (...length() == 0L) return(NULL)
+  dots = list(...)
+  
+  if (!isTRUE(recursive) && any(vapply(dots, is.list, FALSE))) {
+    return(unlist(lapply(dots, function(el) if (inherits(el, "POSIXlt")) el else as.list(el)), recursive=FALSE))
+  }
+  
+  value_class = target_class(dots, recursive=recursive, POSIXltAsCharacter=TRUE)
+  # find positions of elements to be converted
+  if(value_class == "integer64") {
+    # integer64 doesn't have to be converted, but `oldClass(val) = NULL` has to be applied
+    checkFunc = Negate(is.null)
+  } else {
+    checkFunc = is.integer64
+  }
+  findPositionsOfItemsToConvert = function(x) {
+    res = list()
+    for (ii in seq_along(x)) {
+      if (inherits(x[[ii]], c("list", "data.frame"))) {
+        res = c(res, lapply(findPositionsOfItemsToConvert(x[[ii]]), function(el) c(ii, el)))
+      } else if (checkFunc(x[[ii]])) {
+        res = c(res, list(ii))
       }
-      oldClass(l[[k]]) <- NULL
     }
+    res
   }
-  ret = do.call(c, l)
-  oldClass(ret) = "integer64"
+  for (idx in findPositionsOfItemsToConvert(dots)) {
+    val = dots[[idx]]
+    if (inherits(val, "POSIXlt")) {
+      val = lapply(unclass(val), as, value_class)
+    } else {
+      val = as(val, value_class)
+      if (value_class == "integer64")
+        oldClass(val) = NULL
+    }
+    dots[[idx]] = val
+  }
+
+  ret = do.call(c, c(dots, list(recursive=recursive)))
+  if (value_class == "integer64")
+    oldClass(ret) = value_class
   ret
 }
 
+# helper function to generate names for cbind/rbind if missing; it is not intended to be exported
+make_names_for_cbind = function(sys_call, dots, deparse.level=1) {
+  nd = names(dots)
+  if (!deparse.level %in% c(1L, 2L)) return(nd)
+  if (is.null(nd)) 
+    nd = character(length(dots))
+  
+  sys_call_dots = sys_call[-1L][seq_along(dots)]
+  sel = !logical(length(sys_call_dots))
+  if (deparse.level == 1L)
+    sel = vapply(sys_call_dots, is.symbol, FALSE)
+  sel = sel & nd == "" & !vapply(dots, function(el) length(el) == 1L && is.na(el), FALSE)
+  nd[sel] = as.character(sys_call_dots[sel])
+  nd
+}
+
 #' @rdname c.integer64
 #' @export
-cbind.integer64 = function(...) {
-  l = list(...)
-    K <- length(l)
-  for (k in 1:K) {
-        if (!is.integer64(l[[k]])) {
-            nam <- names(l[[k]])
-            l[[k]] <- as.integer64(l[[k]])
-            names(l[[k]]) <- nam
+cbind.integer64 = function(..., deparse.level=1) {
+  dots = list(...)
+  value_class = target_class(dots, recursive=FALSE)
+  
+  # find positions of elements to be converted
+  if(value_class == "integer64") {
+    # integer64 doesn't have to be converted, but `oldClass(val) = NULL` has to be applied
+    checkFunc = Negate(is.null)
+  } else {
+    checkFunc = is.integer64
+  }
+  positionsOfItemsToConvert = which(vapply(dots, function(el) !is.list(el) && checkFunc(el), FALSE, USE.NAMES=FALSE))
+
+  # set names if missing  
+  names(dots) = make_names_for_cbind(sys.call(sys.nframe() - 1L), dots, deparse.level)
+  # convert relevant items
+  for (idx in positionsOfItemsToConvert) {
+    val = dots[[idx]]
+    val = structure(as(val, value_class), dim=dim(val), dimnames=dimnames(val), names=names(val))
+    if (value_class == "integer64")
+      oldClass(val) = NULL
+    dots[[idx]] = val
+  }
+  ret = withCallingHandlers_and_choose_call(
+    do.call(cbind, c(dots, list(deparse.level=deparse.level))), 
+    c("cbind", "cbind"),
+    callStack = sys.calls()
+  )
+  
+  # restore integer64 class
+  if (value_class == "integer64") {
+    if (is.list(ret)) {
+      estimatedColumnIndices = lapply(dots, function(el) {
+        res = ncol(el)
+        if (is.null(res)) 
+          res = as.integer(length(el) > 0L)
+        res
+      })
+      lastValue = 0L
+      for (ii in seq_along(estimatedColumnIndices)) {
+        estimatedColumnIndices[[ii]] = lastValue + seq_len(estimatedColumnIndices[[ii]])
+        lastValue = lastValue + length(estimatedColumnIndices[[ii]])
+      }
+      nrow_ret = nrow(ret)
+      for (idx in positionsOfItemsToConvert) {
+        for (ii in estimatedColumnIndices[[idx]]) {
+          if (is.data.frame(ret)) {
+            oldClass(ret[[ii]]) = value_class
+          } else {
+            for (jj in seq_len(nrow_ret))
+              oldClass(ret[[(ii - 1L)*nrow_ret + jj]]) = value_class
+          }
         }
-        oldClass(l[[k]]) <- NULL
+      }
+    } else {
+      oldClass(ret) = value_class
+    }
   }
-  ret = do.call(cbind, l)
-  oldClass(ret) = "integer64"
   ret
 }
 
 #' @rdname c.integer64
 #' @export
-rbind.integer64 = function(...) {
-  l = list(...)
-    K <- length(l)
-  for (k in 1:K) {
-        if (!is.integer64(l[[k]])) {
-            nam <- names(l[[k]])
-            l[[k]] <- as.integer64(l[[k]])
-            names(l[[k]]) <- nam
+rbind.integer64 = function(..., deparse.level=1) {
+  dots = list(...)
+  value_class = target_class(dots, recursive=TRUE)
+  
+  # find positions of elements to be converted
+  if(value_class == "integer64") {
+    # integer64 doesn't have to be converted, but `oldClass(val) = NULL` has to be applied
+    checkFunc = Negate(is.null)
+  } else {
+    checkFunc = is.integer64
+  }
+  findPositionsOfItemsToConvert = function(x) {
+    res = list()
+    for (ii in seq_along(x)) {
+      if (is.data.frame(x[[ii]])) {
+        res = c(res, lapply(findPositionsOfItemsToConvert(x[[ii]]), function(el) c(ii, el)))
+      } else if (checkFunc(x[[ii]]) && !is.list(x[[ii]])) {
+        res = c(res, list(ii))
+      }
+    }
+    res
+  }
+  positionsOfItemsToConvert = findPositionsOfItemsToConvert(dots)
+
+  # set names if missing  
+  names(dots) = make_names_for_cbind(sys.call(sys.nframe() - 1L), dots, deparse.level)
+  # convert relevant items
+  for (idx in positionsOfItemsToConvert) {
+    val = dots[[idx]]
+    val = structure(as(val, value_class), dim=dim(val), dimnames=dimnames(val), names=names(val))
+    if (value_class == "integer64")
+      oldClass(val) = NULL
+    dots[[idx]] = val
+  }
+  ret = withCallingHandlers_and_choose_call(
+    do.call(rbind, c(dots, list(deparse.level=deparse.level))), 
+    c("rbind", "rbind"),
+    callStack = sys.calls()
+  )
+  
+  # restore integer64 class
+  if (value_class == "integer64") {
+    if (is.list(ret)) {
+      if (is.data.frame(ret)) {
+        for (ii in seq_along(ret))
+          oldClass(ret[[ii]]) = value_class
+      } else {
+        # for rbind, we have to estimate row indices for each item to convert because of possible recycling
+        # this is mainly for POSIXlt
+        estimatedRowIndices = lapply(dots, function(el) {
+          res = nrow(el)
+          if (is.null(res)) 
+            res = as.integer(length(el) > 0L)
+          res
+        })
+        lastValue = 0L
+        for (ii in seq_along(estimatedRowIndices)) {
+          estimatedRowIndices[[ii]] = lastValue + seq_len(estimatedRowIndices[[ii]])
+          lastValue = lastValue + length(estimatedRowIndices[[ii]])
         }
-        oldClass(l[[k]]) <- NULL
+        col_offset = (seq_len(ncol(ret)) - 1L)*nrow(ret)
+        for (idx in positionsOfItemsToConvert) {
+          for (ii in estimatedRowIndices[[idx]]) {
+            for (jj in col_offset)
+              oldClass(ret[[ii + jj]]) = value_class
+          }
+        }
+      }
+    } else {
+      oldClass(ret) = value_class
+    }
   }
-  ret = do.call(rbind, l)
-  oldClass(ret) = "integer64"
   ret
 }
 

R/zzz.R

@@ -48,8 +48,8 @@ if (getRversion() < "3.6.0") {
 # * call stack: [A, B, C, D, E]; function_names = c("C", "D") returns C
 # * call stack: [A, B, C, D, E]; function_names = c("E", "D") returns D
 # * call stack: [A, B, C, D, E]; function_names = c("E", "X") returns A
-choose_sys_call = function(function_names, name_to_display=NULL) {
-  calls = sys.calls()
+choose_sys_call = function(function_names, name_to_display=NULL, callStack=NULL) {
+  calls = if (is.null(callStack)) sys.calls() else callStack
   if (length(calls) == 1L || length(function_names) == 0L) return(calls[[1L]])
   # find last occurrence of last name in function_names
   function_names_rev = rev(as.character(function_names))
@@ -70,14 +70,14 @@ choose_sys_call = function(function_names, name_to_display=NULL) {
   ret
 }
 
-withCallingHandlers_and_choose_call = function(expr, function_names, name_to_display=NULL) {
+withCallingHandlers_and_choose_call = function(expr, function_names, name_to_display=NULL, callStack=NULL) {
   wch = substitute(
     withCallingHandlers(expr, error=error, warning=warning),
     list(
       expr = sys.call()[[2L]],
-      error = function(e) stop(errorCondition(e$message, call=choose_sys_call(function_names, name_to_display))),
+      error = function(e) stop(errorCondition(e$message, call=choose_sys_call(function_names, name_to_display, callStack=callStack))),
       warning = function(w) {
-        warning(warningCondition(w$message, call=choose_sys_call(function_names, name_to_display)))
+        warning(warningCondition(w$message, call=choose_sys_call(function_names, name_to_display, callStack=callStack)))
         invokeRestart("muffleWarning")
       }
     )
@@ -86,10 +86,20 @@ withCallingHandlers_and_choose_call = function(expr, function_names, name_to_dis
 }
 
 # function to determine target class and sample value for union, intersect, setdiff, setequal, min, max, range, sum, prod, c, cbind and rbind functions
-target_class = function(x) {
+getClassesOfElements = function(x, recursive) {
+  classes = vapply(x, function(el) if (inherits(el, c("list", "data.frame"))) "list" else class(el)[1L], character(1L))
+  if (recursive) {
+    union(classes[classes != "list"], unlist(lapply(x[classes == "list"], function(el) getClassesOfElements(el, recursive=TRUE))))
+  } else {
+    unique(classes)
+  }
+}
+
+target_class = function(x, recursive=FALSE, POSIXltAsCharacter=FALSE) {
 
-  classes = unique(vapply(x, function(el) if (inherits(el, c("list", "data.frame"))) "list" else class(el)[1L], character(1L)))
+  classes = getClassesOfElements(x, recursive=isTRUE(recursive))
 
+  if ("POSIXlt" %in% classes && isTRUE(POSIXltAsCharacter)) return("character")
   if ("complex" %in% classes) return("complex")
   if (any(c("character", "factor", "ordered") %in% classes)) {
     # TODO(#44): next Release: change default behavior; subsequent Release: change from message to warning; subsequent Release: change from warning to error; subsequent Release: remove option