diff --git a/.devcontainer/r-350/.Rprofile b/.devcontainer/r-350/.Rprofile index 6ff1d29c..4a11458b 100644 --- a/.devcontainer/r-350/.Rprofile +++ b/.devcontainer/r-350/.Rprofile @@ -76,7 +76,7 @@ expect_warning <- function(object, regexp = NULL, ...) { } if (is.null(regexp)) return(invisible()) - if (!any(grepl(regexp, warnings))) { + if (!any(grepl(regexp, warnings, ...))) { stop(sprintf("FAILURE: expect_warning() regex mismatch.\n Expected: %s\n Actual: %s", regexp, toString(warnings))) } } diff --git a/NAMESPACE b/NAMESPACE index bb59f8de..98b23f20 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,7 +29,8 @@ S3method(abs,integer64) S3method(all,integer64) S3method(all.equal,integer64) S3method(any,integer64) -S3method(aperm,integer64) +S3method(array,default) +S3method(array,integer64) S3method(as.bitstring,integer64) S3method(as.character,integer64) S3method(as.data.frame,integer64) @@ -51,11 +52,14 @@ S3method(as.integer64,logical) S3method(as.integer64,raw) S3method(as.list,integer64) S3method(as.logical,integer64) +S3method(base::`%*%`,integer64) S3method(base::anyNA,integer64) +S3method(base::aperm,integer64) S3method(base::as.Date,integer64) S3method(base::as.POSIXct,integer64) S3method(base::as.POSIXlt,integer64) S3method(base::as.complex,integer64) +S3method(base::as.matrix,integer64) S3method(base::as.numeric,integer64) S3method(base::as.raw,integer64) S3method(c,integer64) @@ -99,6 +103,8 @@ S3method(log10,integer64) S3method(log2,integer64) S3method(match,default) S3method(match,integer64) +S3method(matrix,default) +S3method(matrix,integer64) S3method(max,integer64) S3method(mean,integer64) S3method(median,integer64) @@ -193,6 +199,7 @@ export(abs.integer64) export(all.equal.integer64) export(all.integer64) export(any.integer64) +export(array) export(as.bitstring) export(as.bitstring.integer64) export(as.character.integer64) @@ -267,6 +274,7 @@ export(log.integer64) export(match) export(match.default) export(match.integer64) +export(matrix) export(max.integer64) export(mean.integer64) export(median.integer64) @@ -415,6 +423,7 @@ importFrom(methods,is) importFrom(stats,cor) importFrom(stats,median) importFrom(stats,quantile) +importFrom(utils,getS3method) importFrom(utils,head) importFrom(utils,packageDescription) importFrom(utils,strOptions) diff --git a/NEWS.md b/NEWS.md index 9d3c12bb..8172edab 100644 --- a/NEWS.md +++ b/NEWS.md @@ -55,6 +55,7 @@ - `as.integer64` gets `Date`, `POSIXct`, `POSXlt`, `complex`, `raw`, and `difftime` methods. 1. `as.integer64.character` now supports hexadecimal (base 16) input when prefixed with "0x" or "-0x", e.g. `as.integer64("0x7FFFFFFFFFFFFFFF")`. Thanks @hcirellu for a PR which completes work begun by @marcpaterno. 1. `sortcache`, `sortordercache` and `ordercache` get a new argument `na.last`. +1. `matrix`, `array`, `%*%` and `as.matrix` get an `integer64` method (#45). Thanks @hcirellu. ## BUG FIXES diff --git a/R/bit64-package.R b/R/bit64-package.R index 4282443e..a0d8ac11 100644 --- a/R/bit64-package.R +++ b/R/bit64-package.R @@ -116,6 +116,10 @@ #' | double | / | integer64 | -> | integer64 | / | long double | -> | double | #' | integer64 | ^ | double | -> | integer64 | / | long double | -> | double | #' | double | ^ | integer64 | -> | integer64 | / | long double | -> | double | +#' | integer64 | %*% | double | -> | integer64 | %*% | integer64 | -> | integer64 | +#' | double | %*% | integer64 | -> | integer64 | %*% | integer64 | -> | integer64 | +#' | integer64 | %*% | complex | -> | double | %*% | complex | -> | complex | +#' | complex | %*% | integer64 | -> | complex | %*% | double | -> | complex | #' #' # Creating and testing S3 class 'integer64' #' @@ -697,7 +701,7 @@ #' @importFrom graphics barplot par title #' @importFrom methods as is #' @importFrom stats cor median quantile -#' @importFrom utils head packageDescription strOptions tail +#' @importFrom utils head packageDescription strOptions tail getS3method #' @export : :.default :.integer64 #' @export [.integer64 [[.integer64 [[<-.integer64 [<-.integer64 #' @export %in% %in%.default diff --git a/R/integer64.R b/R/integer64.R index 4cb9521b..e3c1639e 100644 --- a/R/integer64.R +++ b/R/integer64.R @@ -114,8 +114,7 @@ NULL #' @seealso [`[`][base::Extract] [integer64()] #' @examples #' as.integer64(1:12)[1:3] -#' x <- as.integer64(1:12) -#' dim(x) <- c(3, 4) +#' x <- matrix(as.integer64(1:12), nrow = 3L) #' x #' x[] #' x[, 2:3] @@ -881,7 +880,7 @@ str.integer64 = function(object, vec.len=strO$vec.len, give.head=TRUE, give.leng vec.len = 2L*vec.len n = length(object) displayObject = object[seq_len(min(vec.len, length(object)))] - + cat( if (isTRUE(give.head)) { if (length(object) == 0L && is.null(dim(object))) { @@ -891,14 +890,13 @@ str.integer64 = function(object, vec.len=strO$vec.len, give.head=TRUE, give.leng "integer64 ", if (length(object) > 1L && is.null(dim(object))) { if (isTRUE(give.length)) paste0("[1:", n, "] ") else " " - } else if (!is.null(dim(object))) { - dimO = dim(object) - if (prod(dimO) != n) - stop(gettextf("dims [product %d] do not match the length of object [%d]", prod(dimO), n, domain="R")) - if (length(dimO) == 1L) { + } else if (!is.null(obj_dim <- dim(object))) { + if (prod(obj_dim) != n) + stop(gettextf("dims [product %d] do not match the length of object [%d]", prod(obj_dim), n, domain="R"), domain=NA) + if (length(obj_dim) == 1L) { paste0("[", n, "(1d)] ") } else { - paste0("[", paste(vapply(dimO, function(el) {if (el < 2L) as.character(el) else paste0("1:", el)}, ""), collapse = ", "), "] ") + paste0("[", toString(vapply(obj_dim, function(el) if (el < 2L) as.character(el) else paste0("1:", el), "")), "] ") } } ) @@ -1189,6 +1187,32 @@ seq.integer64 = function(from=NULL, to=NULL, by=NULL, length.out=NULL, along.wit ret } + +# helper for determining the target class for Ops methods +target_class_for_Ops = function(e1, e2) { + if(missing(e2)) { + if (!is.numeric(unclass(e1)) && !is.logical(e1) && !is.complex(e1)) + stop(errorCondition(gettext("non-numeric argument to mathematical function", domain = "R"), call=sys.call(sys.nframe() - 1L))) + + if (is.complex(e1)) { + "complex" + } else { + "integer64" + } + } else { + if (!is.numeric(unclass(e1)) && !is.logical(e1) && !is.complex(e1)) + stop(errorCondition(gettext("non-numeric argument to binary operator", domain = "R"), call=sys.call(sys.nframe() - 1L))) + if (!is.numeric(unclass(e2)) && !is.logical(e2) && !is.complex(e2)) + stop(errorCondition(gettext("non-numeric argument to binary operator", domain = "R"), call=sys.call(sys.nframe() - 1L))) + + if (is.complex(e1) || is.complex(e2)) { + "complex" + } else { + "integer64" + } + } +} + #' @rdname xor.integer64 #' @export `+.integer64` <- function(e1, e2) { diff --git a/R/matrix64.R b/R/matrix64.R index 215b7157..d3f43376 100644 --- a/R/matrix64.R +++ b/R/matrix64.R @@ -19,9 +19,9 @@ #' @param x An array of integer64 numbers. #' @param na.rm,dims Same interpretation as in [colSums()]. #' @param ... Passed on to subsequent methods. +#' @param data,nrow,ncol,byrow,dimnames,dim Arguments for `matrix()` and `array()`. #' @examples -#' A = as.integer64(1:6) -#' dim(A) = 3:2 +#' A = matrix(as.integer64(1:6), 3) #' #' colSums(A) #' rowSums(A) @@ -29,54 +29,126 @@ #' @name matrix64 NULL -#' @rdname matrix64 -#' @export -colSums = function(x, na.rm=FALSE, dims=1L) UseMethod("colSums") -#' @rdname matrix64 -#' @export -colSums.default = function(x, na.rm=FALSE, dims=1L) base::colSums(x, na.rm, dims) #' @rdname matrix64 -#' @export -colSums.integer64 = function(x, na.rm=FALSE, dims=1L) { - n_dim = length(dim(x)) - stopifnot( - `dims= should be a length-1 integer between 1 and length(dim(x))-1L` = - length(dims) == 1L && dims > 0L && dims < n_dim - ) - MARGIN = tail(seq_len(n_dim), -dims) - ret = apply(x, MARGIN, sum, na.rm = na.rm) - class(ret) = "integer64" +#' @exportS3Method matrix integer64 +matrix.integer64 = function(data=NA_integer64_, ...) { + if (!length(data)) data = NA_integer64_ + ret = withCallingHandlers_and_choose_call( + base::matrix(data=data, ...), + c("matrix", "matrix.integer64") + ) + class(ret) = class(data) ret } #' @rdname matrix64 -#' @export -rowSums = function(x, na.rm=FALSE, dims=1L) UseMethod("rowSums") +#' @exportS3Method array integer64 +array.integer64 = function(data=NA_integer64_, ...) { + if (!length(data)) data = NA_integer64_ + ret = withCallingHandlers_and_choose_call( + base::array(data=data, ...), + c("array", "array.integer64") + ) + class(ret) = class(data) + ret +} + #' @rdname matrix64 #' @export -rowSums.default = function(x, na.rm=FALSE, dims=1L) base::rowSums(x, na.rm, dims) +colSums.integer64 = function(x, na.rm=FALSE, dims=1L) { + dn = dim(x) + if (!is.array(x) || length(dn) < 2L) + stop(errorCondition(gettext("'x' must be an array of at least two dimensions", domain="R-base"), call=choose_sys_call(c("colSums", "colSums.integer64")))) + if (length(dims) != 1L || dims < 1L || dims > length(dn) - 1L) + stop(errorCondition(gettext("invalid 'dims'", domain="R-base"), call=choose_sys_call(c("colSums", "colSums.integer64")))) + + ret = apply(x, seq_along(dn)[-seq_len(dims)], sum, na.rm=na.rm) + class(ret) = class(x) + ret +} #' @rdname matrix64 #' @export rowSums.integer64 = function(x, na.rm=FALSE, dims=1L) { - n_dim = length(dim(x)) - stopifnot( - `dims= should be a length-1 integer between 1 and length(dim(x))-1L` = - length(dims) == 1L && dims > 0L && dims < n_dim - ) - MARGIN = seq_len(dims) - ret = apply(x, MARGIN, sum, na.rm = na.rm) - class(ret) = "integer64" + dn = dim(x) + if (!is.array(x) || length(dn) < 2L) + stop(errorCondition(gettext("'x' must be an array of at least two dimensions", domain="R-base"), call=choose_sys_call(c("rowSums", "rowSums.integer64")))) + if (length(dims) != 1L || dims < 1L || dims > length(dn) - 1L) + stop(errorCondition(gettext("invalid 'dims'", domain="R-base"), call=choose_sys_call(c("rowSums", "rowSums.integer64")))) + + ret = apply(x, seq_len(dims), sum, na.rm=na.rm) + class(ret) = class(x) ret } #' @rdname matrix64 #' @param a,perm Passed on to [aperm()]. -#' @export +#' @exportS3Method base::aperm integer64 aperm.integer64 = function(a, perm, ...) { - class(a) = minusclass(class(a), "integer64") - ret = aperm(a, perm, ...) - class(ret) = plusclass(class(a), "integer64") + ret = NextMethod() + class(ret) = class(a) ret } + +#' @exportS3Method base::`%*%` integer64 +`%*%.integer64` = function(x, y) { + if (!is.integer64(x) && !is.integer64(y)) + return(x%*%y) + + target_class = target_class_for_Ops(x, y) + if (target_class != "integer64") { + if (is.integer64(x)) { + for (cc in class(y)) { + f = getS3method("%*%", cc, optional=TRUE) + if (!is.null(f)) + return(f(.as_double_integer64(x, keep.attributes=TRUE), y)) + } + x = .as_double_integer64(x, keep.attributes=TRUE) + } else { + y = .as_double_integer64(y, keep.attributes=TRUE) + } + return(x%*%y) + } + + dx = dim(x) + dy = dim(y) + if (length(dx) > 2L || length(dy) > 2L) + stop("non-conformable arguments", domain="R") + if (length(dx) <= 1L && length(dy) <= 1L) { + dx = c(1L, length(x)) + if (length(x) == length(y)) { + dy = c(length(y), 1L) + } else { + dy = c(1L, length(y)) + } + } + if (length(dx) <= 1L) + dx = c(1L, dy[1L]) + if (length(dy) <= 1L) + dy = c(dx[2L], 1L) + if (dx[2L] != dy[1L]) + stop("non-conformable arguments", domain="R") + dim(x) = dx + dim(y) = dy + + if (is.double(x)) { + ret = .Call(C_matmult_double_integer64, x, structure(as.integer64(y), dim=dy), double(dx[1L]*dy[2L])) + } else if (is.double(y)) { + ret = .Call(C_matmult_integer64_double, structure(as.integer64(x), dim=dx), y, double(dx[1L]*dy[2L])) + } else { + ret = .Call(C_matmult_integer64_integer64, structure(as.integer64(x), dim=dx), structure(as.integer64(y), dim=dy), double(dx[1L]*dy[2L])) + } + dim(ret) = c(dx[1L], dy[2L]) + oldClass(ret) = "integer64" + ret +} + +#' @exportS3Method base::as.matrix integer64 +as.matrix.integer64 = function(x, ...) { + if (is.matrix(x)) { + x + } else { + array(x, c(length(x), 1L), if (!is.null(names(x))) list(names(x), NULL)) + } +} diff --git a/R/patch64.R b/R/patch64.R index 29bfd058..b350b498 100644 --- a/R/patch64.R +++ b/R/patch64.R @@ -130,3 +130,48 @@ order <- function(...) UseMethod("order") #' @rdname bit64S3 #' @export order.default <- function(...) base::order(...) + +#' @rdname matrix64 +#' @export matrix +matrix = function(data=NA, nrow=1L, ncol=1L, byrow=FALSE, dimnames=NULL) UseMethod("matrix") +#' @exportS3Method matrix default +matrix.default = function(...) { + withCallingHandlers_and_choose_call( + base::matrix(...), + c("matrix", "matrix.default") + ) +} + +#' @rdname matrix64 +#' @export array +array = function(data=NA, dim=length(data), dimnames=NULL) UseMethod("array") +#' @exportS3Method array default +array.default = function(...) { + withCallingHandlers_and_choose_call( + base::array(...), + c("array", "array.default") + ) +} + +#' @rdname matrix64 +#' @export +colSums = function(x, na.rm=FALSE, dims=1L) UseMethod("colSums") +#' @rdname matrix64 +#' @export +colSums.default = function(x, na.rm=FALSE, dims=1L) + withCallingHandlers_and_choose_call( + base::colSums(x=x, na.rm=na.rm, dims=dims), + c("colSums", "colSums.default") + ) + +#' @rdname matrix64 +#' @export +rowSums = function(x, na.rm=FALSE, dims=1L) UseMethod("rowSums") +#' @rdname matrix64 +#' @export +rowSums.default = function(x, na.rm=FALSE, dims=1L) + withCallingHandlers_and_choose_call( + base::rowSums(x=x, na.rm=na.rm, dims=dims), + c("rowSums", "rowSums.default") + ) + diff --git a/R/zzz.R b/R/zzz.R index c347b65f..85b4d6b4 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -7,6 +7,23 @@ # Created: 2011-12-11 # */ + +# backports +# R < 3.6.0 +if (getRversion() < "3.6.0") { + errorCondition = function(message, ..., class = NULL, call = NULL) { + obj <- list(message = as.character(message), call = call, ...) + class(obj) = c(class, "error", "condition") + obj + } + + warningCondition = function(message, ..., class = NULL, call = NULL) { + obj <- list(message = as.character(message), call = call, ...) + class(obj) = c(class, "warning", "condition") + obj + } +} + # nocov start .onUnload = function(libpath) { library.dynam.unload("bit64", libpath) @@ -216,3 +233,50 @@ deprecate_exported_s3_methods( unipos.integer64 ) # nocov end + + +# The call stack is searched for a given sequence of function names. If the last element of function_names is found, +# we try to match as many elements in function_names with the function names in the call stack. The sequence must be +# adhered to. The complete call of the function name of the last match is returned. If no match exists, the top call +# is returned. It is also possible to change the function name of the matched return value by providing its new name +# with name_to_display. +# Examples: +# * 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() + 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)) + for (sel in rev(seq_along(calls))) { + el = calls[[sel]] + if (!is.function(el[[1L]]) && rev(as.character(el[[1L]]))[1L] == function_names_rev[1L]) break + } + # now check further backwards to match as far as possible + for (fn in function_names_rev[-1L]) { + if (sel == 1L) break + el = calls[[sel - 1L]] + if (is.function(el[[1L]]) || rev(as.character(el[[1L]]))[[1L]] != fn) break + sel = sel - 1L + } + ret = calls[[sel]] + if (!is.null(name_to_display)) + ret[[1L]] = as.name(name_to_display) + ret +} + +withCallingHandlers_and_choose_call = function(expr, function_names, name_to_display=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))), + warning = function(w) { + warning(warningCondition(w$message, call=choose_sys_call(function_names, name_to_display))) + invokeRestart("muffleWarning") + } + ) + ) + eval(wch, envir=parent.frame()) +} diff --git a/man/bit64-package.Rd b/man/bit64-package.Rd index a1fb6a4d..b0d122a3 100644 --- a/man/bit64-package.Rd +++ b/man/bit64-package.Rd @@ -189,6 +189,10 @@ argument to 'long double', they return as \code{double}, like double \tab / \tab integer64 \tab -> \tab integer64 \tab / \tab long double \tab -> \tab double \cr integer64 \tab ^ \tab double \tab -> \tab integer64 \tab / \tab long double \tab -> \tab double \cr double \tab ^ \tab integer64 \tab -> \tab integer64 \tab / \tab long double \tab -> \tab double \cr + integer64 \tab \%*\% \tab double \tab -> \tab integer64 \tab \%*\% \tab integer64 \tab -> \tab integer64 \cr + double \tab \%*\% \tab integer64 \tab -> \tab integer64 \tab \%*\% \tab integer64 \tab -> \tab integer64 \cr + integer64 \tab \%*\% \tab complex \tab -> \tab double \tab \%*\% \tab complex \tab -> \tab complex \cr + complex \tab \%*\% \tab integer64 \tab -> \tab complex \tab \%*\% \tab double \tab -> \tab complex \cr } } diff --git a/man/extract.replace.integer64.Rd b/man/extract.replace.integer64.Rd index bf2e61d1..eeb420a1 100644 --- a/man/extract.replace.integer64.Rd +++ b/man/extract.replace.integer64.Rd @@ -37,8 +37,7 @@ The current implementation returns \code{9218868437227407266} instead of \code{N } \examples{ as.integer64(1:12)[1:3] - x <- as.integer64(1:12) - dim(x) <- c(3, 4) + x <- matrix(as.integer64(1:12), nrow = 3L) x x[] x[, 2:3] diff --git a/man/matrix64.Rd b/man/matrix64.Rd index 85fd9958..74bd5abb 100644 --- a/man/matrix64.Rd +++ b/man/matrix64.Rd @@ -1,38 +1,52 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/matrix64.R +% Please edit documentation in R/matrix64.R, R/patch64.R \name{matrix64} \alias{matrix64} +\alias{matrix.integer64} +\alias{array.integer64} +\alias{colSums.integer64} +\alias{rowSums.integer64} +\alias{aperm.integer64} +\alias{matrix} +\alias{array} \alias{colSums} \alias{colSums.default} -\alias{colSums.integer64} \alias{rowSums} \alias{rowSums.default} -\alias{rowSums.integer64} -\alias{aperm.integer64} \title{Working with integer64 arrays and matrices} \usage{ -colSums(x, na.rm = FALSE, dims = 1L) +\method{matrix}{integer64}(data = NA_integer64_, ...) -\method{colSums}{default}(x, na.rm = FALSE, dims = 1L) +\method{array}{integer64}(data = NA_integer64_, ...) \method{colSums}{integer64}(x, na.rm = FALSE, dims = 1L) -rowSums(x, na.rm = FALSE, dims = 1L) - -\method{rowSums}{default}(x, na.rm = FALSE, dims = 1L) - \method{rowSums}{integer64}(x, na.rm = FALSE, dims = 1L) \method{aperm}{integer64}(a, perm, ...) + +matrix(data = NA, nrow = 1L, ncol = 1L, byrow = FALSE, dimnames = NULL) + +array(data = NA, dim = length(data), dimnames = NULL) + +colSums(x, na.rm = FALSE, dims = 1L) + +\method{colSums}{default}(x, na.rm = FALSE, dims = 1L) + +rowSums(x, na.rm = FALSE, dims = 1L) + +\method{rowSums}{default}(x, na.rm = FALSE, dims = 1L) } \arguments{ +\item{data, nrow, ncol, byrow, dimnames, dim}{Arguments for \code{matrix()} and \code{array()}.} + +\item{...}{Passed on to subsequent methods.} + \item{x}{An array of integer64 numbers.} \item{na.rm, dims}{Same interpretation as in \code{\link[=colSums]{colSums()}}.} \item{a, perm}{Passed on to \code{\link[=aperm]{aperm()}}.} - -\item{...}{Passed on to subsequent methods.} } \description{ These functions and methods facilitate working with integer64 @@ -53,8 +67,7 @@ that of \code{colSums()} for integers; feature requests and PRs welcome. \code{FUN} gets applied to a class-stripped version of the input. } \examples{ -A = as.integer64(1:6) -dim(A) = 3:2 +A = matrix(as.integer64(1:6), 3) colSums(A) rowSums(A) diff --git a/src/init.c b/src/init.c index dd67350e..3ec0d228 100644 --- a/src/init.c +++ b/src/init.c @@ -51,6 +51,9 @@ extern SEXP logbase_integer64(SEXP, SEXP, SEXP); extern SEXP log_integer64(SEXP, SEXP); extern SEXP logvect_integer64(SEXP, SEXP, SEXP); extern SEXP LT_integer64(SEXP, SEXP, SEXP); +extern SEXP matmult_double_integer64(SEXP, SEXP, SEXP); +extern SEXP matmult_integer64_double(SEXP, SEXP, SEXP); +extern SEXP matmult_integer64_integer64(SEXP, SEXP, SEXP); extern SEXP max_integer64(SEXP, SEXP, SEXP); extern SEXP mean_integer64(SEXP, SEXP, SEXP); extern SEXP min_integer64(SEXP, SEXP, SEXP); @@ -166,6 +169,9 @@ static const R_CallMethodDef CallEntries[] = { {"log_integer64", (DL_FUNC) &log_integer64, 2}, {"logvect_integer64", (DL_FUNC) &logvect_integer64, 3}, {"LT_integer64", (DL_FUNC) <_integer64, 3}, + {"matmult_double_integer64", (DL_FUNC) &matmult_double_integer64, 3}, + {"matmult_integer64_double", (DL_FUNC) &matmult_integer64_double, 3}, + {"matmult_integer64_integer64", (DL_FUNC) &matmult_integer64_integer64, 3}, {"max_integer64", (DL_FUNC) &max_integer64, 3}, {"mean_integer64", (DL_FUNC) &mean_integer64, 3}, {"min_integer64", (DL_FUNC) &min_integer64, 3}, diff --git a/src/integer64.c b/src/integer64.c index 836ef02c..da0d3191 100644 --- a/src/integer64.c +++ b/src/integer64.c @@ -1025,6 +1025,18 @@ SEXP runif_integer64(SEXP n_, SEXP min_, SEXP max_){ UNPROTECT(1); return ret_; } +/* +require(bit64) +require(microbenchmark) +microbenchmark(runif64(1e6)) + +sort(runif64(1e2)) + + +Unit: milliseconds + expr min lq mean median uq max neval + runif64(1e+06) 24.62306 25.60286 25.61903 25.61369 25.62032 26.40202 100 +*/ SEXP as_list_integer64(SEXP x_){ long long i, n = LENGTH(x_); @@ -1040,15 +1052,131 @@ SEXP as_list_integer64(SEXP x_){ return x_; } -/* -require(bit64) -require(microbenchmark) -microbenchmark(runif64(1e6)) +__attribute__((no_sanitize("signed-integer-overflow"))) SEXP matmult_integer64_integer64(SEXP x_, SEXP y_, SEXP ret_){ + long long i, j, k; + // get dimension of x + SEXP dim1 = getAttrib(x_, R_DimSymbol); + long long nrow1 = INTEGER(dim1)[0]; + long long ncol1 = INTEGER(dim1)[1]; + // get dimension of y + SEXP dim2 = getAttrib(y_, R_DimSymbol); + long long nrow2 = INTEGER(dim2)[0]; + long long ncol2 = INTEGER(dim2)[1]; -sort(runif64(1e2)) + long long * x = (long long *) REAL(x_); + long long * y = (long long *) REAL(y_); + long long * ret = (long long *) REAL(ret_); + Rboolean naflag = FALSE; + long long cumsum, tempsum, addValue; + + for(i=0; i 0) ? (((long double) addValue) < ((long double) tempsum)) : ! (((long double) addValue) < ((long double) tempsum)))){ + naflag = TRUE; + cumsum = NA_INTEGER64; + break; + } + cumsum = tempsum; + } + ret[i + j*nrow1] = cumsum; + } + } + if (naflag)warning(INTEGER64_OVERFLOW_WARNING); + return ret_; +} -Unit: milliseconds - expr min lq mean median uq max neval - runif64(1e+06) 24.62306 25.60286 25.61903 25.61369 25.62032 26.40202 100 -*/ +SEXP matmult_double_integer64(SEXP x_, SEXP y_, SEXP ret_){ + long long i, j, k; + // get dimension of x + SEXP dim1 = getAttrib(x_, R_DimSymbol); + long long nrow1 = INTEGER(dim1)[0]; + long long ncol1 = INTEGER(dim1)[1]; + // get dimension of y + SEXP dim2 = getAttrib(y_, R_DimSymbol); + long long nrow2 = INTEGER(dim2)[0]; + long long ncol2 = INTEGER(dim2)[1]; + + double * x = REAL(x_); + long long * y = (long long *) REAL(y_); + long long * ret = (long long *) REAL(ret_); + Rboolean naflag = FALSE; + long long cumsum, tempsum, addValue; + long double longret; + + for(i=0; i=4.0.0): use rep_len(x, 1*2*3) over the ugly versions with seq_len() + expect_identical(array(x, c(1,2,3))[seq_len(1*2*3)], x[seq_len(1*2*3)]) + expect_identical(dim(array(x, c(1,2,3))), c(1L,2L,3L)) + expect_identical(array(x, c(3,2,3))[seq_len(3*2*3)], x[(seq_len(3*2*3)-1L) %% length(x) + 1L]) + + if (type == "integer64") { + missing = NA_integer64_ + empty = integer64() + } else { + missing = NA_integer_ + empty = integer() + } + + expect_identical(array(missing, c(2,1))[1:2], c(missing, missing)) + expect_identical(array(empty, c(2,1))[1:2], c(missing, missing)) + + expect_identical( + dimnames(array(x, c(2,5), dimnames=list(NULL, letters[1:5]))), + list(NULL, letters[1:5]) + ) + expect_identical( + dimnames(array(x, c(2,5), dimnames=list(LETTERS[1:2]))), + list(LETTERS[1:2], NULL) + ) + expect_identical( + dimnames(array(x, c(2,5), dimnames=list(LETTERS[1:2], letters[1:5]))), + list(LETTERS[1:2], letters[1:5]) + ) + + expect_error( + array(x, dim=NULL), + "'dims?' cannot be of length 0" + ) + expect_error( + array(x, dim=-1), + "negative length vectors are not allowed" + ) + + expect_identical(array(x, dim=0), structure(empty, dim = 0L)) + }, + .cases=data.frame(x=I(list(1:10, as.integer64(1:10))), type=c("integer", "integer64")) +) + test_that("colSums and rowSums work on simple integer64 input", { A = array(seq_len(120L), dim = 2:5) A64 = array64(A, dim=dim(A)) @@ -17,12 +147,12 @@ test_that("colSums and rowSums work on simple integer64 input", { skip_unless_r(">= 4.0.0") # named args in stopifnot() unsupported -> different error expect_error( rowSums(A64, dims=4L), - "dims= should be a length-1 integer", + "invalid 'dims'", fixed = TRUE ) expect_error( colSums(A64, dims=4L), - "dims= should be a length-1 integer", + "invalid 'dims'", fixed = TRUE ) }) @@ -62,6 +192,26 @@ test_that("out-of-integer-range inputs are handled correctly", { expect_identical(colSums(A64), as.integer64(2L^30L*c(1L+2L+4L, 8L+16L+32L))) }) +test_that("dimnames with colSums and rowSums", { + M32 = matrix(1:(3*2), nrow=3L, ncol=2L, dimnames=list(LETTERS[1:3], letters[1:2])) + A32 = array(1:(2*5*3), dim=c(2, 5, 3), dimnames=list(LETTERS[1:2], letters[1:5], rev(LETTERS)[1:3])) + M64 = matrix(as.integer64(1:(3*2)), nrow=3L, ncol=2L, dimnames=list(LETTERS[1:3], letters[1:2])) + A64 = array(as.integer64(1:(2*5*3)), dim=c(2, 5, 3), dimnames=list(LETTERS[1:2], letters[1:5], rev(LETTERS)[1:3])) + + expect_identical(names(colSums(M32)), names(colSums(M64))) + expect_identical(dimnames(colSums(M32)), dimnames(colSums(M64))) + expect_identical(names(colSums(A32)), names(colSums(A64))) + expect_identical(dimnames(colSums(A32)), dimnames(colSums(A64))) + expect_identical(names(colSums(A32, dims=2L)), names(colSums(A64, dims=2L))) + expect_identical(dimnames(colSums(A32, dims=2L)), dimnames(colSums(A64, dims=2L))) + expect_identical(names(rowSums(M32)), names(rowSums(M64))) + expect_identical(dimnames(rowSums(M32)), dimnames(rowSums(M64))) + expect_identical(names(rowSums(A32)), names(rowSums(A64))) + expect_identical(dimnames(rowSums(A32)), dimnames(rowSums(A64))) + expect_identical(names(rowSums(A32, dims=2L)), names(rowSums(A64, dims=2L))) + expect_identical(dimnames(rowSums(A32, dims=2L)), dimnames(rowSums(A64, dims=2L))) +}) + test_that("aperm works in simple cases", { # example from ?aperm A = array64(1:24, 2:4) @@ -71,3 +221,54 @@ test_that("aperm works in simple cases", { expect_identical(t(B[, , 3L]), A[, , 3L], ignore_attr="class") expect_identical(t(B[, , 4L]), A[, , 4L], ignore_attr="class") }) + +test_that("matrix multiplication", { + skip_unless_r(">= 4.0.0") # it does not work with ubuntu-latest (3.6), because a double vector is returned + m32 = matrix(1:10, 2) + m64 = matrix(as.integer64(m32), nrow(m32)) + mDo = matrix(as.numeric(m32), nrow(m32)) + mCo = matrix(as.complex(m32), nrow(m32)) + expect_error(m32%*%m32, "non-conformable arguments") + expect_error(m64%*%m64, "non-conformable arguments") + expect_identical(m64%*%t(m64), matrix(as.integer64(m32%*%t(m32)), nrow=nrow(m32))) + expect_identical(t(m64)%*%m64, matrix(as.integer64(t(m32)%*%m32), ncol=ncol(m32))) + expect_identical((1:2)%*%m64, matrix(as.integer64((1:2)%*%m32), ncol=ncol(m32))) + expect_identical(m64%*%(1:5), matrix(as.integer64(m32%*%(1:5)), nrow=nrow(m32))) + expect_error((1:2)%*%3L, "non-conformable arguments") + expect_error(as.integer64(1:2)%*%as.integer64(3L), "non-conformable arguments") + expect_identical(as.integer64(1L)%*%(3:4), matrix(as.integer64(3:4), nrow=1L)) + expect_identical(as.integer64(1:2)%*%(3:4), matrix(as.integer64(11L), nrow=1L)) + + expect_identical(m64%*%t(m32), matrix(as.integer64(m32%*%t(m32)), nrow=nrow(m32))) + expect_identical(m32%*%t(m64), matrix(as.integer64(m32%*%t(m32)), nrow=nrow(m32))) + expect_identical(m64%*%t(mDo), matrix(as.integer64(m32%*%t(m32)), nrow=nrow(m32))) + expect_identical(mDo%*%t(m64), matrix(as.integer64(m32%*%t(m32)), nrow=nrow(m32))) + expect_identical(m64%*%t(mCo), matrix(as.complex(m32%*%t(m32)), nrow=nrow(m32))) + expect_identical(mCo%*%t(m64), matrix(as.complex(m32%*%t(m32)), nrow=nrow(m32))) + + expect_error(m64%*%LETTERS[1:5], "non-numeric argument to binary operator", fixed=TRUE) + expect_error(m64%*%as.raw(1:5), "non-numeric argument to binary operator", fixed=TRUE) + + # warning in multiplication part + x = as.integer64("4000000000") # x**2 > 2^63 + expect_warning(expect_identical(matrix(x, 1)%*%matrix(x, ncol=1), matrix(NA_integer64_, 1, 1)), "NAs produced by integer64 overflow") + + # warning in summation part + x = rep_len(as.integer64("3000000000"), 2) # x**2 < 2^63, but 2 * x**2 > 2^63 + expect_warning(expect_identical(matrix(x, 1)%*%matrix(x, ncol=1), matrix(NA_integer64_, 1, 1)), "NAs produced by integer64 overflow") + +}) + + +test_that("coercion to matrix and array", { + + i32 = 1:10 + i64 = as.integer64(i32) + m64 = matrix(as.integer64(i32), 2L) + + expect_identical(as.matrix(i64), structure(i64, dim = c(length(i64), 1L)), ignore_attr=if (getRversion() < "4.0.0") "class" else FALSE) + expect_identical(as.matrix(m64), m64) + + expect_identical(as.array(i64), structure(i64, dim = c(length(i64))), ignore_attr=if (getRversion() < "4.0.0") "class" else FALSE) + expect_identical(as.array(m64), m64) +})