# /*

# R-Code

# S3 atomic 64bit integers for R

# (c) 2011-2024 Jens Oehlschägel

# (c) 2025-2026 Michael Chirico

# Licence: GPL2

# Provided 'as is', use at your own risk

# Created: 2011-12-11

#*/

#' Identity function for class 'integer64'

#'

#' This will discover any deviation between objects containing integer64 vectors.

#'

#' This is simply a wrapper to [identical()] with default arguments

#' `num.eq = FALSE, single.NA = FALSE`.

#'

#' @param x,y Atomic vector of class 'integer64'

#' @param num.eq,single.NA,attrib.as.set,ignore.bytecode,ignore.environment,ignore.srcref

#' See [identical()].

#' @param ... Passed on to `identical()`. Only `extptr.as.ref=` is available as of R 4.4.1,

#' and then only for versions of R >= 4.2.0.

#'

#' @return A single logical value, `TRUE` or `FALSE`, never `NA` and never

#' anything other than a single value.

#' @keywords classes manip

#' @seealso [`==.integer64`] [identical()] [integer64()]

#' @examples

#' i64 <- as.double(NA); class(i64) <- "integer64"

#' identical(i64-1, i64+1)

#' identical.integer64(i64-1, i64+1)

#' @name identical.integer64

NULL

#' Coerce from integer64

#'

#' Methods to coerce integer64 to other atomic types. 'as.bitstring' coerces

#' to a human-readable bit representation (strings of zeroes and ones).

#' The methods [format()], [as.character()], [as.double()],

#' [as.logical()], [as.integer()] do what you would expect.

#'

#' @param x an integer64 vector

#' @param ...,origin,tz further arguments to the [NextMethod()]

#'

#' @return `as.bitstring` returns a string of class 'bitstring'.

#'

#' The other methods return atomic vectors of the expected types

#'

#' @keywords classes manip

#' @seealso [as.integer64.character()] [integer64()]

#' @examples

#' as.character(lim.integer64())

#' as.bitstring(lim.integer64())

#' as.bitstring(as.integer64(c(-2, -1, NA, 0:2)))

#' @name as.character.integer64

NULL

#' Coerce to integer64

#'

#' Methods to coerce from other atomic types to integer64.

#'

#' @param x an atomic vector

#' @param ...,units further arguments to the [NextMethod()]

#'

#' @details

#' `as.integer64.character` is realized using C function `strtoll` which

#' does not support scientific notation. Instead of '1e6' use '1000000'.

#' `as.integer64.bitstring` evaluates characters '0' and ' ' as zero-bit,

#' all other one byte characters as one-bit, multi-byte characters are not allowed,

#' strings shorter than 64 characters are treated as if they were left-padded with '0',

#' strings longer than 64 bytes are mapped to `NA_INTEGER64` and a warning is emitted.

#'

#' @return The other methods return atomic vectors of the expected types

#'

#' @keywords classes manip

#' @seealso [as.character.integer64()] [integer64()]

#' @examples

#' as.integer64(as.character(lim.integer64()))

#' as.integer64(

#' structure(c("1111111111111111111111111111111111111111111111111111111111111110",

#' "1111111111111111111111111111111111111111111111111111111111111111",

#' "1000000000000000000000000000000000000000000000000000000000000000",

#' "0000000000000000000000000000000000000000000000000000000000000000",

#' "0000000000000000000000000000000000000000000000000000000000000001",

#' "0000000000000000000000000000000000000000000000000000000000000010"

#' ), class = "bitstring")

#' )

#' as.integer64(

#' structure(c("............................................................... ",

#' "................................................................",

#' ". ",

#' "",

#' ".",

#' "10"

#' ), class = "bitstring")

#' )

#' @name as.integer64.character

NULL

#' Extract or Replace Parts of an integer64 vector

#'

#' Methods to extract and replace parts of an integer64 vector.

#'

#' @param x an atomic vector

#' @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, matrix, array or scalar of class 'integer64'

#' @keywords classes manip

#' @seealso [`[`][base::Extract] [integer64()]

#' @examples

#' as.integer64(1:12)[1:3]

#' x <- matrix(as.integer64(1:12), nrow = 3L)

#' x

#' x[]

#' x[, 2:3]

#' @name extract.replace.integer64

NULL

#' Unary operators and functions for integer64 vectors

#'

#' Unary operators and functions for integer64 vectors.

#'

#' @param x an atomic vector of class 'integer64'

#' @param base an atomic scalar (we save 50% log-calls by not allowing

#' a vector base)

#' @param digits integer indicating the number of decimal places (round)

#' or significant digits (signif) to be used. Negative values are allowed

#' (see [round()])

#' @param justify should it be right-justified (the default), left-justified,

#' centred or left alone.

#' @param center see [scale()]

#' @param scale see [scale()]

#' @param ... further arguments to the [NextMethod()]

#'

#' @returns

#' [format()] returns a character vector

#'

#' [is.na()] and [`!`] return a logical vector

#'

#' [sqrt()], [log()], [log2()] and [log10()] return a double vector

#'

#' [sign()], [abs()], [floor()], [ceiling()], [trunc()] and

#' [round()] return a vector of class 'integer64'

#'

#' [signif()] is not implemented

#'

#' @keywords classes manip

#' @seealso [ops64] [integer64()]

#' @examples

#' sqrt(as.integer64(1:12))

#' @name format.integer64

NULL

#' Summary functions for integer64 vectors

#'

#' Summary functions for integer64 vectors. Function 'range' without arguments

#' returns the smallest and largest value of the 'integer64' class.

#'

#' @param ... atomic vectors of class 'integer64'

#' @param na.rm logical scalar indicating whether to ignore NAs

#' @param finite logical scalar indicating whether to ignore NAs (just for

#' compatibility with [range.default()])

#'

#' @details

#' The numerical summary methods always return `integer64`. Wherever integer methods would

#' return `Inf` (or its negation), here the extreme 64-bit integer `9223372036854775807` is

#' returned. See [min()] for more details about the behavior.

#'

#' `lim.integer64` returns these limits in proper order

#' `-9223372036854775807, +9223372036854775807` and without a [warning()].

#'

#' @returns

#' [all()] and [any()] return a logical scalar

#'

#' [range()] returns a integer64 vector with two elements

#'

#' [min()], [max()], [sum()] and [prod()] return a integer64 scalar

#'

#' @keywords classes manip

#' @seealso [mean.integer64()] [cumsum.integer64()] [integer64()]

#' @examples

#' lim.integer64()

#' range(as.integer64(1:12))

#' @name sum.integer64

NULL

#' Cumulative Sums, Products, Extremes and lagged differences

#'

#' Cumulative Sums, Products, Extremes and lagged differences

#'

#' @param x an atomic vector of class 'integer64'

#' @param lag see [diff()]

#' @param differences see [diff()]

#' @param ... ignored

#'

#' @returns

#' [cummin()], [cummax()] , [cumsum()] and [cumprod()]

#' return a integer64 vector of the same length as their input

#'

#' [diff()] returns a integer64 vector shorter by `lag*differences` elements

#'

#' @keywords classes manip

#' @seealso [sum.integer64()] [integer64()]

#' @examples

#' cumsum(rep(as.integer64(1), 12))

#' diff(as.integer64(c(0, 1:12)))

#' cumsum(as.integer64(c(0, 1:12)))

#' diff(cumsum(as.integer64(c(0, 0, 1:12))), differences=2)

#' @name cumsum.integer64

NULL

#' Concatenating integer64 vectors

#'

#' The ususal functions 'c', 'cbind' and 'rbind'

#'

#' @param ... two or more arguments coerced to 'integer64' and

#' passed to [NextMethod()]

#' @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 vector of the appropriate mode. This could be a integer64 vector or a list of objects

#'

#' [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

#' first argument is 'integer64'

#'

#' @keywords classes manip

#' @seealso [rep.integer64()] [seq.integer64()] [as.data.frame.integer64()]

#' [integer64()]

#'

#' @examples

#' c(as.integer64(1), 2:6)

#' cbind(1:6, as.integer64(1:6))

#' rbind(1:6, as.integer64(1:6))

#' @name c.integer64

NULL

#' Replicate elements of integer64 vectors

#'

#' Replicate elements of integer64 vectors

#'

#' @param x a vector of 'integer64' to be replicated

#' @param ... further arguments passed to [NextMethod()]

#'

#' @returns [rep()] returns a integer64 vector

#' @keywords classes manip

#' @seealso [c.integer64()] [rep.integer64()]

#' [as.data.frame.integer64()] [integer64()]

#'

#' @examples

#' rep(as.integer64(1:2), 6)

#' rep(as.integer64(1:2), c(6, 6))

#' rep(as.integer64(1:2), length.out=6)

#' @name rep.integer64

NULL

#' integer64: Coercing to data.frame column

#'

#' Coercing integer64 vector to data.frame.

#'

#' @param x an integer64 vector

#' @param row.names,optional,... passed to NextMethod [as.data.frame()] after removing the

#' 'integer64' class attribute

#'

#' @returns a one-column data.frame containing an integer64 vector

#' @details

#' 'as.data.frame.integer64' is rather not intended to be called directly,

#' but it is required to allow integer64 as data.frame columns.

#' @note This is currently very slow -- any ideas for improvement?

#' @keywords classes manip

#' @seealso

#' [cbind.integer64()] [integer64()]

# as.vector.integer64 removed as requested by the CRAN maintainer [as.vector.integer64()]

#' @examples

#' as.data.frame(as.integer64(1:12))

#' data.frame(a=1:12, b=as.integer64(1:12))

#' @name as.data.frame.integer64

NULL

#' integer64: Maintaining S3 class attribute

#'

#' Maintaining integer64 S3 class attribute.

#'

#' @param class NULL or a character vector of class attributes

#' @param whichclass the (single) class name to add or remove from the class vector

#'

#' @returns NULL or a character vector of class attributes

#'

#' @keywords classes manip internal

#' @seealso [oldClass()] [integer64()]

#' @examples

#' plusclass("inheritingclass", "integer64")

#' minusclass(c("inheritingclass", "integer64"), "integer64")

#' @name plusclass

NULL

#' Test if two integer64 vectors are all.equal

#'

#' A utility to compare integer64 objects 'x' and 'y' testing for

#' ‘near equality’, see [all.equal()].

#'

#' @param target a vector of 'integer64' or an object that can be coerced

#' with [as.integer64()]

#' @param current a vector of 'integer64' or an object that can be coerced

#' with [as.integer64()]

#' @param tolerance numeric > 0. Differences smaller than `tolerance` are

#' not reported. The default value is close to `1.5e-8`.

#' @param scale `NULL` or numeric > 0, typically of length 1 or

#' `length(target)`. See Details.

#' @param countEQ logical indicating if the `target == current` cases should

#' be counted when computing the mean (absolute or relative) differences.

#' The default, `FALSE` may seem misleading in cases where `target` and

#' `current` only differ in a few places; see the extensive example.

#' @param formatFUN a [function()] of two arguments, `err`, the relative,

#' absolute or scaled error, and `what`, a character string indicating the

#' _kind_ of error; maybe used, e.g., to format relative and absolute errors

#' differently.

#' @param ... further arguments are ignored

#' @param check.attributes logical indicating if the [attributes()] of `target`

#' and `current` (other than the names) should be compared.

#'

#' @returns

#' Either ‘TRUE’ (‘NULL’ for ‘attr.all.equal’) or a vector of ‘mode’

#' ‘"character"’ describing the differences between ‘target’ and

#' ‘current’.

#'

#' @details

#' In [all.equal.numeric()] the type `integer` is treated as a proper subset

#' of `double` i.e. does not complain about comparing `integer` with `double`.

#' Following this logic `all.equal.integer64` treats `integer` as a proper

#' subset of `integer64` and does not complain about comparing `integer` with

#' `integer64`. `double` also compares without warning as long as the values

#' are within [lim.integer64()], if `double` are bigger `all.equal.integer64`

#' complains about the `all.equal.integer64 overflow warning`. For further

#' details see [all.equal()].

#'

#' @note

#' [all.equal()] only dispatches to this method if the first argument is `integer64`,

#' calling [all.equal()] with a `non-integer64` first and a `integer64` second argument

#' gives undefined behavior!

#'

#' @seealso [all.equal()]

#' @examples

#' all.equal(as.integer64(1:10), as.integer64(0:9))

#' all.equal(as.integer64(1:10), as.integer(1:10))

#' all.equal(as.integer64(1:10), as.double(1:10))

#' all.equal(as.integer64(1), as.double(1e300))

#' @name all.equal.integer64

NULL

#' Factors

#'

#' The function [factor] is used to encode a vector as a factor.

#'

#' @inheritParams base::factor

#' @param nmax an upper bound on the number of levels.

#'

#' @return An object of class "factor" or "ordered".

#' @seealso [factor][base::factor]

#' @examples

#' x <- as.integer64(c(132724613L, -2143220989L, -1L, NA, 1L))

#' factor(x)

#' ordered(x)

#' @name factor

NULL

methods::setOldClass("integer64")

methods::setOldClass("difftime")

# contributed by Leonardo Silvestri with modifications of JO

#' @rdname all.equal.integer64

#' @method all.equal integer64

#' @exportS3Method all.equal integer64

all.equal.integer64 <- function(target, current,

tolerance = sqrt(.Machine$double.eps),

scale = NULL,

countEQ = FALSE,

formatFUN = function(err, what) format(err),

...,

check.attributes = TRUE) {

if (!is.numeric(tolerance))

stop("'tolerance' should be numeric")

if (!is.numeric(scale) && !is.null(scale))

stop("'scale' should be numeric or NULL")

if (!is.logical(check.attributes))

stop(gettextf("'%s' must be logical", "check.attributes"),

domain = NA)

# JO: BEGIN respect that integer is a proper subset of integer64 like integer is a proper subset of double

oldwarn = getOption("warn")

on.exit(options(warn=oldwarn))

options(warn=2L)

if (!is.integer64(target)) {

cl <- oldClass(target)

oldClass(target) <- NULL

target <- try(as.integer64(target))

if (inherits(target, 'try-error'))

return(paste("while coercing 'target' to 'integer64':", attr(target, "condition")$message))

oldClass(target) <- c(cl, "integer64")

}

if (!is.integer64(current)) {

cl <- oldClass(current)

oldClass(current) <- NULL

current <- try(as.integer64(current))

if (inherits(current, 'try-error'))

return(paste("while coercing 'current' to 'integer64':", attr(current, "condition")$message))

oldClass(current) <- c(cl, "integer64")

}

# JO: END respect that integer is a proper subset of integer64 like integer is a proper subset of double

msg = NULL

msg = if (check.attributes)

attr.all.equal(target, current, tolerance = tolerance,

scale = scale, ...)

if (data.class(target) != data.class(current)) {

msg <- c(msg, paste0("target is ", data.class(target),

", current is ", data.class(current)))

return(msg)

}

lt = length(target)

lc = length(current)

if (lt != lc) {

if (!is.null(msg))

msg <- msg[-grep("\\bLengths\\b", msg)]

msg <- c(msg, paste0("integer64: lengths (", lt, ", ", lc, ") differ"))

return(msg)

}

out = is.na(target)

if (any(out != is.na(current))) {

msg <- c(msg, paste("'is.NA' value mismatch:", sum(is.na(current)),

"in current", sum(out), "in target"))

return(msg)

}

out = out | target == current

if (all(out))

return(msg %||% TRUE)

anyO = any(out)

sabst0 = if (countEQ && anyO) mean(abs(target[out])) else 0.0

if (anyO) {

keep <- which(!out)

target <- target [keep]

current <- current[keep]

if (!is.null(scale) && length(scale) > 1L) {

# TODO(R>=4.0.0): Try removing this ocl part when rep() dispatching WAI on all versions (#100)

ocl = class(scale)

scale = rep_len(scale, length(out))[keep]

class(scale) = ocl

}

}

N = length(target)

what = if (is.null(scale)) {

scale <- sabst0 + sum(abs(target)/N)

if (is.finite(scale) && scale > tolerance) {

"relative"

} else {

scale <- 1.0

"absolute"

}

} else {

stopifnot(scale > 0.0)

if (all(abs(scale - 1.0) < 1e-07))

"absolute"

else

"scaled"

}

xy = sum(abs(target - current) / (N*scale))

if (is.na(xy) || xy > tolerance)

msg <- c(msg, paste("Mean", what, "difference:", formatFUN(xy, what)))

msg %||% TRUE

}

# TODO(R>=4.2.0): Consider restoring extptr.as.ref= to the signature.

#' @rdname identical.integer64

#' @exportS3Method identical integer64

#' @export

identical.integer64 = function(x, y,

num.eq=FALSE,

single.NA=FALSE,

attrib.as.set=TRUE,

ignore.bytecode=TRUE,

ignore.environment=FALSE,

ignore.srcref=TRUE,

...) {

identical(x=x, y=y,

num.eq=num.eq,

single.NA=single.NA,

attrib.as.set=attrib.as.set,

ignore.bytecode=ignore.bytecode,

ignore.environment=ignore.environment,

ignore.srcref=ignore.srcref,

...

)

}

#' @rdname as.integer64.character

#' @export

as.integer64 = function(x, ...) UseMethod("as.integer64")

#' @rdname as.character.integer64

#' @export

as.bitstring = function(x, ...) UseMethod("as.bitstring")

#' @rdname plusclass

#' @export

minusclass = function(class, whichclass) {

if (!length(class)) return(class)

i = whichclass == class

if (any(i))

class[!i]

else

class

}

#' @export

plusclass = function(class, whichclass) {

if (!length(class)) return(whichclass)

c(class, if (!any(whichclass == class)) whichclass)

}

#' @rdname bit64-package

#' @param length length of vector using [integer()]

#' @return `integer64` returns a vector of 'integer64', i.e.,

#' a vector of [double()] decorated with class 'integer64'.

#' @export

integer64 = function(length=0L) {

ret = double(length)

oldClass(ret) = "integer64"

ret

}

#' @rdname bit64-package

#' @param x an integer64 vector

#' @export

is.integer64 = function(x) inherits(x, "integer64")

#' @rdname as.integer64.character

#' @export

as.integer64.NULL = function(x, ...) integer64()

#' @rdname as.integer64.character

#' @param keep.names (Deprecated) Logical, default `FALSE`. If `TRUE`, the input's names are retained.

#' @export

as.integer64.integer64 = function(x, ..., keep.names=FALSE) {

ret = unclass(x)

attributes(ret) = NULL

oldClass(ret) = "integer64"

if (isTRUE(keep.names)) {

warning("keep.names will be removed in a future version. The caller should add names if needed.")

names(ret) = names(x)

}

ret

}

#' @rdname as.integer64.character

#' @export

as.integer64.double = function(x, ..., keep.names=FALSE) {

ret = .Call(C_as_integer64_double, x, double(length(x)))

oldClass(ret) = "integer64"

if (isTRUE(keep.names)) {

warning("keep.names will be removed in a future version. The caller should add names if needed.")

names(ret) = names(x)

}

ret

}

#' @rdname as.integer64.character

#' @exportS3Method as.integer64 complex

as.integer64.complex = function(x, ...) {

xd = withCallingHandlers(

as.double(x),

# call.=FALSE to avoid confusion about where the warning arises

warning = function(w) {

warning(conditionMessage(w), call.=FALSE)

invokeRestart("muffleWarning")

}

)

ret = .Call(C_as_integer64_double, xd, double(length(xd)))

oldClass(ret) = "integer64"

ret

}

#' @rdname as.integer64.character

#' @export

as.integer64.integer = function(x, ...) {

ret = .Call(C_as_integer64_integer, x, double(length(x)))

oldClass(ret) = "integer64"

ret

}

#' @rdname as.integer64.character

#' @exportS3Method as.integer64 raw

as.integer64.raw = function(x, ...) {

ret = .Call(C_as_integer64_integer, as.integer(x), double(length(x)))

oldClass(ret) = "integer64"

ret

}

#' @rdname as.integer64.character

#' @export

as.integer64.logical = as.integer64.integer

#' @rdname as.integer64.character

#' @export

as.integer64.character = function(x, ...) {

ret = .Call(C_as_integer64_character, x, rep(NA_real_, length(x)))

oldClass(ret) = "integer64"

ret

}

#' @rdname as.integer64.character

#' @export

as.integer64.factor = function(x, ...) as.integer64(unclass(x), ...)

#' @rdname as.integer64.character

#' @exportS3Method as.integer64 Date

as.integer64.Date = function(x, ...) as.integer64(as.double(x))

#' @rdname as.integer64.character

#' @exportS3Method as.integer64 POSIXct

as.integer64.POSIXct = function(x, ...) as.integer64(as.double(x))

#' @rdname as.integer64.character

#' @exportS3Method as.integer64 POSIXlt

as.integer64.POSIXlt = function(x, ...) as.integer64(as.POSIXct(x))

#' @rdname as.integer64.character

#' @exportS3Method as.integer64 difftime

as.integer64.difftime = function(x, units="auto", ...) {

as.integer64(as.double(x, units=units, ...))

}

.as_double_integer64 = function(x, keep.attributes=FALSE, ...) {

ret = .Call(C_as_double_integer64, x, double(length(x)))

if (isTRUE(keep.attributes)) {

# like dimensions for matrix operations

a = attributes(x)

a$class = NULL

attributes(ret) = a

}

ret

}

#' @rdname as.character.integer64

#' @export

as.double.integer64 = function(x, ...) .as_double_integer64(x, keep.attributes=FALSE, ...)

#' @rdname as.character.integer64

#' @exportS3Method as.numeric integer64

as.numeric.integer64 = as.double.integer64

#' @rdname as.character.integer64

#' @exportS3Method as.complex integer64

as.complex.integer64 = function(x, ...) as.complex(as.double(x), ...)

#' @rdname as.character.integer64

#' @export

as.integer.integer64 = function(x, ...) {

.Call(C_as_integer_integer64, x, integer(length(x)))

}

#' @rdname as.character.integer64

#' @exportS3Method as.raw integer64

as.raw.integer64 = function(x, ...) {

withCallingHandlers(

as.raw(.Call(C_as_integer_integer64, x, integer(length(x)))),

warning = function(w) {

warning(conditionMessage(w), call.=FALSE)

invokeRestart("muffleWarning")

}

)

}

#' @rdname as.character.integer64

#' @export

as.logical.integer64 = function(x, ...) {

.Call(C_as_logical_integer64, x, logical(length(x)))

}

#' @rdname as.character.integer64

#' @export

as.character.integer64 = function(x, ...) {

.Call(C_as_character_integer64, x, rep(NA_character_, length(x)))

}

#' @rdname as.character.integer64

#' @export

as.bitstring.integer64 = function(x, ...) {

ret = .Call(C_as_bitstring_integer64, x, rep(NA_character_, length(x)))

oldClass(ret) = 'bitstring'

attr(ret, 'nbits') = c(1L, 63L)

attr(ret, 'type') = "int64"

ret

}

#' @rdname as.character.integer64

#' @exportS3Method as.Date integer64

as.Date.integer64 = function(x, origin, ...) {

as.Date(as.double(x), origin=origin, ...)

}

#' @rdname as.character.integer64

#' @exportS3Method as.POSIXct integer64

as.POSIXct.integer64 = function(x, tz="", origin, ...) {

as.POSIXct(as.double(x), tz=tz, origin=origin, ...)

}

#' @rdname as.character.integer64

#' @exportS3Method as.POSIXlt integer64

as.POSIXlt.integer64 = function(x, tz="", origin, ...) {

as.POSIXlt(as.double(x, ...), tz=tz, origin=origin, ...)

}

#' @rdname as.character.integer64

#' @export as.factor

as.factor = function(x) factor(x=x)

#' @rdname as.character.integer64

#' @export as.ordered

as.ordered = function(x) ordered(x=x)

#' @rdname factor

#' @export

factor = function(x=character(), levels, labels=levels, exclude=NA, ordered=is.ordered(x), nmax=NA) {

force(x)

if (!is.integer64(x)) {

sys_call = match.call()

sys_call[[1L]] = base::factor

sys_call$x = x

parent = parent.frame()

return(withCallingHandlers_and_choose_call(eval(sys_call, envir=parent), "factor"))

}

nx = names(x)

if (missing(levels)) {

levels = sort(unique(x))

} else if (length(x) >= 4000L) {

levels = as.integer64(levels)

}

# use base::factor for short vectors because it is faster

if (length(x) < 4000L) {

force(ordered)

x = as.character(x)

levels = as.character(levels)

if (missing(labels)) {

ret = withCallingHandlers_and_choose_call(

base::factor(x=x, levels=levels, exclude=exclude, ordered=ordered, nmax=nmax),

"factor"

)

} else {

ret = withCallingHandlers_and_choose_call(

base::factor(x=x, levels=levels, labels=labels, exclude=exclude, ordered=ordered, nmax=nmax),

"factor"

)

}

if (!is.null(nx))

names(ret) = nx

return(ret)

}

# basically copied from base::factor, but using the benefit from caching

levels = levels[is.na(match(levels, exclude))]

ret = match(x, levels)

if (!is.null(nx))

names(ret) = nx

if (missing(labels)) {

levels(ret) = as.character(levels)

} else {

nlab = length(labels)

if (nlab == length(levels)) {

xlevs = as.character(labels)

nlevs = unique(xlevs)

at = attributes(ret)

at$levels = nlevs

ret = match(xlevs, nlevs)[ret]

attributes(ret) = at

} else if (nlab == 1L) {

levels(ret) = paste0(labels, seq_along(levels))

} else {

stop(gettextf("invalid 'labels'; length %d should be 1 or %d", nlab, length(levels), domain="R-base"), domain=NA)

}

}

class(ret) <- c(if (ordered) "ordered", "factor")

ret

}

#' @rdname factor

#' @export

ordered = function(x=character(), ...) factor(x, ..., ordered=TRUE)

#' @rawNamespace if (getRversion() < "4.6.0") S3method(print,bitstring)

#' @exportS3Method NULL

print.bitstring = function(x, ...) {

reset_class = minusclass(class(x), 'bitstring')

attributes(x) = NULL

oldClass(x) = reset_class

NextMethod(x)

}

#' @rdname as.integer64.character

#' @export

as.integer64.bitstring = function(x, ...) {

ret = .Call(C_as_integer64_bitstring, x, double(length(x)))

oldClass(ret) = "integer64"

ret

}

# read.table expects S4 as()

methods::setAs("ANY", "integer64", function(from) as.integer64(from))

methods::setAs("integer64", "factor", function(from) as.factor(from))

methods::setAs("integer64", "ordered", function(from) as.ordered(from))

methods::setAs("integer64", "difftime", function(from) as.difftime(from, units="secs"))

methods::setAs("integer64", "POSIXct", function(from) as.POSIXct(from))

methods::setAs("integer64", "POSIXlt", function(from) as.POSIXlt(from))

methods::setAs("integer64", "Date", function(from) as.Date(from))

methods::setAs("integer64", "raw", function(from) as.raw(from))

# this is a trick to generate NA_integer64_ for namespace export before

# as.integer64() is available because dll is not loaded

#' @rdname as.integer64.character

#' @export

NA_integer64_ = unserialize(as.raw(c(

0x58, 0x0a, 0x00, 0x00, 0x00, 0x02, 0x00, 0x03, 0x03, 0x00, 0x00, 0x02, 0x03, 0x00, 0x00, 0x00,

0x03, 0x0e, 0x00, 0x00, 0x00, 0x01, 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,

0x04, 0x02, 0x00, 0x00, 0x00, 0x01, 0x00, 0x04, 0x00, 0x09, 0x00, 0x00, 0x00, 0x05, 0x63, 0x6c,

0x61, 0x73, 0x73, 0x00, 0x00, 0x00, 0x10, 0x00, 0x00, 0x00, 0x01, 0x00, 0x04, 0x00, 0x09, 0x00,

0x00, 0x00, 0x09, 0x69, 0x6e, 0x74, 0x65, 0x67, 0x65, 0x72, 0x36, 0x34, 0x00, 0x00, 0x00, 0xfe

)))

#' @rdname bit64-package

#' @param value an integer64 vector of values to be assigned

#' @export

`length<-.integer64` <- function(x, value) {

cl = oldClass(x)

n = length(x)

x = NextMethod()

oldClass(x) = cl

if (value>n)

x[(n+1L):value] <- 0L

x

}

#' @rdname format.integer64

#' @export

format.integer64 = function(x, justify="right", ...) {

a = attributes(x)

x = as.character(x)

ret = format(x, justify=justify, ...)

a$class = minusclass(a$class, "integer64")

attributes(ret) = a

ret

}

#' @rdname bit64-package

#' @param quote logical, indicating whether or not strings should be printed with surrounding quotes.

#' @param ... further arguments to the [NextMethod()]

#' @export

print.integer64 = function(x, quote=FALSE, ...) {

a = attributes(x)

if (length(x)) {

cat("integer64\n")

ret <- as.character(x)

a$class <- minusclass(a$class, "integer64")

attributes(ret) <- a

print(ret, quote=quote, ...)

} else {

cat("integer64(0)\n")

}

invisible(x)

}

#' @rdname bit64-package

#' @param object an integer64 vector

#' @param vec.len,give.head,give.length see [utils::str()]

#' @export

str.integer64 = function(object, vec.len=strO$vec.len, give.head=TRUE, give.length=give.head, ...) {

strO = strOptions()

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))) {

"integer64(0)"

} else {

paste0(

"integer64 ",

if (length(object) > 1L && is.null(dim(object))) {

if (isTRUE(give.length)) paste0("[1:", n, "] ") else " "

} else if (!is.null(obj_dim <- dim(object))) {

if (prod(obj_dim) != n)

stop(domain=NA, gettextf(

"dims [product %d] do not match the length of object [%d]",

prod(obj_dim), n,

domain="R"

))

if (length(obj_dim) == 1L) {

paste0("[", n, "(1d)] ")

} else {

dim_summary = vapply(obj_dim, function(el) if (el < 2L) as.character(el) else paste0("1:", el), "")

paste0("[", toString(dim_summary), "] ")

}

}

)

}

},

paste(as.character(displayObject), collapse=" "),

if (n > vec.len) " ...",

" \n",

sep=""

)

invisible()

}

position_args_with_int64_to_int_coercion = function(sys_call, eval_frame, skipLast=FALSE) {

sc = as.list(sys_call)[-(1:2)]

if (isTRUE(skipLast))

sc = sc[-length(sc)]

lapply(sc, function(el) {

if (missing_or_dots(el)) return(el)

el = eval(el, eval_frame)

if (is.integer64(el))

el = as.integer(el)

el

})

}

#' @rdname extract.replace.integer64

#' @export

`[.integer64` = function(x, i, j, ..., drop=TRUE) {

old_class = oldClass(x)

sc = sys.call() # NB: not match.call(), which eats a missing argument in x[1, , 3]

parent = parent.frame()

coerced_args = position_args_with_int64_to_int_coercion(sc, parent)

coerced_args$drop = FALSE

if (length(coerced_args) == 1L && isFALSE(drop)) return(x)

oldClass(x) = NULL

ret = withCallingHandlers_and_choose_call(do.call(`[`, c(list(x=x), coerced_args)), c("[", "[.integer64"))

NA_integer64_real = NA_integer64_

oldClass(NA_integer64_real) = NULL

# drop is not relevant anymore for NA handling

coerced_args$drop = NULL

# NA handling

if (length(dim(ret)) <= 1L) {

# vector mode

if (!missing_or_dots(coerced_args[[1L]])) {

arg1Value = coerced_args[[1L]]

if (is.logical(arg1Value)) {

ret[is.na(arg1Value[arg1Value])] = NA_integer64_real

} else if (is.character(arg1Value)) {

ret[is.na(arg1Value) | !nzchar(arg1Value) | !arg1Value %in% names(x)] = NA_integer64_real

} else if (anyNA(arg1Value) || suppressWarnings(max(arg1Value, na.rm=TRUE)) > length(x)) {

arg1Value = arg1Value[arg1Value != 0L]

ret[which(is.na(arg1Value) | arg1Value > length(x))] = NA_integer64_real

}

}

} else {

# array/matrix mode

dimSelect = coerced_args[seq_along(dim(x))]

for (ii in seq_along(dimSelect)) {

if (missing_or_dots(dimSelect[[ii]])) 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)))

}

}

}

# dimension handling

if (!isFALSE(drop) && !is.null(dim(ret))) {

newDim = dim(ret)[dim(ret) != 1L]

if (length(newDim) == 1L && !(length(dim(x)) == 1L && newDim != 1L))

newDim = NULL

dim(ret) = if (length(newDim)) newDim else NULL

}

oldClass(ret) = old_class

ret

}