wickra/bindings/r/tests/testthat/test-golden-all.R

# Generic golden-fixture parity for the whole 514-indicator catalogue: every
# indicator is reconstructed by its constructor, fed the synthetic stream derived
# from the shared testdata/golden input (identical to gen_golden's Rust
# construction) and checked bit-for-bit against g_<Canonical>.csv. One reflective
# runner flattens scalar, multi-output, profile and bar shapes.
#
# Like test-golden.R, the fixtures live at the repo root and are not bundled into
# the standalone package, so packaged checks (r-universe / CRAN) skip; the parity
# is enforced by the monorepo CI. Specs are generated by gen_golden_test.py.

find_golden_dir_all <- function() {
  d <- normalizePath(getwd(), winslash = "/", mustWork = FALSE)
  repeat {
    g <- file.path(d, "testdata", "golden")
    if (dir.exists(g)) return(g)
    parent <- dirname(d)
    if (identical(parent, d)) return(NULL)
    d <- parent
  }
}

golden_dir_all <- find_golden_dir_all()

test_that("all 514 indicators match the Rust golden fixtures", {
  skip_if(is.null(golden_dir_all), "golden fixtures not bundled with the package")
  source(test_path("golden_specs.R"), local = TRUE)

  gcell <- function(s) {
    if (s == "nan") NA_real_ else if (s == "inf") Inf else if (s == "-inf") -Inf else as.numeric(s)
  }
  read_rows <- function(name) {
    lines <- readLines(file.path(golden_dir_all, paste0(name, ".csv")))[-1]
    lapply(lines, function(l) {
      if (nchar(l) == 0) return(numeric(0))
      vapply(strsplit(l, ",", fixed = TRUE)[[1]], gcell, numeric(1), USE.NAMES = FALSE)
    })
  }
  input_rows <- lapply(
    readLines(file.path(golden_dir_all, "input.csv"))[-1],
    function(l) as.numeric(strsplit(l, ",", fixed = TRUE)[[1]])
  )

  deriv_fields <- function(r) {
    o <- r[1]; h <- r[2]; l <- r[3]; c <- r[4]; v <- r[5]
    c((c - o) / c * 0.01, c, c - 0.5, c + 1.0, v * 10, v * 0.6, v * 0.4,
      v * 0.55, v * 0.45, h - c, c - l)
  }
  cross_lists <- function(r) {
    o <- r[1]; c <- r[4]; v <- r[5]; j <- 0:4
    list(change = (c - o) + j, volume = v + j * 10,
         newHigh = as.numeric(j %% 2 == 0), newLow = as.numeric(j %% 3 == 0),
         aboveMa = as.numeric(j %% 2 == 0), onBuy = as.numeric(j %% 3 == 0))
  }
  ob_lists <- function(r) {
    c <- r[4]; v <- r[5]; k <- 1:5
    list(bp = c - 0.1 * k, bs = v / k, ap = c + 0.1 * k, asz = v * 0.9 / k)
  }
  flatten <- function(o, arch, width) {
    if (arch %in% c("profile_bins")) {
      if (is.null(o) || length(o) == 0 || all(is.na(o))) return(rep(NA_real_, width))
      return(as.numeric(o))
    }
    if (arch == "profile_pricebins") {
      if (is.list(o)) return(c(o$price_low, o$price_high, as.numeric(o$values)))
      return(rep(NA_real_, width))
    }
    if (arch %in% c("bars_close", "bars_candle4", "bars_candle5", "footprint")) {
      if (is.null(o) || length(o) == 0) return(numeric(0))
      if (is.matrix(o)) return(as.numeric(t(o)))
      return(as.numeric(o))
    }
    as.numeric(o)
  }

  compute <- function(spec, ind, r, i) {
    o <- r[1]; h <- r[2]; l <- r[3]; cl <- r[4]; v <- r[5]; ts <- as.integer(i - 1)
    out <- switch(spec$arch,
      scalar_f64 = update(ind, cl),
      multi_f64  = update(ind, cl),
      pairwise = , multi_pairwise = update(ind, cl, o),
      scalar_candle = , multi_candle = , profile_bins = , profile_pricebins =
        update(ind, o, h, l, cl, v, ts),
      trade = update(ind, cl, v, cl >= o, ts),
      trademid = update(ind, cl, v, cl >= o, ts, (h + l) / 2),
      ob = { L <- ob_lists(r); update(ind, L$bp, L$bs, L$ap, L$asz) },
      cross = { L <- cross_lists(r)
        update(ind, L$change, L$volume, L$newHigh, L$newLow, L$aboveMa, L$onBuy, ts) },
      deriv = , deriv_multi = { d <- deriv_fields(r)
        do.call(update, c(list(ind), as.list(d), list(ts))) },
      bars_close = update(ind, cl, cl, cl, cl, 1, 0L),
      bars_candle4 = update(ind, o, h, l, cl, 1, 0L),
      bars_candle5 = update(ind, o, h, l, cl, v, 0L),
      footprint = update(ind, cl, v, cl >= o, ts),
      stop("arch ", spec$arch)
    )
    flatten(out, spec$arch, spec$width)
  }

  for (spec in GOLDEN_SPECS) {
    ind <- do.call(get(spec$canon), as.list(spec$params))
    expect_identical(name(ind), spec$name,
      info = sprintf("%s name()", spec$canon))
    exp <- read_rows(paste0("g_", spec$canon))
    for (i in seq_along(input_rows)) {
      got <- compute(spec, ind, input_rows[[i]], i)
      want <- exp[[i]]
      expect_equal(length(got), length(want),
        info = sprintf("%s row %d arity", spec$canon, i))
      for (k in seq_along(want)) {
        w <- want[k]; g <- got[k]
        if (is.na(w)) {
          expect_true(is.na(g), info = sprintf("%s row %d col %d: want NA", spec$canon, i, k))
        } else if (is.infinite(w)) {
          expect_true(is.infinite(g) && sign(g) == sign(w),
            info = sprintf("%s row %d col %d: want %g", spec$canon, i, k, w))
        } else {
          expect_lte(abs(g - w), 1e-6 * max(1, abs(w)),
            label = sprintf("%s row %d col %d (got %s want %g)", spec$canon, i, k, as.character(g), w))
        }
      }
    }
  }
})