From 85e7aa28a1d4f82cba6ff00e41fd182e0fd779e2 Mon Sep 17 00:00:00 2001
From: Michael Chirico <michaelchirico4@gmail.com>
Date: Sun, 20 Oct 2024 22:06:31 -0700
Subject: [PATCH] Fixes for vector scale= in all.equal (#99)

* Fixes for vector scale= in all.equal

* Skip test not working on old R

* more tests for all.equal() coverage

* One more test
---
 NEWS                            |  4 +++
 R/integer64.R                   | 48 ++++++++++++++++-----------------
 tests/testthat/test-integer64.R | 48 +++++++++++++++++++++++++++++++++
 3 files changed, 76 insertions(+), 24 deletions(-)

diff --git a/NEWS b/NEWS
index b4cd6bd..677c908 100644
--- a/NEWS
+++ b/NEWS
@@ -42,6 +42,10 @@
 
 1. `is.na()` is supported for long vector input (more than `2^31` elements), #30. Thanks @ilia-kats for the request. Long vector support will be added on an as-needed basis as I don't have a great machine for testing these features -- PRs welcome!
 
+## BUG FIXES
+
+1. `all.equal.integer64()` gets the same fix for vector `scale=` to work as intended that `all.equal.numeric()` got in R 4.1.3, #23.
+
 ## NOTES
 
 1. After creating, developing, and maintaining {bit64} for about 13 years, Jens Oehlschlägel has decided to step down as maintainer of the package. Michael Chirico will take over in this duty. Thank you Jens for creating such a wonderful & important part of the R ecosystem!
diff --git a/R/integer64.R b/R/integer64.R
index 8cfe7db..5ccc035 100644
--- a/R/integer64.R
+++ b/R/integer64.R
@@ -506,32 +506,32 @@ all.equal.integer64  <- function (
   out <- out | target == current
   if (all(out))
     return(if (is.null(msg)) TRUE else msg)
-  if (countEQ) {
-    N <- length(out)
-    sabst0 <- sum(abs(target[out]))
-  } else {
-    sabst0 <- 0.0
+  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)
+      scale <- rep_len(scale, length(out))[keep]
   }
-  target <- target[!out]
-  current <- current[!out]
-  if (!countEQ)
-    N <- length(target)
-  xy <- sum(abs(target - current))/N
+  N <- length(target)
   what <- if (is.null(scale)) {
-            xn <- (sabst0 + sum(abs(target)))/N
-            if (is.finite(xn) && xn > tolerance) {
-              xy <- xy/xn
-              "relative"
-            } else {
-              "absolute"
-            }
-          } else {
-            stopifnot(scale > 0.0)
-            xy <- xy/scale
-            if (all(abs(scale - 1.0) < 1e-07))
-              "absolute"
-            else "scaled"
-          }
+    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)))
   if (is.null(msg)) {
diff --git a/tests/testthat/test-integer64.R b/tests/testthat/test-integer64.R
index 0c37b5f..7cfe2db 100644
--- a/tests/testthat/test-integer64.R
+++ b/tests/testthat/test-integer64.R
@@ -271,3 +271,51 @@ test_that("semantics about mixed types for division are respected", {
     expect_identical(i64 / i64, 1.0)
   })
 })
+
+test_that("all.equal.integer64 reflects changes for vector scale= from all.equal.numeric", {
+  # same test as for base R, multiplied by 1000 so the inputs are all integer64
+  expect_identical(
+    all.equal(
+      as.integer64(c(1000L, 1000L)),
+      as.integer64(c(1010L, 1010L)),
+      scale = c(10.0, 10.0)
+    ),
+    "Mean scaled difference: 1"
+  )
+  # TODO(#100): restore this if possible.
+  skip_if_not_r_version("4.1.3")
+  # same test as for base R, multiplied by 1e9
+  one_e9 = as.integer64(1000000000L)
+  expect_true(all.equal(
+    rep(one_e9, 5L),
+    one_e9 + (-1L:3), # TODO(r-lib/lintr#): no 'L'
+    scale = (1:5)*one_e9
+  ))
+})
+
+test_that("all.equal works", {
+  x = y = as.integer64(1L)
+
+  expect_true(all.equal(x, x))
+
+  class(y) = c("xx", "integer64")
+  expect_match(all.equal(x, y), "target is integer64, current is xx", fixed=TRUE, all=FALSE)
+  expect_match(all.equal(x[0L], x[1L]), "integer64: lengths.*differ", all=FALSE)
+
+  class(y) = "integer64"
+  attr(y, "xx") = "zz"
+  expect_match(all.equal(x, y), "Attributes", fixed=TRUE)
+  expect_no_match(
+    expect_match(all.equal(x[0L], y), "integer64: lengths.*differ", all=FALSE),
+    "Lengths:", fixed = TRUE
+  )
+
+  y = NA_integer64_
+  expect_match(all.equal(x, y), "'is.NA' value mismatch", fixed=TRUE)
+
+  x = as.integer64(1000000000L)
+  expect_true(all.equal(x, x+1L))
+  expect_true(all.equal(x, x+1L, tolerance=1.0e9)) # forcing scale=1
+  expect_match(all.equal(x, x+100L), "Mean relative difference", fixed=TRUE)
+  expect_match(all.equal(x, x+1L, scale=1.0), "Mean absolute difference", fixed=TRUE)
+})