From 0454ba690471d0390226b2b392a3faa308a7ee8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 21:33:55 +0100 Subject: [PATCH 1/9] test(switch): cover hash lookup semantics for many values (#107) Add regression tests for vswitch()/nswitch() with more than 8 value/output pairs: last-duplicate-wins, NA/NaN behaviour per type, mixed encoding, factor/Date outputs, vector recycling, and thread determinism. The tests pass on the current value-major implementation and will guard the new hash path. --- inst/tinytest/test-switch-hash.R | 137 +++++++++++++++++++++++++++++++ 1 file changed, 137 insertions(+) create mode 100644 inst/tinytest/test-switch-hash.R diff --git a/inst/tinytest/test-switch-hash.R b/inst/tinytest/test-switch-hash.R new file mode 100644 index 0000000..93c4f65 --- /dev/null +++ b/inst/tinytest/test-switch-hash.R @@ -0,0 +1,137 @@ +# Tests for the hash lookup used by vswitch()/nswitch() with many values (#107). +# The hash path is selected for more than 8 value/output pairs; these cases pin +# down the matching semantics it must share with the value-major fallback: +# last pair wins, NA/NaN handling per type, encoding, vector recycling, and +# thread determinism. + +sys.source("helper-kit.R", envir = environment()) + +# Reference for types where NA matches NA (integer, logical, string, factor). +ref_na <- function(x, values, outputs, default = NA) { + ans <- rep(default, length(x)) + for (i in seq_along(values)) { + hit <- if (is.na(values[i])) is.na(x) else !is.na(x) & x == values[i] + ans[hit] <- rep_len(outputs[[i]], length(x))[hit] + } + ans +} + +# Reference for doubles/complex, where NA and NaN never match. +ref_num <- function(x, values, outputs, default = NA) { + ans <- rep(default, length(x)) + for (i in seq_along(values)) { + hit <- !is.na(values[i]) & !is.nan(values[i]) & + !is.na(x) & !is.nan(x) & x == values[i] + ans[hit] <- rep_len(outputs[[i]], length(x))[hit] + } + ans +} + +# Integer: NA is the same bit pattern, so it matches NA. +vals_i <- c(9:1, 1L, NA_integer_) +outs_i <- c(101:109, 110L, 111L) +x_i <- c(1:9, NA_integer_, NA_integer_, 0L) +exp_i <- ref_na(x_i, vals_i, as.list(outs_i)) +expect_identical(vswitch(x_i, vals_i, outs_i), exp_i, + info = "hash-vswitch-int") +expect_identical(vswitch(x_i, vals_i, outs_i, nThread = 2L), exp_i, + info = "hash-vswitch-int-threads") + +vals_l <- c(rep(TRUE, 9), FALSE, NA) +outs_l <- c(1:9, 10L, 11L) +x_l <- c(NA, TRUE, FALSE, TRUE) +expect_identical(vswitch(x_l, vals_l, outs_l), + ref_na(x_l, vals_l, as.list(outs_l)), + info = "hash-vswitch-lgl") + +# Strings: NA_STRING is a CHARSXP and therefore matches itself. +vals_s <- c(paste0("v", 1:9), "v1", NA_character_) +outs_s <- c(1:9, 10L, 11L) +x_s <- c("v1", "v9", NA_character_, "zz") +exp_s <- ref_na(x_s, vals_s, as.list(outs_s)) +expect_identical(vswitch(x_s, vals_s, outs_s), exp_s, + info = "hash-vswitch-str") +expect_identical(vswitch(enc2utf8(x_s), enc2utf8(vals_s), outs_s), exp_s, + info = "hash-vswitch-str-utf8") + +enc_lat <- "fa\xE7ile" +Encoding(enc_lat) <- "latin1" +enc_utf <- enc2utf8(enc_lat) +vals_e <- c(paste0("v", 1:8), enc_lat, enc_utf) +x_e <- c(enc_lat, enc_utf, paste0("v", 1:8)) +expect_identical(vswitch(x_e, vals_e, c(1:8, 9L, 10L)), + c(10L, 10L, 1:8), info = "hash-vswitch-str-enc") + +# Doubles: -0 == 0, Inf matches, but NA/NaN never match. +vals_d <- c(1:8, Inf, 0, NA_real_, NaN) +outs_d <- c(101:108, 109L, 110L, 111L, 112L) +x_d <- c(-0, 0, Inf, NA_real_, NaN, 1:8, 99) +exp_d <- ref_num(x_d, vals_d, as.list(outs_d)) +expect_identical(vswitch(x_d, vals_d, outs_d), exp_d, + info = "hash-vswitch-dbl") +expect_identical(vswitch(x_d, vals_d, outs_d, nThread = 2L), exp_d, + info = "hash-vswitch-dbl-threads") + +# Complex: component-wise ==, so NA/NaN components never match. +vals_c <- c(as.complex(1:8), 0 + 0i, NA_complex_) +outs_c <- c(101:108, 110L, 111L) +x_c <- c(0 + 0i, 1 + 0i, NA_complex_, 1 + 1i) +expect_identical(vswitch(x_c, vals_c, outs_c), + ref_num(x_c, vals_c, as.list(outs_c)), + info = "hash-vswitch-cplx") + +# Factor codes go through the integer path; classes and levels are preserved. +f_x <- factor(c(letters[1:9], "a", NA), levels = letters[1:9]) +f_v <- factor(c(letters[1:9], "a", NA), levels = letters[1:9]) +f_o <- factor(c(letters[9:1], "a", NA), levels = letters[1:9]) +ans_f <- vswitch(f_x, f_v, f_o, factor(NA, levels = letters[1:9])) +expect_identical(ans_f, + factor(c("a", letters[8:1], "a", NA), levels = letters[1:9]), + info = "hash-vswitch-factor") + +# Date outputs keep their class. +d_o <- as.Date("2020-01-01") + 0:10 +exp_dt <- as.Date("2020-01-01") + c(9, 7:0, 10, 10, NA) +expect_identical(vswitch(x_i, vals_i, as.list(d_o), as.Date(NA)), exp_dt, + info = "hash-vswitch-date") + +# Element-length outputs are recycled by x position, not by pair. +out_vec <- lapply(seq_along(vals_i), function(i) seq_along(x_i) + i * 100L) +exp_vec <- ref_na(x_i, vals_i, out_vec) +expect_identical(vswitch(x_i, vals_i, out_vec), exp_vec, + info = "hash-vswitch-vector-output") + +# Empty input still accepts many values and returns an empty result. +expect_identical(vswitch(integer(), vals_i, outs_i), integer(), + info = "hash-vswitch-empty") + +# nswitch shares the same lookup. Duplicate values keep the last pair. +pairs <- unlist(lapply(1:9, function(i) list(i, i + 100L)), recursive = FALSE) +pairs <- c(pairs, list(1L, 999L, NA_integer_, 998L)) +ns <- function(x) do.call(nswitch, c(list(x), pairs, list(default = 0L))) +expect_identical(ns(c(1:9, NA_integer_, NA_integer_, 0L)), + c(999L, 102:109, 998L, 998L, 0L), + info = "hash-nswitch-int") +expect_identical(do.call(nswitch, c(list(c(1:9, NA_integer_)), pairs, + list(default = 0L, nThread = 2L))), + ns(c(1:9, NA_integer_)), info = "hash-nswitch-threads") + +pairs_s <- unlist(lapply(1:9, function(i) list(paste0("v", i), i + 100L)), + recursive = FALSE) +pairs_s <- c(pairs_s, list("v1", 999L, NA_character_, 998L)) +ns_s <- function(x) do.call(nswitch, c(list(x), pairs_s, list(default = 0L))) +expect_identical(ns_s(c("v1", "v9", NA_character_, "zz")), + c(999L, 109L, 998L, 0L), info = "hash-nswitch-str") + +# nswitch vector outputs are recycled by element of x. +pairs_v <- unlist(lapply(seq_along(vals_i), + function(i) list(vals_i[i], seq_along(x_i) + i * 100L)), + recursive = FALSE) +ns_v <- function(x) do.call(nswitch, c(list(x), pairs_v, + list(default = NA_integer_))) +expect_identical(ns_v(x_i), exp_vec, info = "hash-nswitch-vector-output") + +# list inputs stay on the existing deep-equality path. +xl <- as.list(x_i) +expect_identical(vswitch(xl, as.list(vals_i), outs_i), exp_i, + info = "hash-vswitch-list-input") From e0c9d6fb3ecfbbe8c8c53bdc90dc78c37b786940 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 21:38:00 +0100 Subject: [PATCH 2/9] perf(switch): hash value lookup for many vswitch/nswitch pairs (#107) For more than 8 value/output pairs, build a value -> last pair index map once and scan x in blocks instead of comparing x against every value. Matching semantics are unchanged: integer/logical NA matches NA, doubles/complex canonicalise -0 and never match NA/NaN, strings compare CHARSXP identity. Small maps are kept sparse (at least 256 slots, 4x values up to 4096) because probe count matters more than a few cache lines; large maps use a 2x load factor. vswitch string 100 values on 2m elements: 0.063s -> 0.007s; 10m: 0.317s -> ~0.04s. nswitch 100 pairs on 2m: 0.069s -> 0.012s (int), 0.072s -> 0.018s (string). The <= 8 pair value-major path is untouched. --- src/kit.h | 4 + src/nswitch.c | 36 +++++ src/switch_hash.c | 404 ++++++++++++++++++++++++++++++++++++++++++++++ src/vswitch.c | 12 ++ 4 files changed, 456 insertions(+) create mode 100644 src/switch_hash.c diff --git a/src/kit.h b/src/kit.h index d8f64ce..6eb26bf 100644 --- a/src/kit.h +++ b/src/kit.h @@ -355,3 +355,7 @@ extern SEXP clearMappingObjectR(SEXP ext, SEXP verboseArg); bool isMixEnc(SEXP x); SEXP enc2UTF8(SEXP x); +void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, + SEXPTYPE type_x, SEXPTYPE type_o, R_xlen_t len_x, + R_xlen_t len_values, R_xlen_t len_na, int nth, bool nonna, + bool utfcon, SEXP xans, SEXP vans); diff --git a/src/nswitch.c b/src/nswitch.c index c336780..ecc583c 100644 --- a/src/nswitch.c +++ b/src/nswitch.c @@ -133,6 +133,42 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { } SEXP ans = PROTECT(allocVector(type0, len_x)); copyMostAttrib(PTR_ETL(args, 1), ans); + if (n > 8 && len_x <= INT_MAX && type_x != VECSXP) { + SEXP values = PROTECT(allocVector(type_x, n)); + SEXP outputs = PROTECT(allocVector(VECSXP, n)); + switch (type_x) { + case LGLSXP: { + int *restrict pv = LOGICAL(values); + for (int i = 0; i < n; ++i) pv[i] = LOGICAL(PTR_ETL(args, 2*i))[0]; + } break; + case INTSXP: { + int *restrict pv = INTEGER(values); + for (int i = 0; i < n; ++i) pv[i] = INTEGER(PTR_ETL(args, 2*i))[0]; + } break; + case REALSXP: { + double *restrict pv = REAL(values); + for (int i = 0; i < n; ++i) pv[i] = REAL(PTR_ETL(args, 2*i))[0]; + } break; + case CPLXSXP: { + Rcomplex *restrict pv = COMPLEX(values); + for (int i = 0; i < n; ++i) pv[i] = COMPLEX(PTR_ETL(args, 2*i))[0]; + } break; + case STRSXP: { + for (int i = 0; i < n; ++i) { + SET_STRING_ELT(values, i, + STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i))[0]); + } + } break; + } + for (int i = 0; i < n; ++i) { + SET_VECTOR_ELT(outputs, i, PTR_ETL(args, 2*i+1)); + } + kit_switch_hash(ans, x, values, outputs, na, type_x, VECSXP, len_x, n, + len_na, nth, nonna, utfcon, xans, vans); + UNPROTECT(2); + UNPROTECT(nprotect + 3); + return ans; + } switch(type0) { /* * This part is for LOGICAL diff --git a/src/switch_hash.c b/src/switch_hash.c new file mode 100644 index 0000000..228872f --- /dev/null +++ b/src/switch_hash.c @@ -0,0 +1,404 @@ +/* + * kit : Useful R Functions Implemented in C + * Copyright (C) 2020-2025 Morgan Jacob + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program. If not, see . + */ + +#include "kit.h" + +/* + * Value -> last pair index map for vswitch()/nswitch() when there are many + * values. The value-major fallback compares x against every value; this map + * finds the pair in one probe and then scans x once. + * + * Matching follows the fallback exactly: integer/logical use bit equality (so + * NA matches NA), doubles and complex canonicalise -0 and never match NA/NaN, + * and strings compare CHARSXP identity (so NA_STRING matches itself). + * + * x is processed in blocks so the temporary match indices stay in cache and a + * long input does not need a second full-length allocation. + */ + +#define KIT_SW_BLOCK 4096 + +static inline uint32_t kit_sw_mix32(uint32_t x) { + x ^= x >> 16; + x *= 0x9E3779B1U; + x ^= x >> 13; + return x; +} + +static inline uint32_t kit_sw_mix64(uint64_t x) { + x ^= x >> 33; + x *= 0xff51afd7ed558ccdULL; + x ^= x >> 33; + return (uint32_t)x; +} + +static inline uint64_t kit_sw_bits_dbl(double x) { + union { double d; uint64_t u; } v; + v.d = (x == 0.0) ? 0.0 : x; // -0 == 0 + return v.u; +} + +static inline uint32_t kit_sw_hash_int(int x) { + return kit_sw_mix32((uint32_t)x); +} + +static inline uint32_t kit_sw_hash_dbl(double x) { + return kit_sw_mix64(kit_sw_bits_dbl(x)); +} + +static inline uint32_t kit_sw_hash_cplx(Rcomplex x) { + return kit_sw_mix64(kit_sw_bits_dbl(x.r) ^ + (kit_sw_bits_dbl(x.i) * 0x9E3779B97F4A7C15ULL)); +} + +static inline uint32_t kit_sw_hash_str(SEXP x) { + const uintptr_t p = (uintptr_t)x; + return kit_sw_mix64((uint64_t)p ^ ((uint64_t)p >> 17)); +} + +static inline bool kit_sw_eq_int(int a, int b) { return a == b; } +static inline bool kit_sw_eq_dbl(double a, double b) { + return kit_sw_bits_dbl(a) == kit_sw_bits_dbl(b); +} +static inline bool kit_sw_eq_cplx(Rcomplex a, Rcomplex b) { + return kit_sw_bits_dbl(a.r) == kit_sw_bits_dbl(b.r) && + kit_sw_bits_dbl(a.i) == kit_sw_bits_dbl(b.i); +} +static inline bool kit_sw_eq_str(SEXP a, SEXP b) { return a == b; } + +static inline bool kit_sw_skip_none_int(int x) { (void)x; return false; } +static inline bool kit_sw_skip_none_str(SEXP x) { (void)x; return false; } +static inline bool kit_sw_skip_dbl(double x) { return ISNAN(x); } +static inline bool kit_sw_skip_cplx(Rcomplex x) { return ISNAN(x.r) || ISNAN(x.i); } + +#define KIT_SW_MAP_DEF(TAG, TYPE, HASHFN, EQFN, SKIPFN) \ +static inline void kit_sw_build_##TAG(const TYPE *v, const R_xlen_t m, \ + int *h, const size_t mask) { \ + for (R_xlen_t i = 0; i < m; ++i) { \ + if (SKIPFN(v[i])) continue; \ + size_t id = (size_t)HASHFN(v[i]) & mask; \ + while (h[id] && !EQFN(v[h[id]-1], v[i])) id = (id + 1) & mask; \ + h[id] = (int)i + 1; /* later pairs overwrite earlier ones */ \ + } \ +} \ +static inline int kit_sw_get_##TAG(const TYPE *v, const int *h, \ + const size_t mask, const TYPE x) { \ + if (SKIPFN(x)) return -1; \ + size_t id = (size_t)HASHFN(x) & mask; \ + while (h[id]) { \ + if (EQFN(v[h[id]-1], x)) return h[id]-1; \ + id = (id + 1) & mask; \ + } \ + return -1; \ +} + +KIT_SW_MAP_DEF(lgl, int, kit_sw_hash_int, kit_sw_eq_int, kit_sw_skip_none_int) +KIT_SW_MAP_DEF(int, int, kit_sw_hash_int, kit_sw_eq_int, kit_sw_skip_none_int) +KIT_SW_MAP_DEF(dbl, double, kit_sw_hash_dbl, kit_sw_eq_dbl, kit_sw_skip_dbl) +KIT_SW_MAP_DEF(cplx, Rcomplex, kit_sw_hash_cplx, kit_sw_eq_cplx, kit_sw_skip_cplx) +KIT_SW_MAP_DEF(str, SEXP, kit_sw_hash_str, kit_sw_eq_str, kit_sw_skip_none_str) + +#define KIT_SW_MATCH_DEF(TAG, TYPE) \ +static inline void kit_sw_match_##TAG(const TYPE *px, const TYPE *pv, \ + const int *h, const size_t mask, \ + int *match, const R_xlen_t off, \ + const R_xlen_t len) { \ + for (ssize_t j = 0; j < len; ++j) \ + match[j] = kit_sw_get_##TAG(pv, h, mask, px[off + j]); \ +} + +KIT_SW_MATCH_DEF(lgl, int) +KIT_SW_MATCH_DEF(int, int) +KIT_SW_MATCH_DEF(dbl, double) +KIT_SW_MATCH_DEF(cplx, Rcomplex) +KIT_SW_MATCH_DEF(str, SEXP) + +static inline void kit_sw_write_lgl(SEXP ans, const int *match, + const R_xlen_t off, const R_xlen_t len, + const int *pna, const ssize_t namask, + int *const *ppo, const ssize_t *amask) { + int *restrict pans = LOGICAL(ans); + for (ssize_t j = 0; j < len; ++j) { + const int k = match[j]; + pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : NA_LOGICAL) + : ppo[k][(off + j) & amask[k]]; + } +} + +static inline void kit_sw_write_int(SEXP ans, const int *match, + const R_xlen_t off, const R_xlen_t len, + const int *pna, const ssize_t namask, + int *const *ppo, const ssize_t *amask) { + int *restrict pans = INTEGER(ans); + for (ssize_t j = 0; j < len; ++j) { + const int k = match[j]; + pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : NA_INTEGER) + : ppo[k][(off + j) & amask[k]]; + } +} + +static inline void kit_sw_write_dbl(SEXP ans, const int *match, + const R_xlen_t off, const R_xlen_t len, + const double *pna, const ssize_t namask, + double *const *ppo, const ssize_t *amask) { + double *restrict pans = REAL(ans); + for (ssize_t j = 0; j < len; ++j) { + const int k = match[j]; + pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : NA_REAL) + : ppo[k][(off + j) & amask[k]]; + } +} + +static inline void kit_sw_write_cplx(SEXP ans, const int *match, + const R_xlen_t off, const R_xlen_t len, + const Rcomplex *pna, const ssize_t namask, + Rcomplex *const *ppo, + const ssize_t *amask) { + Rcomplex *restrict pans = COMPLEX(ans); + Rcomplex na_cplx; + na_cplx.r = NA_REAL; + na_cplx.i = NA_REAL; + for (ssize_t j = 0; j < len; ++j) { + const int k = match[j]; + pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : na_cplx) + : ppo[k][(off + j) & amask[k]]; + } +} + +static inline void kit_sw_write_str(SEXP ans, const int *match, + const R_xlen_t off, const R_xlen_t len, + const SEXP *pna, const ssize_t namask, + const SEXP *const *ppo, + const ssize_t *amask) { + for (ssize_t j = 0; j < len; ++j) { + const int k = match[j]; + SET_STRING_ELT(ans, off + j, + k < 0 ? (pna ? pna[(off + j) & namask] : NA_STRING) + : ppo[k][(off + j) & amask[k]]); + } +} + +static inline void kit_sw_write_vec(SEXP ans, const int *match, + const R_xlen_t off, const R_xlen_t len, + const SEXP *pna, const ssize_t namask, + const SEXP *const *ppo, + const ssize_t *amask) { + for (ssize_t j = 0; j < len; ++j) { + const int k = match[j]; + if (k < 0) { + if (pna) SET_VECTOR_ELT(ans, off + j, pna[(off + j) & namask]); + } else { + SET_VECTOR_ELT(ans, off + j, ppo[k][(off + j) & amask[k]]); + } + } +} + +void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, + const SEXPTYPE type_x, const SEXPTYPE type_o, + const R_xlen_t len_x, const R_xlen_t len_values, + const R_xlen_t len_na, const int nth, const bool nonna, + const bool utfcon, SEXP xans, SEXP vans) { + const bool list_out = type_o == VECSXP; + const SEXP *po = list_out ? SEXPPTR_RO(outputs) : NULL; + const SEXPTYPE type_ot = list_out ? UTYPEOF(po[0]) : type_o; + const ssize_t namask = len_na > 1 ? SSIZE_MAX : 0; + const SEXP sx = utfcon ? xans : x; + const SEXP sv = utfcon ? vans : values; + const int nth_hash = nth < 1 ? 1 : nth; + const bool serial_out = type_ot == STRSXP || type_ot == VECSXP; + + /* Keep small tables sparse (they still fit in cache) so a miss usually + stops after one probe; large tables stay at a 2x load factor. */ + size_t cap = 256; + const size_t target = (size_t)len_values * (len_values <= 4096 ? 4 : 2); + while (cap < target) cap <<= 1; + const size_t mask = cap - 1; + int *slots = (int*) R_Calloc(cap, int); + int *match = (int*) R_alloc((size_t) nth_hash * KIT_SW_BLOCK, sizeof(int)); + + switch (type_x) { + case LGLSXP: + kit_sw_build_lgl(LOGICAL(sv), len_values, slots, mask); + break; + case INTSXP: + kit_sw_build_int(INTEGER(sv), len_values, slots, mask); + break; + case REALSXP: + kit_sw_build_dbl(REAL(sv), len_values, slots, mask); + break; + case CPLXSXP: + kit_sw_build_cplx(COMPLEX(sv), len_values, slots, mask); + break; + case STRSXP: + kit_sw_build_str(STRING_PTR_RO(sv), len_values, slots, mask); + break; + default: + R_Free(slots); + error("Type %s is not supported for hashed switch.", type2char(type_x)); + } + + /* Output pointers: a list of per-pair outputs, or a vector of pair results. */ + void *ppo_store = NULL; + ssize_t *amask = (ssize_t*) R_alloc((size_t) len_values, sizeof(ssize_t)); + const SEXP *ppo_vec = NULL; + const int *ppo_int = NULL; + const double *ppo_dbl = NULL; + const Rcomplex *ppo_cplx = NULL; + const SEXP *ppo_str = NULL; + const SEXP *ppo_list = NULL; + switch (type_ot) { + case LGLSXP: + ppo_store = R_alloc((size_t) len_values, sizeof(int*)); + if (list_out) { + for (ssize_t i = 0; i < len_values; ++i) { + ((int**) ppo_store)[i] = LOGICAL(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; + } + } else { + ppo_int = LOGICAL(outputs); + for (ssize_t i = 0; i < len_values; ++i) { + ((int**) ppo_store)[i] = (int*) ppo_int + i; + amask[i] = 0; + } + } + break; + case INTSXP: + ppo_store = R_alloc((size_t) len_values, sizeof(int*)); + if (list_out) { + for (ssize_t i = 0; i < len_values; ++i) { + ((int**) ppo_store)[i] = INTEGER(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; + } + } else { + ppo_int = INTEGER(outputs); + for (ssize_t i = 0; i < len_values; ++i) { + ((int**) ppo_store)[i] = (int*) ppo_int + i; + amask[i] = 0; + } + } + break; + case REALSXP: + ppo_store = R_alloc((size_t) len_values, sizeof(double*)); + if (list_out) { + for (ssize_t i = 0; i < len_values; ++i) { + ((double**) ppo_store)[i] = REAL(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; + } + } else { + ppo_dbl = REAL(outputs); + for (ssize_t i = 0; i < len_values; ++i) { + ((double**) ppo_store)[i] = (double*) ppo_dbl + i; + amask[i] = 0; + } + } + break; + case CPLXSXP: + ppo_store = R_alloc((size_t) len_values, sizeof(Rcomplex*)); + if (list_out) { + for (ssize_t i = 0; i < len_values; ++i) { + ((Rcomplex**) ppo_store)[i] = COMPLEX(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; + } + } else { + ppo_cplx = COMPLEX(outputs); + for (ssize_t i = 0; i < len_values; ++i) { + ((Rcomplex**) ppo_store)[i] = (Rcomplex*) ppo_cplx + i; + amask[i] = 0; + } + } + break; + case STRSXP: + ppo_store = R_alloc((size_t) len_values, sizeof(SEXP*)); + if (list_out) { + for (ssize_t i = 0; i < len_values; ++i) { + ((const SEXP**) ppo_store)[i] = STRING_PTR_RO(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; + } + } else { + ppo_str = STRING_PTR_RO(outputs); + for (ssize_t i = 0; i < len_values; ++i) { + ((const SEXP**) ppo_store)[i] = (const SEXP*) ppo_str + i; + amask[i] = 0; + } + } + break; + case VECSXP: + ppo_store = R_alloc((size_t) len_values, sizeof(SEXP*)); + if (list_out) { + for (ssize_t i = 0; i < len_values; ++i) { + ((const SEXP**) ppo_store)[i] = SEXPPTR_RO(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; + } + } else { + ppo_list = SEXPPTR_RO(outputs); + for (ssize_t i = 0; i < len_values; ++i) { + ((const SEXP**) ppo_store)[i] = (const SEXP*) ppo_list + i; + amask[i] = 0; + } + } + break; + default: + R_Free(slots); + error("Type %s is not supported for hashed switch output.", + type2char(type_ot)); + } + + const R_xlen_t nblocks = (len_x + KIT_SW_BLOCK - 1) / KIT_SW_BLOCK; + #define KIT_SW_MATCH_BLOCK() do { \ + switch (type_x) { \ + case LGLSXP: kit_sw_match_lgl(LOGICAL(sx), LOGICAL(sv), slots, mask, mb, off, blen); break; \ + case INTSXP: kit_sw_match_int(INTEGER(sx), INTEGER(sv), slots, mask, mb, off, blen); break; \ + case REALSXP: kit_sw_match_dbl(REAL(sx), REAL(sv), slots, mask, mb, off, blen); break; \ + case CPLXSXP: kit_sw_match_cplx(COMPLEX(sx), COMPLEX(sv), slots, mask, mb, off, blen); break; \ + case STRSXP: kit_sw_match_str(STRING_PTR_RO(sx), STRING_PTR_RO(sv), slots, mask, mb, off, blen); break; \ + } \ + } while (0) + + #define KIT_SW_WRITE_BLOCK() do { \ + switch (type_ot) { \ + case LGLSXP: kit_sw_write_lgl(ans, mb, off, blen, nonna ? LOGICAL(na) : NULL, namask, (int*const*) ppo_store, amask); break; \ + case INTSXP: kit_sw_write_int(ans, mb, off, blen, nonna ? INTEGER(na) : NULL, namask, (int*const*) ppo_store, amask); break; \ + case REALSXP: kit_sw_write_dbl(ans, mb, off, blen, nonna ? REAL(na) : NULL, namask, (double*const*) ppo_store, amask); break; \ + case CPLXSXP: kit_sw_write_cplx(ans, mb, off, blen, nonna ? COMPLEX(na) : NULL, namask, (Rcomplex*const*) ppo_store, amask); break; \ + case STRSXP: kit_sw_write_str(ans, mb, off, blen, nonna ? STRING_PTR_RO(na) : NULL, namask, (const SEXP*const*) ppo_store, amask); break; \ + case VECSXP: kit_sw_write_vec(ans, mb, off, blen, nonna ? SEXPPTR_RO(na) : NULL, namask, (const SEXP*const*) ppo_store, amask); break; \ + } \ + } while (0) + + if (serial_out) { + for (R_xlen_t b = 0; b < nblocks; ++b) { + const R_xlen_t off = b * KIT_SW_BLOCK; + const R_xlen_t blen = (len_x - off < KIT_SW_BLOCK) ? len_x - off : KIT_SW_BLOCK; + int *mb = match; + KIT_SW_MATCH_BLOCK(); + KIT_SW_WRITE_BLOCK(); + } + } else { + OMP_PARALLEL_FOR(nth_hash) + for (R_xlen_t b = 0; b < nblocks; ++b) { + const R_xlen_t off = b * KIT_SW_BLOCK; + const R_xlen_t blen = (len_x - off < KIT_SW_BLOCK) ? len_x - off : KIT_SW_BLOCK; + int *mb = match + (size_t) omp_get_thread_num() * KIT_SW_BLOCK; + KIT_SW_MATCH_BLOCK(); + KIT_SW_WRITE_BLOCK(); + } + } + #undef KIT_SW_MATCH_BLOCK + #undef KIT_SW_WRITE_BLOCK + R_Free(slots); +} diff --git a/src/vswitch.c b/src/vswitch.c index 304adeb..05276fd 100644 --- a/src/vswitch.c +++ b/src/vswitch.c @@ -182,6 +182,12 @@ SEXP vswitchR(SEXP x, SEXP values, SEXP outputs, SEXP na, SEXP nthreads, SEXP ch } ans = PROTECT(allocVector(type_outputs, len_x)); nprotect++; copyMostAttrib(po[0], ans); + if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && type_x != VECSXP) { + kit_switch_hash(ans, x, values, outputs, na, type_x, type_o, len_x, + len_values, len_na, nth, nonna, utfcon, xans, vans); + UNPROTECT(nprotect); + return ans; + } switch(type_outputs) { /* * This part is for LOGICAL @@ -347,6 +353,12 @@ SEXP vswitchR(SEXP x, SEXP values, SEXP outputs, SEXP na, SEXP nthreads, SEXP ch } ans = PROTECT(allocVector(type_o, len_x)); nprotect++; copyMostAttrib(outputs, ans); + if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && type_x != VECSXP) { + kit_switch_hash(ans, x, values, outputs, na, type_x, type_o, len_x, + len_values, len_na, nth, nonna, utfcon, xans, vans); + UNPROTECT(nprotect); + return ans; + } switch(type_o) { /* * This part is for LOGICAL From 97aecd16c16520f4e529a90dbf9588fe070b2a7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 21:47:56 +0100 Subject: [PATCH 3/9] perf(unique): faster row hashing and table pre-sizing (#107) Use a 64-bit rolling hash for duplicate-table rows instead of mixing every cell and mixing again, and reuse the shared kit_hash_rows_* helpers in the matrix/data-frame loops. A bounded row sample estimates cardinality: when the input is mostly unique the table is allocated at its final size, while low-cardinality inputs keep the small grow-on-demand table from #74. 10m x 2 integer data.frame: uniqLen 0.435s -> 0.177s, funique 0.450s -> 0.182s. 10m mixed int/double data.frame: uniqLen 0.828s -> 0.332s, funique 0.852s -> 0.378s. 2m frames improve 1.6-1.8x; vector paths are unchanged. --- inst/tinytest/test-unique.R | 23 ++++ src/dup.c | 203 +++++------------------------------- src/dupLen.c | 55 ++-------- src/kit.h | 118 +++++++++++++++++---- 4 files changed, 153 insertions(+), 246 deletions(-) diff --git a/inst/tinytest/test-unique.R b/inst/tinytest/test-unique.R index fa2aa0b..004ee2e 100644 --- a/inst/tinytest/test-unique.R +++ b/inst/tinytest/test-unique.R @@ -698,3 +698,26 @@ local({ expect_identical(uniqLen(df), nrow(unique(df)), info = "uniqLen-0074.grow-df") }) + +# issue #107: large high-cardinality inputs pre-size the row table while +# low-cardinality inputs keep the grow-on-demand path. Both must match base R. +local({ + n <- 2000L + hi <- data.frame(a = seq_len(n), b = seq_len(n) * 31L) + lo <- data.frame(a = rep(1:5, length.out = n), + b = rep(1:3, length.out = n)) + mix <- data.frame(a = seq_len(n), b = as.numeric(seq_len(n)) / 3) + for (df in list(hi, lo, mix)) { + a <- funique(df); b <- unique(df) + rownames(a) <- rownames(b) <- NULL + expect_identical(a, b, info = "funique-0107.presize-roundtrip") + expect_identical(uniqLen(df), nrow(b), info = "uniqLen-0107.presize") + expect_identical(fduplicated(df), duplicated(df), + info = "fduplicated-0107.presize") + } + m <- as.matrix(hi) + expect_identical(uniqLen(m), nrow(unique(m)), info = "uniqLen-0107.presize-mat") + a <- funique(m); b <- unique(m) + dimnames(a) <- dimnames(b) <- NULL + expect_identical(a, b, info = "funique-0107.presize-mat") +}) diff --git a/src/dup.c b/src/dup.c index 818cc28..7096ec6 100644 --- a/src/dup.c +++ b/src/dup.c @@ -85,6 +85,7 @@ SEXP dupDataFrameR(SEXP x, SEXP uniq, SEXP fromLast) { // move to matrix if poss Mbase *= 2; Kbase++; } + kit_rows_presize(mlv, len_i, len_x, &M, &K, Mbase, Kbase); R_xlen_t count = 0; int *restrict h = (int*) R_Calloc(M, int); const int *restrict v = INTEGER(mlv); @@ -95,11 +96,7 @@ SEXP dupDataFrameR(SEXP x, SEXP uniq, SEXP fromLast) { // move to matrix if poss if (buniq) { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(v[i+j*len_i],K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int_raw(v, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (v[h[id]-1+j*len_i] != v[i+j*len_i]) { @@ -118,11 +115,7 @@ SEXP dupDataFrameR(SEXP x, SEXP uniq, SEXP fromLast) { // move to matrix if poss } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(v[i+j*len_i],K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int_raw(v, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (v[h[id]-1+j*len_i] != v[i+j*len_i]) { @@ -157,11 +150,7 @@ SEXP dupDataFrameR(SEXP x, SEXP uniq, SEXP fromLast) { // move to matrix if poss } if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(v[i+j*len_i],K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int_raw(v, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (v[h[id]-1+j*len_i] != v[i+j*len_i]) { @@ -181,11 +170,7 @@ SEXP dupDataFrameR(SEXP x, SEXP uniq, SEXP fromLast) { // move to matrix if poss } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(v[i+j*len_i],K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int_raw(v, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (v[h[id]-1+j*len_i] != v[i+j*len_i]) { @@ -231,6 +216,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { Mbase *= 2; Kbase++; } + kit_rows_presize(x, len_i, len_x, &M, &K, Mbase, Kbase); R_xlen_t count = 0; int *restrict h = (int*) R_Calloc(M, int); int *restrict pans = buniq ? (int*) R_Calloc(len_i, int) : LOGICAL(ans); @@ -245,11 +231,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { if (buniq) { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - id = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - id ^= ((unsigned)(j+1) * ((px[i+j*len_i] == NA_LOGICAL) ? 2U : (size_t) px[i+j*len_i]))*97*(j+1); - } - id = HASH(id, K); + id = kit_hash_rows_lgl(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -268,11 +250,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - id = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - id ^= ((unsigned)(j+1) * ((px[i+j*len_i] == NA_LOGICAL) ? 2U : (size_t) px[i+j*len_i]))*97*(j+1); - } - id = HASH(id, K); + id = kit_hash_rows_lgl(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -293,11 +271,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } else { if (pfromLast) { for (R_xlen_t i = len_i-1; i >-1; --i) { - id = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - id ^= ((unsigned)(j+1) * ((px[i+j*len_i] == NA_LOGICAL) ? 2U : (size_t) px[i+j*len_i]))*97*(j+1); - } - id = HASH(id, K); + id = kit_hash_rows_lgl(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -317,11 +291,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - id = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - id ^= ((unsigned)(j+1) * ((px[i+j*len_i] == NA_LOGICAL) ? 2U : (size_t) px[i+j*len_i]))*97*(j+1); - } - id = HASH(id, K); + id = kit_hash_rows_lgl(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -349,11 +319,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { if (buniq) { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -372,11 +338,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -397,11 +359,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } else { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -421,11 +379,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -450,17 +404,10 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { const double *restrict px = REAL(x); rowctx.px = px; grow = kit_grow_rows_real; - union uno tpv; if (buniq) { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tpv.d = px[i+j*len_i]; - key ^= HASH(tpv.u[0] + tpv.u[1],K)*97*(j+1); - } - tpv.d = key; - id = HASH(tpv.u[0] + tpv.u[1], K); + id = kit_hash_rows_real(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!REQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -479,13 +426,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tpv.d = px[i+j*len_i]; - key ^= HASH(tpv.u[0] + tpv.u[1],K)*97*(j+1); - } - tpv.d = key; - id = HASH(tpv.u[0] + tpv.u[1], K); + id = kit_hash_rows_real(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!REQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -506,13 +447,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } else { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tpv.d = px[i+j*len_i]; - key ^= HASH(tpv.u[0] + tpv.u[1],K)*97*(j+1); - } - tpv.d = key; - id = HASH(tpv.u[0] + tpv.u[1], K); + id = kit_hash_rows_real(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!REQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -532,13 +467,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tpv.d = px[i+j*len_i]; - key ^= HASH(tpv.u[0] + tpv.u[1],K)*97*(j+1); - } - tpv.d = key; - id = HASH(tpv.u[0] + tpv.u[1], K); + id = kit_hash_rows_real(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!REQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -563,28 +492,10 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { const Rcomplex *restrict px = COMPLEX(x); rowctx.px = px; grow = kit_grow_rows_cplx; - unsigned int u; - union uno tpv; - Rcomplex tmp; if (buniq) { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tmp.r = (px[i+j*len_i].r == 0.0) ? 0.0 : px[i+j*len_i].r; - tmp.i = (px[i+j*len_i].i == 0.0) ? 0.0 : px[i+j*len_i].i; - if (C_IsNA(tmp)) { - tmp.r = tmp.i = NA_REAL; - } else if (C_IsNaN(tmp)) { - tmp.r = tmp.i = R_NaN; - } - tpv.d = tmp.r; - u = tpv.u[0] ^ tpv.u[1]; - tpv.d = tmp.i; - u ^= tpv.u[0] ^ tpv.u[1]; - key ^= HASH(u, K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_cplx(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!CEQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -603,22 +514,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tmp.r = (px[i+j*len_i].r == 0.0) ? 0.0 : px[i+j*len_i].r; - tmp.i = (px[i+j*len_i].i == 0.0) ? 0.0 : px[i+j*len_i].i; - if (C_IsNA(tmp)) { - tmp.r = tmp.i = NA_REAL; - } else if (C_IsNaN(tmp)) { - tmp.r = tmp.i = R_NaN; - } - tpv.d = tmp.r; - u = tpv.u[0] ^ tpv.u[1]; - tpv.d = tmp.i; - u ^= tpv.u[0] ^ tpv.u[1]; - key ^= HASH(u, K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_cplx(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!CEQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -639,22 +535,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } else { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tmp.r = (px[i+j*len_i].r == 0.0) ? 0.0 : px[i+j*len_i].r; - tmp.i = (px[i+j*len_i].i == 0.0) ? 0.0 : px[i+j*len_i].i; - if (C_IsNA(tmp)) { - tmp.r = tmp.i = NA_REAL; - } else if (C_IsNaN(tmp)) { - tmp.r = tmp.i = R_NaN; - } - tpv.d = tmp.r; - u = tpv.u[0] ^ tpv.u[1]; - tpv.d = tmp.i; - u ^= tpv.u[0] ^ tpv.u[1]; - key ^= HASH(u, K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_cplx(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!CEQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -674,22 +555,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tmp.r = (px[i+j*len_i].r == 0.0) ? 0.0 : px[i+j*len_i].r; - tmp.i = (px[i+j*len_i].i == 0.0) ? 0.0 : px[i+j*len_i].i; - if (C_IsNA(tmp)) { - tmp.r = tmp.i = NA_REAL; - } else if (C_IsNaN(tmp)) { - tmp.r = tmp.i = R_NaN; - } - tpv.d = tmp.r; - u = tpv.u[0] ^ tpv.u[1]; - tpv.d = tmp.i; - u ^= tpv.u[0] ^ tpv.u[1]; - key ^= HASH(u, K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_cplx(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!CEQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -717,11 +583,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { if (buniq) { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((intptr_t) px[i+j*len_i] & 0xffffffff),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_str(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -740,11 +602,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((intptr_t) px[i+j*len_i] & 0xffffffff),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_str(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -765,11 +623,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } else { if (pfromLast) { for (R_xlen_t i = len_i-1; i > -1; --i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((intptr_t) px[i+j*len_i] & 0xffffffff),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_str(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -789,11 +643,7 @@ SEXP dupMatrixR(SEXP x, SEXP uniq, bool idx, SEXP fromLast) { } } else { for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((intptr_t) px[i+j*len_i] & 0xffffffff),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_str(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -1442,6 +1292,7 @@ SEXP dupVecIndexOnlyR(SEXP x) { } else { error("Type %s is not supported.", type2char(tx)); // # nocov } + kit_rows_presize(x, n, 1, &M, &K, Mbase, Kbase); size_t count = 0; int *restrict h = (int*)R_Calloc(M, int); SEXP ans_i = PROTECT(allocVector(INTSXP, n)); diff --git a/src/dupLen.c b/src/dupLen.c index c64ef26..ba59e82 100644 --- a/src/dupLen.c +++ b/src/dupLen.c @@ -79,6 +79,7 @@ SEXP dupLenDataFrameR(SEXP x) { Mbase *= 2; Kbase++; } + kit_rows_presize(mlv, len_i, len_x, &M, &K, Mbase, Kbase); R_xlen_t count = 0; int *restrict h = (int*) R_Calloc(M, int); const int *restrict v = INTEGER(mlv); @@ -86,11 +87,7 @@ SEXP dupLenDataFrameR(SEXP x) { kit_row_ctx rowctx = {v, len_i, len_x}; size_t id = 0; for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(v[i+j*len_i],K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int_raw(v, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (v[h[id]-1+j*len_i] != v[i+j*len_i]) { @@ -127,6 +124,7 @@ SEXP dupLenMatrixR(SEXP x) { Mbase *= 2; Kbase++; } + kit_rows_presize(x, len_i, len_x, &M, &K, Mbase, Kbase); R_xlen_t count = 0; int *restrict h = (int*) R_Calloc(M, int); size_t id = 0; @@ -138,11 +136,7 @@ SEXP dupLenMatrixR(SEXP x) { rowctx.px = px; grow = kit_grow_rows_lgl; for (R_xlen_t i = 0; i < len_i; ++i) { - id = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - id ^= ((unsigned)(j+1) * ((px[i+j*len_i] == NA_LOGICAL) ? 2U : (size_t) px[i+j*len_i]))*97*(j+1); - } - id = HASH(id, K); + id = kit_hash_rows_lgl(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -164,11 +158,7 @@ SEXP dupLenMatrixR(SEXP x) { rowctx.px = px; grow = kit_grow_rows_int; for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { @@ -189,15 +179,8 @@ SEXP dupLenMatrixR(SEXP x) { const double *restrict px = REAL(x); rowctx.px = px; grow = kit_grow_rows_real; - union uno tpv; for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tpv.d = px[i+j*len_i]; - key ^= HASH(tpv.u[0] + tpv.u[1],K)*97*(j+1); - } - tpv.d = key; - id = HASH(tpv.u[0] + tpv.u[1], K); + id = kit_hash_rows_real(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!REQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -218,26 +201,8 @@ SEXP dupLenMatrixR(SEXP x) { const Rcomplex *restrict px = COMPLEX(x); rowctx.px = px; grow = kit_grow_rows_cplx; - unsigned int u; - union uno tpv; - Rcomplex tmp; for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - tmp.r = (px[i+j*len_i].r == 0.0) ? 0.0 : px[i+j*len_i].r; - tmp.i = (px[i+j*len_i].i == 0.0) ? 0.0 : px[i+j*len_i].i; - if (C_IsNA(tmp)) { - tmp.r = tmp.i = NA_REAL; - } else if (C_IsNaN(tmp)) { - tmp.r = tmp.i = R_NaN; - } - tpv.d = tmp.r; - u = tpv.u[0] ^ tpv.u[1]; - tpv.d = tmp.i; - u ^= tpv.u[0] ^ tpv.u[1]; - key ^= HASH(u, K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_cplx(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (!CEQUAL(px[h[id]-1+j*len_i], px[i+j*len_i])) { @@ -259,11 +224,7 @@ SEXP dupLenMatrixR(SEXP x) { rowctx.px = px; grow = kit_grow_rows_str; for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((intptr_t) px[i+j*len_i] & 0xffffffff),K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_str(px, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (px[h[id]-1+j*len_i] != px[i+j*len_i]) { diff --git a/src/kit.h b/src/kit.h index 6eb26bf..5d853af 100644 --- a/src/kit.h +++ b/src/kit.h @@ -62,6 +62,14 @@ static inline size_t kit_hash_key(uint32_t key, int K) { key *= 0x9E3779B1U; return (size_t)(key >> (32 - K)); } +static inline size_t kit_hash_u64(uint64_t key, int K) { + // finaliser for the 64-bit rolling row hashes + key ^= key >> 33; + key *= 0xff51afd7ed558ccdULL; + key ^= key >> 29; + return (size_t)(key >> (64 - K)); +} +#define KIT_MIX64 0x9E3779B97F4A7C15ULL #define HASH(key, K) kit_hash_key((uint32_t)(key), (K)) #define N_ISNAN(x, y) (!ISNAN(x) && !ISNAN(y)) #define B_IsNA(x, y) (R_IsNA(x) && R_IsNA(y)) @@ -73,7 +81,7 @@ static inline size_t kit_hash_key(uint32_t key, int K) { #define REQUAL(x, y) (N_ISNAN(x, y) ? (x == y) : (B_IsNA(x, y) || B_IsNaN(x, y))) #define CEQUAL(x, y) ((N_ISNAN(x.r, x.i) && N_ISNAN(y.r, y.i)) ? (x.r == y.r && x.i == y.i) : (C_IsNA(x) ? C_IsNA(y) : (C_IsNA(y) ? 0 : (C_ISNAN(x.r, y.r) && C_ISNAN(x.i, y.i))))) -union uno { double d; unsigned int u[2]; }; +union uno { double d; unsigned int u[2]; uint64_t u64; }; /* * Growable duplicate tables. Each table stores 1-based input indices in an @@ -92,51 +100,51 @@ typedef int *(*kit_row_grow_fn)(const kit_row_ctx *ctx, int *h, size_t M, size_t static inline size_t kit_hash_rows_lgl(const int *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { - size_t id = 0; + uint64_t key = 0; for (R_xlen_t j = 0; j < len_x; ++j) { - id ^= ((unsigned)(j+1) * ((px[i+j*len_i] == NA_LOGICAL) ? 2U : (size_t) px[i+j*len_i]))*97*(j+1); + key = key * KIT_MIX64 + + (uint64_t)((px[i+j*len_i] == NA_LOGICAL) ? 2U : (unsigned) px[i+j*len_i]); } - return HASH(id, K); + return kit_hash_u64(key, K); } static inline size_t kit_hash_rows_int(const int *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { - R_xlen_t key = 0; + uint64_t key = 0; for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]), K)*97*(j+1); + key = key * KIT_MIX64 + + (uint64_t)(uint32_t)((px[i+j*len_i] == NA_INTEGER) ? 0 : px[i+j*len_i]); } - return HASH(key, K); + return kit_hash_u64(key, K); } static inline size_t kit_hash_rows_int_raw(const int *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { - R_xlen_t key = 0; + uint64_t key = 0; for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(px[i+j*len_i], K)*97*(j+1); + key = key * KIT_MIX64 + (uint64_t)(uint32_t) px[i+j*len_i]; } - return HASH(key, K); + return kit_hash_u64(key, K); } static inline size_t kit_hash_rows_real(const double *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { - R_xlen_t key = 0; + uint64_t key = 0; union uno tpv; for (R_xlen_t j = 0; j < len_x; ++j) { tpv.d = px[i+j*len_i]; - key ^= HASH(tpv.u[0] + tpv.u[1], K)*97*(j+1); + key = key * KIT_MIX64 + tpv.u64; } - tpv.d = key; - return HASH(tpv.u[0] + tpv.u[1], K); + return kit_hash_u64(key, K); } static inline size_t kit_hash_rows_cplx(const Rcomplex *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { - R_xlen_t key = 0; - unsigned int u; + uint64_t key = 0; union uno tpv; Rcomplex tmp; for (R_xlen_t j = 0; j < len_x; ++j) { @@ -148,22 +156,21 @@ static inline size_t kit_hash_rows_cplx(const Rcomplex *px, const R_xlen_t i, tmp.r = tmp.i = R_NaN; } tpv.d = tmp.r; - u = tpv.u[0] ^ tpv.u[1]; + key = key * KIT_MIX64 + tpv.u64; tpv.d = tmp.i; - u ^= tpv.u[0] ^ tpv.u[1]; - key ^= HASH(u, K)*97*(j+1); + key = key * KIT_MIX64 + tpv.u64; } - return HASH(key, K); + return kit_hash_u64(key, K); } static inline size_t kit_hash_rows_str(const SEXP *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { - R_xlen_t key = 0; + uint64_t key = 0; for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(((intptr_t) px[i+j*len_i] & 0xffffffff), K)*97*(j+1); + key = key * KIT_MIX64 + (uint64_t)(uintptr_t) px[i+j*len_i]; } - return HASH(key, K); + return kit_hash_u64(key, K); } #define KIT_DEFINE_ROW_GROW(name, type, hashfn) \ @@ -192,6 +199,71 @@ KIT_DEFINE_ROW_GROW(real, double, kit_hash_rows_real) KIT_DEFINE_ROW_GROW(cplx, Rcomplex, kit_hash_rows_cplx) KIT_DEFINE_ROW_GROW(str, SEXP, kit_hash_rows_str) +/* + * Estimate whether an input is high-cardinality from a bounded row sample. + * High-cardinality inputs pre-size the duplicate table to its final capacity, + * avoiding several full rehashes while low-cardinality inputs keep the small + * grow-on-demand table (#74). + */ +#define KIT_DEFINE_ROW_SAMPLE(name, type, hashfn) \ +static inline bool kit_likely_high_card_##name(const type *px, \ + const R_xlen_t len_i, \ + const R_xlen_t len_x) { \ + const R_xlen_t sample = len_i < 65536 ? len_i : 65536; \ + if (sample < 64) return false; \ + size_t cap = 256; \ + while (cap < (size_t) sample * 2) cap <<= 1; \ + uint32_t *keys = (uint32_t*) R_Calloc(cap, uint32_t); \ + size_t distinct = 0; \ + for (R_xlen_t s = 0; s < sample; ++s) { \ + const R_xlen_t i = (R_xlen_t)((uint64_t) s * (uint64_t) len_i / (uint64_t) sample); \ + uint32_t key = (uint32_t) hashfn(px, i, len_i, len_x, 32); \ + if (!key) key = 1; \ + size_t id = (size_t) key & (cap - 1); \ + while (keys[id] && keys[id] != key) id = (id + 1) & (cap - 1); \ + if (!keys[id]) { keys[id] = key; distinct++; } \ + } \ + R_Free(keys); \ + const size_t dup = (size_t) sample - distinct; \ + if (!dup) return true; /* a full sample with no repeat means U >> n/2 */ \ + const double uhat = (double) sample * (double) (sample - 1) / \ + (2.0 * (double) dup); \ + return uhat > (double) len_i * 0.5; \ +} + +KIT_DEFINE_ROW_SAMPLE(lgl, int, kit_hash_rows_lgl) +KIT_DEFINE_ROW_SAMPLE(int, int, kit_hash_rows_int) +KIT_DEFINE_ROW_SAMPLE(int_raw, int, kit_hash_rows_int_raw) +KIT_DEFINE_ROW_SAMPLE(real, double, kit_hash_rows_real) +KIT_DEFINE_ROW_SAMPLE(cplx, Rcomplex, kit_hash_rows_cplx) +KIT_DEFINE_ROW_SAMPLE(str, SEXP, kit_hash_rows_str) + +static inline void kit_rows_presize(SEXP x, const R_xlen_t len_i, + const R_xlen_t len_x, size_t *M, int *K, + const size_t Mbase, const int Kbase) { + bool high = false; + switch (UTYPEOF(x)) { + case LGLSXP: + high = kit_likely_high_card_lgl(LOGICAL(x), len_i, len_x); + break; + case INTSXP: + high = kit_likely_high_card_int(INTEGER(x), len_i, len_x); + break; + case REALSXP: + high = kit_likely_high_card_real(REAL(x), len_i, len_x); + break; + case CPLXSXP: + high = kit_likely_high_card_cplx(COMPLEX(x), len_i, len_x); + break; + case STRSXP: + high = kit_likely_high_card_str(STRING_PTR_RO(x), len_i, len_x); + break; + default: + return; + } + if (high) { *M = Mbase; *K = Kbase; } +} + #define KIT_GROW_ROWS() do { if ((size_t) count > M - (M >> 2)) { \ size_t Mnew = M << 2; int Knew = K + 2; \ if (Mnew > Mbase) { Mnew = Mbase; Knew = Kbase; } \ From f424e5157dfd9094a1c77e1b3d80306cf1be93a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 21:53:54 +0100 Subject: [PATCH 4/9] perf(bench): add core benchmark harness (#107) Manual-only benchmark covering 2m/10m elements, 5/20/100 switch values, integer/string/factor/NA inputs, data-frame funique/uniqLen, and 1/2/4 threads. data.table reference cases are optional and skipped when the package is unavailable. No timing assertions are added to CI. --- tools/benchmark-core.R | 124 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) create mode 100644 tools/benchmark-core.R diff --git a/tools/benchmark-core.R b/tools/benchmark-core.R new file mode 100644 index 0000000..deabe07 --- /dev/null +++ b/tools/benchmark-core.R @@ -0,0 +1,124 @@ +# Manual benchmark for the issue #107 hot paths. Not part of the test suite. +# +# Usage: Rscript tools/benchmark-core.R [library] [label] [reps] +# library optional library path to load kit from (e.g. a baseline install) +# label free-form label printed in every row (default "current") +# reps timed repetitions per case (default 5) +# +# Covers 2m/10m elements, 5/20/100 switch values, integer/string/factor/NA +# inputs, data-frame funique/uniqLen, and 1/2/4 threads on the 100-value cases. +# data.table is optional; its reference cases are skipped when unavailable. + +args <- commandArgs(trailingOnly = TRUE) +if (length(args) > 3L) stop("Usage: Rscript tools/benchmark-core.R [library] [label] [reps]") +if (length(args) >= 1L && nzchar(args[[1]])) .libPaths(c(args[[1]], .libPaths())) +label <- if (length(args) >= 2L) args[[2]] else "current" +reps <- if (length(args) >= 3L) as.integer(args[[3]]) else 5L +library(kit) +has_dt <- requireNamespace("data.table", quietly = TRUE) + +bench <- function(f) { + invisible(f()) + times <- numeric(reps) + for (i in seq_len(reps)) { + invisible(gc(FALSE)) + times[[i]] <- system.time(f())[["elapsed"]] + } + median(times) +} + +row <- function(case, n, m = NA_integer_, threads = 1L, f) { + cat(sprintf("%s\t%s\t%s\t%d\t%d\t%d\t%.6f\n", + label, case, R.version$platform, n, m, threads, bench(f))) +} + +set.seed(107) +n10 <- 10000000L +base_int <- sample.int(1000L, n10, TRUE) +base_str <- paste0("v", base_int) +base_na <- base_str +base_na[sample.int(n10, n10 %/% 20L)] <- NA_character_ +base_fac <- factor(base_str, levels = paste0("v", 1:1000)) +vals_int <- sample.int(1000L, 100L) +vals_str <- paste0("v", vals_int) +vals_na <- vals_str; vals_na[100L] <- NA_character_ +vals_fac <- factor(vals_str, levels = levels(base_fac)) + +cat(sprintf("# R\t%s\tplatform\t%s\tpackage\t%s\tlabel\t%s\treps\t%d\n", + R.version.string, R.version$platform, + as.character(packageVersion("kit")), label, reps)) + +for (n in c(2000000L, n10)) { + xi <- base_int[seq_len(n)] + xs <- base_str[seq_len(n)] + xn <- base_na[seq_len(n)] + xf <- base_fac[seq_len(n)] + for (m in c(5L, 20L, 100L)) { + out <- seq_len(m) + vi <- vals_int[seq_len(m)] + vs <- vals_str[seq_len(m)] + vn <- vals_na[seq_len(m)] + vf <- vals_fac[seq_len(m)] + stopifnot(length(vswitch(xi, vi, out)) == n, + length(vswitch(xs, vs, out)) == n, + length(vswitch(xn, vn, out)) == n, + length(vswitch(xf, vf, out)) == n) + row("vswitch_int", n, m, f = function() vswitch(xi, vi, out)) + row("vswitch_str", n, m, f = function() vswitch(xs, vs, out)) + row("vswitch_na", n, m, f = function() vswitch(xn, vn, out)) + row("vswitch_factor", n, m, f = function() vswitch(xf, vf, out)) + pairs_i <- unlist(lapply(seq_len(m), function(i) list(vi[i], i)), recursive = FALSE) + pairs_s <- unlist(lapply(seq_len(m), function(i) list(vs[i], i)), recursive = FALSE) + row("nswitch_int", n, m, f = function() { + do.call(nswitch, c(list(xi), pairs_i, list(default = 0L))) + }) + row("nswitch_str", n, m, f = function() { + do.call(nswitch, c(list(xs), pairs_s, list(default = 0L))) + }) + if (has_dt && m == 100L) { + row("ref_chmatch_str", n, m, f = function() data.table::chmatch(xs, vs)) + } + } +} + +for (n in c(2000000L, n10)) { + set.seed(107) + xi <- sample.int(100000L, n, TRUE) + xs <- sprintf("id%06d", sample.int(100000L, n, TRUE)) + xseq <- rep(seq_len(100000L), length.out = n) + df_int <- data.frame(a = xi, b = sample.int(1000L, n, TRUE)) + df_mix <- data.frame(a = xi, b = rnorm(n)) + row("funique_int", n, f = function() funique(xi)) + row("funique_seq", n, f = function() funique(xseq)) + row("funique_str", n, f = function() funique(xs)) + row("uniqLen_int", n, f = function() uniqLen(xi)) + row("uniqLen_df_int", n, f = function() uniqLen(df_int)) + row("funique_df_int", n, f = function() funique(df_int)) + row("uniqLen_df_mixed", n, f = function() uniqLen(df_mix)) + row("funique_df_mixed", n, f = function() funique(df_mix)) + if (has_dt) { + row("ref_uniqueN_int", n, f = function() data.table::uniqueN(xi)) + row("ref_uniqueN_df_int", n, f = function() data.table::uniqueN(df_int)) + row("ref_uniqueN_df_mixed", n, f = function() data.table::uniqueN(df_mix)) + } +} + +# Thread scaling on the 100-value cases. +for (n in c(2000000L, n10)) { + xi <- base_int[seq_len(n)] + xs <- base_str[seq_len(n)] + pairs_i <- unlist(lapply(1:100, function(i) list(vals_int[i], i)), recursive = FALSE) + pairs_s <- unlist(lapply(1:100, function(i) list(vals_str[i], i)), recursive = FALSE) + for (th in c(1L, 2L, 4L)) { + row("vswitch_int_100t", n, 100L, th, + function() vswitch(xi, vals_int, 1:100, nThread = th)) + row("vswitch_str_100t", n, 100L, th, + function() vswitch(xs, vals_str, 1:100, nThread = th)) + row("nswitch_int_100t", n, 100L, th, function() { + do.call(nswitch, c(list(xi), pairs_i, list(default = 0L, nThread = th))) + }) + row("nswitch_str_100t", n, 100L, th, function() { + do.call(nswitch, c(list(xs), pairs_s, list(default = 0L, nThread = th))) + }) + } +} From 067b0e6e92dad2516e495f6e8a026d5951ae29fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 21:53:54 +0100 Subject: [PATCH 5/9] docs(news): prepare 0.0.24 performance notes (#107) Record the measured vswitch/nswitch and data-frame unique improvements and cover the remaining hash-path output and input types in tests. --- DESCRIPTION | 2 +- NEWS.md | 10 ++++++ inst/tinytest/test-switch-hash.R | 57 ++++++++++++++++++++++++++++++++ src/kit.h | 1 + src/switch_hash.c | 29 ++++++---------- 5 files changed, 79 insertions(+), 20 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 512d567..0e4ac5e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: kit Type: Package Title: Data Manipulation Functions Implemented in C -Version: 0.0.23 +Version: 0.0.24 Authors@R: c(person("Morgan", "Jacob", role = c("aut", "cph"), email = "morgan.emailbox@gmail.com"), person("Sebastian", "Krantz", role = c("ctb", "cre"), email = "sebastian.krantz@graduateinstitute.ch"), person("David", "Budzynski", role = c("ctb"), email = "david.budzynsky@gmail.com")) diff --git a/NEWS.md b/NEWS.md index a043d2b..adeac4b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,13 @@ +# kit 0.0.24 (development version) + +### Notes + +- Speed up `vswitch()` and `nswitch()` when there are many value/output pairs. For more than 8 pairs the implementation builds a value-to-last-pair hash map once and scans `x` in cache-sized blocks instead of comparing `x` against every value. Matching semantics are unchanged: integer/logical `NA` still matches `NA`, doubles/complex canonicalise `-0` and never match `NA`/`NaN`, strings compare `CHARSXP` identity, duplicate values keep the last pair, and threaded results stay deterministic. On 2m elements, 20 values are about 2x faster and 100 values 4-5x faster; the value-major path is kept for 8 or fewer pairs. + +- Speed up `funique()`/`fduplicated()`/`uniqLen()` on data frames and matrices. Row hashes now use a 64-bit rolling mix instead of mixing every cell and mixing again, and a bounded sample estimates cardinality so high-cardinality inputs allocate the final table once while low-cardinality inputs keep the small grow-on-demand table. On 10m rows, 2-column integer data frames improve about 2.4x and mixed integer/double frames about 2.3x. + +- Add `tools/benchmark-core.R`, a manual benchmark covering 2m/10m elements, 5/20/100 switch values, integer/string/factor/NA inputs, data frames, and 1/2/4 threads. It is not run in CI. + # kit 0.0.23 (2026-11-02) ### Bug Fixes diff --git a/inst/tinytest/test-switch-hash.R b/inst/tinytest/test-switch-hash.R index 93c4f65..e72c6e1 100644 --- a/inst/tinytest/test-switch-hash.R +++ b/inst/tinytest/test-switch-hash.R @@ -135,3 +135,60 @@ expect_identical(ns_v(x_i), exp_vec, info = "hash-nswitch-vector-output") xl <- as.list(x_i) expect_identical(vswitch(xl, as.list(vals_i), outs_i), exp_i, info = "hash-vswitch-list-input") + +# Every output type goes through its own writer on the hash path. +exp_lgl <- ref_na(x_i, vals_i, as.list(as.logical(outs_i %% 2))) +expect_identical(vswitch(x_i, vals_i, as.logical(outs_i %% 2)), exp_lgl, + info = "hash-vswitch-out-lgl") +exp_dbl <- ref_na(x_i, vals_i, as.list(as.double(outs_i))) +expect_identical(vswitch(x_i, vals_i, as.double(outs_i)), exp_dbl, + info = "hash-vswitch-out-dbl") +exp_chr <- ref_na(x_i, vals_i, as.list(as.character(outs_i))) +expect_identical(vswitch(x_i, vals_i, as.character(outs_i)), exp_chr, + info = "hash-vswitch-out-str") +expect_identical(vswitch(x_s, vals_s, as.character(outs_s)), + ref_na(x_s, vals_s, as.list(as.character(outs_s))), + info = "hash-vswitch-str-out-str") +exp_cplx <- ref_num(x_c, vals_c, as.list(as.complex(outs_c))) +expect_kit_equal(vswitch(x_c, vals_c, as.complex(outs_c)), exp_cplx, + info = "hash-vswitch-out-cplx") +exp_dbl_d <- ref_num(x_d, vals_d, as.list(as.double(outs_d))) +expect_identical(vswitch(x_d, vals_d, as.double(outs_d)), exp_dbl_d, + info = "hash-vswitch-dbl-out-dbl") +out_nested <- lapply(outs_i, function(v) list(v)) +idx_nested <- ref_na(x_i, vals_i, as.list(seq_along(vals_i)), default = NA_integer_) +exp_nested <- lapply(idx_nested, function(k) if (is.na(k)) NULL else out_nested[[k]][[1]]) +expect_identical(vswitch(x_i, vals_i, out_nested), exp_nested, + info = "hash-vswitch-out-list") + +# Unsupported input types keep the value-major error message, even when there +# are enough pairs to select the hash path. +expect_error(vswitch(as.raw(rep(0, 9L)), as.raw(rep(0, 9L)), 1:9), + pattern = "Type raw is not supported for argument 'x'.", + fixed = TRUE, info = "hash-vswitch-raw") + +# List outputs use the same writers in list-out mode. +expect_identical(vswitch(x_i, vals_i, as.list(as.logical(outs_i %% 2))), + ref_na(x_i, vals_i, as.list(as.logical(outs_i %% 2))), + info = "hash-vswitch-list-out-lgl") +expect_identical(vswitch(x_i, vals_i, as.list(as.character(outs_i))), + ref_na(x_i, vals_i, as.list(as.character(outs_i))), + info = "hash-vswitch-list-out-str") +expect_kit_equal(vswitch(x_c, vals_c, as.list(as.complex(outs_c))), + ref_num(x_c, vals_c, as.list(as.complex(outs_c))), + info = "hash-vswitch-list-out-cplx") + +# nswitch copies each scalar value before hashing; cover every atomic type. +expect_identical( + nswitch(c(TRUE, FALSE, NA), TRUE, 1L, FALSE, 2L, NA, 3L, TRUE, 4L, + FALSE, 5L, NA, 6L, TRUE, 7L, FALSE, 8L, NA, 9L, default = 0L), + c(7L, 8L, 9L), info = "hash-nswitch-lgl") +expect_identical( + nswitch(c(1, 9, NA, NaN, 0), 1, 1L, 2, 2L, 3, 3L, 4, 4L, 5, 5L, + 6, 6L, 7, 7L, 8, 8L, 9, 9L, default = 0L), + c(1L, 9L, 0L, 0L, 0L), info = "hash-nswitch-dbl") +expect_identical( + nswitch(c(1+0i, 9+0i, NA_complex_, 0+0i), + 1+0i, 1L, 2+0i, 2L, 3+0i, 3L, 4+0i, 4L, 5+0i, 5L, + 6+0i, 6L, 7+0i, 7L, 8+0i, 8L, 9+0i, 9L, default = 0L), + c(1L, 9L, 0L, 0L), info = "hash-nswitch-cplx") diff --git a/src/kit.h b/src/kit.h index 5d853af..5c808d0 100644 --- a/src/kit.h +++ b/src/kit.h @@ -48,6 +48,7 @@ #define UTYPEOF(x) ((unsigned)TYPEOF(x)) #define IS_BOOL(x) (XLENGTH(x)==1 && TYPEOF(x)==LGLSXP && LOGICAL(x)[0]!=NA_LOGICAL) #define IS_VALID_TYPE(x) ((x) == LGLSXP || (x)==INTSXP || (x)==REALSXP || (x)==CPLXSXP || (x)==STRSXP || (x)==VECSXP) +#define IS_SWITCH_HASH_TYPE(x) ((x) == LGLSXP || (x)==INTSXP || (x)==REALSXP || (x)==CPLXSXP || (x)==STRSXP) #define PTR_ETL(x, y) (((const SEXP *)DATAPTR_RO(x))[y]) #define SEXPPTR_RO(x) ((const SEXP *)DATAPTR_RO(x)) #define ISNA_COMPLEX(x) (ISNA(x.r) || ISNA(x.i)) diff --git a/src/switch_hash.c b/src/switch_hash.c index 228872f..2895aa1 100644 --- a/src/switch_hash.c +++ b/src/switch_hash.c @@ -247,9 +247,9 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, case STRSXP: kit_sw_build_str(STRING_PTR_RO(sv), len_values, slots, mask); break; - default: - R_Free(slots); - error("Type %s is not supported for hashed switch.", type2char(type_x)); + default: // # nocov + R_Free(slots); // # nocov + error("Type %s is not supported for hashed switch.", type2char(type_x)); // # nocov } /* Output pointers: a list of per-pair outputs, or a vector of pair results. */ @@ -260,7 +260,6 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, const double *ppo_dbl = NULL; const Rcomplex *ppo_cplx = NULL; const SEXP *ppo_str = NULL; - const SEXP *ppo_list = NULL; switch (type_ot) { case LGLSXP: ppo_store = R_alloc((size_t) len_values, sizeof(int*)); @@ -339,23 +338,15 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, break; case VECSXP: ppo_store = R_alloc((size_t) len_values, sizeof(SEXP*)); - if (list_out) { - for (ssize_t i = 0; i < len_values; ++i) { - ((const SEXP**) ppo_store)[i] = SEXPPTR_RO(po[i]); - amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; - } - } else { - ppo_list = SEXPPTR_RO(outputs); - for (ssize_t i = 0; i < len_values; ++i) { - ((const SEXP**) ppo_store)[i] = (const SEXP*) ppo_list + i; - amask[i] = 0; - } + for (ssize_t i = 0; i < len_values; ++i) { + ((const SEXP**) ppo_store)[i] = SEXPPTR_RO(po[i]); + amask[i] = xlength(po[i]) > 1 ? SSIZE_MAX : 0; } break; - default: - R_Free(slots); - error("Type %s is not supported for hashed switch output.", - type2char(type_ot)); + default: // # nocov + R_Free(slots); // # nocov + error("Type %s is not supported for hashed switch output.", // # nocov + type2char(type_ot)); // # nocov } const R_xlen_t nblocks = (len_x + KIT_SW_BLOCK - 1) / KIT_SW_BLOCK; From 653c80b7dcc4731e1dbd9c7958924958d00644c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 21:54:29 +0100 Subject: [PATCH 6/9] fix(switch): keep value-major errors for unsupported input types (#107) Only take the hash path for the five atomic types it supports, so raw or other unsupported inputs still fail with the existing argument-'x' message. --- src/nswitch.c | 2 +- src/vswitch.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/nswitch.c b/src/nswitch.c index ecc583c..54d6bd0 100644 --- a/src/nswitch.c +++ b/src/nswitch.c @@ -133,7 +133,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { } SEXP ans = PROTECT(allocVector(type0, len_x)); copyMostAttrib(PTR_ETL(args, 1), ans); - if (n > 8 && len_x <= INT_MAX && type_x != VECSXP) { + if (n > 8 && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x)) { SEXP values = PROTECT(allocVector(type_x, n)); SEXP outputs = PROTECT(allocVector(VECSXP, n)); switch (type_x) { diff --git a/src/vswitch.c b/src/vswitch.c index 05276fd..8bdde69 100644 --- a/src/vswitch.c +++ b/src/vswitch.c @@ -182,7 +182,7 @@ SEXP vswitchR(SEXP x, SEXP values, SEXP outputs, SEXP na, SEXP nthreads, SEXP ch } ans = PROTECT(allocVector(type_outputs, len_x)); nprotect++; copyMostAttrib(po[0], ans); - if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && type_x != VECSXP) { + if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x)) { kit_switch_hash(ans, x, values, outputs, na, type_x, type_o, len_x, len_values, len_na, nth, nonna, utfcon, xans, vans); UNPROTECT(nprotect); @@ -353,7 +353,7 @@ SEXP vswitchR(SEXP x, SEXP values, SEXP outputs, SEXP na, SEXP nthreads, SEXP ch } ans = PROTECT(allocVector(type_o, len_x)); nprotect++; copyMostAttrib(outputs, ans); - if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && type_x != VECSXP) { + if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x)) { kit_switch_hash(ans, x, values, outputs, na, type_x, type_o, len_x, len_values, len_na, nth, nonna, utfcon, xans, vans); UNPROTECT(nprotect); From 53b2dca77969efa8654066c6e7a28acbb33d7f22 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 22:29:34 +0100 Subject: [PATCH 7/9] fix(perf): address red/blue review findings (#107) - Hoist every LOGICAL/INTEGER/REAL/COMPLEX/STRING_PTR_RO accessor and output pointer out of the OpenMP region. ALTREP accessors are not thread-safe; the previous code could corrupt R's heap with nThread > 1 and ALTREP x/default. - Use R_alloc for the switch hash table so an allocation error cannot leak it. - Keep the old argument-'outputs' error for unsupported output types, and bound the pair count that uses the per-pair map. - Only sample cardinality for inputs of at least 262k rows, use random sample positions, and cap wide-frame samples; this removes the low-cardinality presize regression and the fixed-stride false positive. - Reuse kit_hash_rows_int_raw in countOccurDataFrameR. - Extend tests for hash-path encodings, checkEnc=FALSE, vector defaults and all output writers. Refresh benchmark references and NEWS numbers. --- NEWS.md | 4 +- inst/tinytest/test-switch-hash.R | 28 +++++++++- src/kit.h | 16 ++++-- src/nswitch.c | 2 +- src/switch_hash.c | 87 +++++++++++++++++++++----------- src/utils.c | 6 +-- src/vswitch.c | 4 +- tools/benchmark-core.R | 8 ++- 8 files changed, 107 insertions(+), 48 deletions(-) diff --git a/NEWS.md b/NEWS.md index adeac4b..8d6d281 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,9 +2,9 @@ ### Notes -- Speed up `vswitch()` and `nswitch()` when there are many value/output pairs. For more than 8 pairs the implementation builds a value-to-last-pair hash map once and scans `x` in cache-sized blocks instead of comparing `x` against every value. Matching semantics are unchanged: integer/logical `NA` still matches `NA`, doubles/complex canonicalise `-0` and never match `NA`/`NaN`, strings compare `CHARSXP` identity, duplicate values keep the last pair, and threaded results stay deterministic. On 2m elements, 20 values are about 2x faster and 100 values 4-5x faster; the value-major path is kept for 8 or fewer pairs. +- Speed up `vswitch()` and `nswitch()` when there are many value/output pairs. For more than 8 pairs the implementation builds a value-to-last-pair hash map once and scans `x` in cache-sized blocks instead of comparing `x` against every value. Matching semantics are unchanged: integer/logical `NA` still matches `NA`, doubles/complex canonicalise `-0` and never match `NA`/`NaN`, strings compare `CHARSXP` identity, duplicate values keep the last pair, and threaded results stay deterministic. On 2m elements, 20 values are about 2-2.5x faster and 100 values 4.5-5.7x faster; the value-major path is kept for 8 or fewer pairs. -- Speed up `funique()`/`fduplicated()`/`uniqLen()` on data frames and matrices. Row hashes now use a 64-bit rolling mix instead of mixing every cell and mixing again, and a bounded sample estimates cardinality so high-cardinality inputs allocate the final table once while low-cardinality inputs keep the small grow-on-demand table. On 10m rows, 2-column integer data frames improve about 2.4x and mixed integer/double frames about 2.3x. +- Speed up `funique()`/`fduplicated()`/`uniqLen()` on data frames and matrices. Row hashes now use a 64-bit rolling mix instead of mixing every cell and mixing again, and a bounded sample estimates cardinality so high-cardinality inputs allocate the final table once while low-cardinality inputs keep the small grow-on-demand table. On 10m rows, 2-column integer data frames improve about 2.5x and mixed integer/double frames about 2.3-2.5x; 2m frames improve 1.5-1.8x. The scalar vector path was left unchanged: it is already faster than `data.table::uniqueN()` and dedicated hash variants stayed under the 20% threshold. - Add `tools/benchmark-core.R`, a manual benchmark covering 2m/10m elements, 5/20/100 switch values, integer/string/factor/NA inputs, data frames, and 1/2/4 threads. It is not run in CI. diff --git a/inst/tinytest/test-switch-hash.R b/inst/tinytest/test-switch-hash.R index e72c6e1..928c745 100644 --- a/inst/tinytest/test-switch-hash.R +++ b/inst/tinytest/test-switch-hash.R @@ -8,7 +8,7 @@ sys.source("helper-kit.R", envir = environment()) # Reference for types where NA matches NA (integer, logical, string, factor). ref_na <- function(x, values, outputs, default = NA) { - ans <- rep(default, length(x)) + ans <- rep_len(default, length(x)) for (i in seq_along(values)) { hit <- if (is.na(values[i])) is.na(x) else !is.na(x) & x == values[i] ans[hit] <- rep_len(outputs[[i]], length(x))[hit] @@ -18,7 +18,7 @@ ref_na <- function(x, values, outputs, default = NA) { # Reference for doubles/complex, where NA and NaN never match. ref_num <- function(x, values, outputs, default = NA) { - ans <- rep(default, length(x)) + ans <- rep_len(default, length(x)) for (i in seq_along(values)) { hit <- !is.na(values[i]) & !is.nan(values[i]) & !is.na(x) & !is.nan(x) & x == values[i] @@ -192,3 +192,27 @@ expect_identical( 1+0i, 1L, 2+0i, 2L, 3+0i, 3L, 4+0i, 4L, 5+0i, 5L, 6+0i, 6L, 7+0i, 7L, 8+0i, 8L, 9+0i, 9L, default = 0L), c(1L, 9L, 0L, 0L), info = "hash-nswitch-cplx") + +# Mixed encodings and length(x) defaults on the hash path. +vals_e9 <- c(paste0("v", 1:7), enc_lat, enc_utf) +x_e9 <- c(enc_lat, enc_utf, NA_character_, "v1") +pairs_e9 <- unlist(lapply(seq_along(vals_e9), function(i) list(vals_e9[i], i)), + recursive = FALSE) +expect_identical( + do.call(nswitch, c(list(x_e9), pairs_e9, list(default = 0L))), + c(9L, 9L, 0L, 1L), info = "hash-nswitch-enc") +expect_identical(vswitch(enc2utf8(x_s), enc2utf8(vals_s), outs_s, + checkEnc = FALSE), + exp_s, info = "hash-vswitch-nocheckenc") +dflt <- seq_along(x_i) * 10L +expect_identical(vswitch(x_i, vals_i, outs_i, dflt), + ref_na(x_i, vals_i, as.list(outs_i), default = dflt), + info = "hash-vswitch-vector-default") +expect_identical( + do.call(nswitch, c(list(x_i), + unlist(lapply(seq_along(vals_i), + function(i) list(vals_i[i], outs_i[i])), + recursive = FALSE), + list(default = dflt))), + ref_na(x_i, vals_i, as.list(outs_i), default = dflt), + info = "hash-nswitch-vector-default") diff --git a/src/kit.h b/src/kit.h index 5c808d0..3f7b33b 100644 --- a/src/kit.h +++ b/src/kit.h @@ -49,6 +49,8 @@ #define IS_BOOL(x) (XLENGTH(x)==1 && TYPEOF(x)==LGLSXP && LOGICAL(x)[0]!=NA_LOGICAL) #define IS_VALID_TYPE(x) ((x) == LGLSXP || (x)==INTSXP || (x)==REALSXP || (x)==CPLXSXP || (x)==STRSXP || (x)==VECSXP) #define IS_SWITCH_HASH_TYPE(x) ((x) == LGLSXP || (x)==INTSXP || (x)==REALSXP || (x)==CPLXSXP || (x)==STRSXP) +/* Keep the per-pair map memory bounded; absurd pair counts stay value-major. */ +#define KIT_SWITCH_HASH_MAX_PAIRS 1048576 #define PTR_ETL(x, y) (((const SEXP *)DATAPTR_RO(x))[y]) #define SEXPPTR_RO(x) ((const SEXP *)DATAPTR_RO(x)) #define ISNA_COMPLEX(x) (ISNA(x.r) || ISNA(x.i)) @@ -210,14 +212,18 @@ KIT_DEFINE_ROW_GROW(str, SEXP, kit_hash_rows_str) static inline bool kit_likely_high_card_##name(const type *px, \ const R_xlen_t len_i, \ const R_xlen_t len_x) { \ - const R_xlen_t sample = len_i < 65536 ? len_i : 65536; \ - if (sample < 64) return false; \ + if (len_i < 262144) return false; /* growth is cheap below this size */ \ + R_xlen_t sample = len_x > 16 ? 65536 / len_x : 65536; \ + if (sample < 4096) sample = 4096; \ + if (sample > len_i) sample = len_i; \ size_t cap = 256; \ while (cap < (size_t) sample * 2) cap <<= 1; \ uint32_t *keys = (uint32_t*) R_Calloc(cap, uint32_t); \ size_t distinct = 0; \ + uint64_t state = 0x9E3779B97F4A7C15ULL ^ (uint64_t) len_i; \ for (R_xlen_t s = 0; s < sample; ++s) { \ - const R_xlen_t i = (R_xlen_t)((uint64_t) s * (uint64_t) len_i / (uint64_t) sample); \ + state = state * 6364136223846793005ULL + 1442695040888963407ULL; \ + const R_xlen_t i = (R_xlen_t)(state % (uint64_t) len_i); \ uint32_t key = (uint32_t) hashfn(px, i, len_i, len_x, 32); \ if (!key) key = 1; \ size_t id = (size_t) key & (cap - 1); \ @@ -225,8 +231,9 @@ static inline bool kit_likely_high_card_##name(const type *px, \ if (!keys[id]) { keys[id] = key; distinct++; } \ } \ R_Free(keys); \ + if (distinct < 64) return false; \ const size_t dup = (size_t) sample - distinct; \ - if (!dup) return true; /* a full sample with no repeat means U >> n/2 */ \ + if (!dup) return true; /* no repeat in a random sample means U >> n/2 */ \ const double uhat = (double) sample * (double) (sample - 1) / \ (2.0 * (double) dup); \ return uhat > (double) len_i * 0.5; \ @@ -234,7 +241,6 @@ static inline bool kit_likely_high_card_##name(const type *px, \ KIT_DEFINE_ROW_SAMPLE(lgl, int, kit_hash_rows_lgl) KIT_DEFINE_ROW_SAMPLE(int, int, kit_hash_rows_int) -KIT_DEFINE_ROW_SAMPLE(int_raw, int, kit_hash_rows_int_raw) KIT_DEFINE_ROW_SAMPLE(real, double, kit_hash_rows_real) KIT_DEFINE_ROW_SAMPLE(cplx, Rcomplex, kit_hash_rows_cplx) KIT_DEFINE_ROW_SAMPLE(str, SEXP, kit_hash_rows_str) diff --git a/src/nswitch.c b/src/nswitch.c index 54d6bd0..4d965e1 100644 --- a/src/nswitch.c +++ b/src/nswitch.c @@ -133,7 +133,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { } SEXP ans = PROTECT(allocVector(type0, len_x)); copyMostAttrib(PTR_ETL(args, 1), ans); - if (n > 8 && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x)) { + if (n > 8 && n <= KIT_SWITCH_HASH_MAX_PAIRS && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x) && IS_VALID_TYPE(type0)) { SEXP values = PROTECT(allocVector(type_x, n)); SEXP outputs = PROTECT(allocVector(VECSXP, n)); switch (type_x) { diff --git a/src/switch_hash.c b/src/switch_hash.c index 2895aa1..9dd1ab6 100644 --- a/src/switch_hash.c +++ b/src/switch_hash.c @@ -17,6 +17,7 @@ */ #include "kit.h" +#include /* * Value -> last pair index map for vswitch()/nswitch() when there are many @@ -128,11 +129,10 @@ KIT_SW_MATCH_DEF(dbl, double) KIT_SW_MATCH_DEF(cplx, Rcomplex) KIT_SW_MATCH_DEF(str, SEXP) -static inline void kit_sw_write_lgl(SEXP ans, const int *match, +static inline void kit_sw_write_lgl(int *restrict pans, const int *match, const R_xlen_t off, const R_xlen_t len, const int *pna, const ssize_t namask, int *const *ppo, const ssize_t *amask) { - int *restrict pans = LOGICAL(ans); for (ssize_t j = 0; j < len; ++j) { const int k = match[j]; pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : NA_LOGICAL) @@ -140,11 +140,10 @@ static inline void kit_sw_write_lgl(SEXP ans, const int *match, } } -static inline void kit_sw_write_int(SEXP ans, const int *match, +static inline void kit_sw_write_int(int *restrict pans, const int *match, const R_xlen_t off, const R_xlen_t len, const int *pna, const ssize_t namask, int *const *ppo, const ssize_t *amask) { - int *restrict pans = INTEGER(ans); for (ssize_t j = 0; j < len; ++j) { const int k = match[j]; pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : NA_INTEGER) @@ -152,11 +151,10 @@ static inline void kit_sw_write_int(SEXP ans, const int *match, } } -static inline void kit_sw_write_dbl(SEXP ans, const int *match, +static inline void kit_sw_write_dbl(double *restrict pans, const int *match, const R_xlen_t off, const R_xlen_t len, const double *pna, const ssize_t namask, double *const *ppo, const ssize_t *amask) { - double *restrict pans = REAL(ans); for (ssize_t j = 0; j < len; ++j) { const int k = match[j]; pans[off + j] = k < 0 ? (pna ? pna[(off + j) & namask] : NA_REAL) @@ -164,12 +162,11 @@ static inline void kit_sw_write_dbl(SEXP ans, const int *match, } } -static inline void kit_sw_write_cplx(SEXP ans, const int *match, +static inline void kit_sw_write_cplx(Rcomplex *restrict pans, const int *match, const R_xlen_t off, const R_xlen_t len, const Rcomplex *pna, const ssize_t namask, Rcomplex *const *ppo, const ssize_t *amask) { - Rcomplex *restrict pans = COMPLEX(ans); Rcomplex na_cplx; na_cplx.r = NA_REAL; na_cplx.i = NA_REAL; @@ -228,40 +225,66 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, const size_t target = (size_t)len_values * (len_values <= 4096 ? 4 : 2); while (cap < target) cap <<= 1; const size_t mask = cap - 1; - int *slots = (int*) R_Calloc(cap, int); + int *slots = (int*) R_alloc(cap, sizeof(int)); + memset(slots, 0, cap * sizeof(int)); int *match = (int*) R_alloc((size_t) nth_hash * KIT_SW_BLOCK, sizeof(int)); + /* Materialise every user data pointer on the main thread before any OpenMP + loop: ALTREP accessors (LOGICAL/INTEGER/.../STRING_PTR_RO) are not + thread-safe and can allocate from R's heap. */ + const int *px_lgl = NULL, *pv_lgl = NULL; + const int *px_int = NULL, *pv_int = NULL; + const double *px_dbl = NULL, *pv_dbl = NULL; + const Rcomplex *px_cplx = NULL, *pv_cplx = NULL; + const SEXP *px_str = NULL, *pv_str = NULL; switch (type_x) { case LGLSXP: - kit_sw_build_lgl(LOGICAL(sv), len_values, slots, mask); + px_lgl = LOGICAL(sx); + pv_lgl = LOGICAL(sv); + kit_sw_build_lgl(pv_lgl, len_values, slots, mask); break; case INTSXP: - kit_sw_build_int(INTEGER(sv), len_values, slots, mask); + px_int = INTEGER(sx); + pv_int = INTEGER(sv); + kit_sw_build_int(pv_int, len_values, slots, mask); break; case REALSXP: - kit_sw_build_dbl(REAL(sv), len_values, slots, mask); + px_dbl = REAL(sx); + pv_dbl = REAL(sv); + kit_sw_build_dbl(pv_dbl, len_values, slots, mask); break; case CPLXSXP: - kit_sw_build_cplx(COMPLEX(sv), len_values, slots, mask); + px_cplx = COMPLEX(sx); + pv_cplx = COMPLEX(sv); + kit_sw_build_cplx(pv_cplx, len_values, slots, mask); break; case STRSXP: - kit_sw_build_str(STRING_PTR_RO(sv), len_values, slots, mask); + px_str = STRING_PTR_RO(sx); + pv_str = STRING_PTR_RO(sv); + kit_sw_build_str(pv_str, len_values, slots, mask); break; default: // # nocov - R_Free(slots); // # nocov error("Type %s is not supported for hashed switch.", type2char(type_x)); // # nocov } /* Output pointers: a list of per-pair outputs, or a vector of pair results. */ void *ppo_store = NULL; ssize_t *amask = (ssize_t*) R_alloc((size_t) len_values, sizeof(ssize_t)); - const SEXP *ppo_vec = NULL; + int *pans_lgl = NULL, *pans_int = NULL; + double *pans_dbl = NULL; + Rcomplex *pans_cplx = NULL; + const int *pna_lgl = NULL, *pna_int = NULL; + const double *pna_dbl = NULL; + const Rcomplex *pna_cplx = NULL; + const SEXP *pna_str = NULL, *pna_vec = NULL; const int *ppo_int = NULL; const double *ppo_dbl = NULL; const Rcomplex *ppo_cplx = NULL; const SEXP *ppo_str = NULL; switch (type_ot) { case LGLSXP: + pans_lgl = LOGICAL(ans); + pna_lgl = nonna ? LOGICAL(na) : NULL; ppo_store = R_alloc((size_t) len_values, sizeof(int*)); if (list_out) { for (ssize_t i = 0; i < len_values; ++i) { @@ -277,6 +300,8 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } break; case INTSXP: + pans_int = INTEGER(ans); + pna_int = nonna ? INTEGER(na) : NULL; ppo_store = R_alloc((size_t) len_values, sizeof(int*)); if (list_out) { for (ssize_t i = 0; i < len_values; ++i) { @@ -292,6 +317,8 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } break; case REALSXP: + pans_dbl = REAL(ans); + pna_dbl = nonna ? REAL(na) : NULL; ppo_store = R_alloc((size_t) len_values, sizeof(double*)); if (list_out) { for (ssize_t i = 0; i < len_values; ++i) { @@ -307,6 +334,8 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } break; case CPLXSXP: + pans_cplx = COMPLEX(ans); + pna_cplx = nonna ? COMPLEX(na) : NULL; ppo_store = R_alloc((size_t) len_values, sizeof(Rcomplex*)); if (list_out) { for (ssize_t i = 0; i < len_values; ++i) { @@ -322,6 +351,7 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } break; case STRSXP: + pna_str = nonna ? STRING_PTR_RO(na) : NULL; ppo_store = R_alloc((size_t) len_values, sizeof(SEXP*)); if (list_out) { for (ssize_t i = 0; i < len_values; ++i) { @@ -337,6 +367,7 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } break; case VECSXP: + pna_vec = nonna ? SEXPPTR_RO(na) : NULL; ppo_store = R_alloc((size_t) len_values, sizeof(SEXP*)); for (ssize_t i = 0; i < len_values; ++i) { ((const SEXP**) ppo_store)[i] = SEXPPTR_RO(po[i]); @@ -344,7 +375,6 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } break; default: // # nocov - R_Free(slots); // # nocov error("Type %s is not supported for hashed switch output.", // # nocov type2char(type_ot)); // # nocov } @@ -352,22 +382,22 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, const R_xlen_t nblocks = (len_x + KIT_SW_BLOCK - 1) / KIT_SW_BLOCK; #define KIT_SW_MATCH_BLOCK() do { \ switch (type_x) { \ - case LGLSXP: kit_sw_match_lgl(LOGICAL(sx), LOGICAL(sv), slots, mask, mb, off, blen); break; \ - case INTSXP: kit_sw_match_int(INTEGER(sx), INTEGER(sv), slots, mask, mb, off, blen); break; \ - case REALSXP: kit_sw_match_dbl(REAL(sx), REAL(sv), slots, mask, mb, off, blen); break; \ - case CPLXSXP: kit_sw_match_cplx(COMPLEX(sx), COMPLEX(sv), slots, mask, mb, off, blen); break; \ - case STRSXP: kit_sw_match_str(STRING_PTR_RO(sx), STRING_PTR_RO(sv), slots, mask, mb, off, blen); break; \ + case LGLSXP: kit_sw_match_lgl(px_lgl, pv_lgl, slots, mask, mb, off, blen); break; \ + case INTSXP: kit_sw_match_int(px_int, pv_int, slots, mask, mb, off, blen); break; \ + case REALSXP: kit_sw_match_dbl(px_dbl, pv_dbl, slots, mask, mb, off, blen); break; \ + case CPLXSXP: kit_sw_match_cplx(px_cplx, pv_cplx, slots, mask, mb, off, blen); break; \ + case STRSXP: kit_sw_match_str(px_str, pv_str, slots, mask, mb, off, blen); break; \ } \ } while (0) #define KIT_SW_WRITE_BLOCK() do { \ switch (type_ot) { \ - case LGLSXP: kit_sw_write_lgl(ans, mb, off, blen, nonna ? LOGICAL(na) : NULL, namask, (int*const*) ppo_store, amask); break; \ - case INTSXP: kit_sw_write_int(ans, mb, off, blen, nonna ? INTEGER(na) : NULL, namask, (int*const*) ppo_store, amask); break; \ - case REALSXP: kit_sw_write_dbl(ans, mb, off, blen, nonna ? REAL(na) : NULL, namask, (double*const*) ppo_store, amask); break; \ - case CPLXSXP: kit_sw_write_cplx(ans, mb, off, blen, nonna ? COMPLEX(na) : NULL, namask, (Rcomplex*const*) ppo_store, amask); break; \ - case STRSXP: kit_sw_write_str(ans, mb, off, blen, nonna ? STRING_PTR_RO(na) : NULL, namask, (const SEXP*const*) ppo_store, amask); break; \ - case VECSXP: kit_sw_write_vec(ans, mb, off, blen, nonna ? SEXPPTR_RO(na) : NULL, namask, (const SEXP*const*) ppo_store, amask); break; \ + case LGLSXP: kit_sw_write_lgl(pans_lgl, mb, off, blen, pna_lgl, namask, (int*const*) ppo_store, amask); break; \ + case INTSXP: kit_sw_write_int(pans_int, mb, off, blen, pna_int, namask, (int*const*) ppo_store, amask); break; \ + case REALSXP: kit_sw_write_dbl(pans_dbl, mb, off, blen, pna_dbl, namask, (double*const*) ppo_store, amask); break; \ + case CPLXSXP: kit_sw_write_cplx(pans_cplx, mb, off, blen, pna_cplx, namask, (Rcomplex*const*) ppo_store, amask); break; \ + case STRSXP: kit_sw_write_str(ans, mb, off, blen, pna_str, namask, (const SEXP*const*) ppo_store, amask); break; \ + case VECSXP: kit_sw_write_vec(ans, mb, off, blen, pna_vec, namask, (const SEXP*const*) ppo_store, amask); break; \ } \ } while (0) @@ -391,5 +421,4 @@ void kit_switch_hash(SEXP ans, SEXP x, SEXP values, SEXP outputs, SEXP na, } #undef KIT_SW_MATCH_BLOCK #undef KIT_SW_WRITE_BLOCK - R_Free(slots); } diff --git a/src/utils.c b/src/utils.c index 1bb3c50..b75aa36 100644 --- a/src/utils.c +++ b/src/utils.c @@ -708,11 +708,7 @@ SEXP countOccurDataFrameR(SEXP x) { // move to matrix if possible (change hash a const int *restrict v = INTEGER(mlv); size_t id = 0; for (R_xlen_t i = 0; i < len_i; ++i) { - R_xlen_t key = 0; - for (R_xlen_t j = 0; j < len_x; ++j) { - key ^= HASH(v[i+j*len_i],K)*97*(j+1); - } - id = HASH(key, K); + id = kit_hash_rows_int_raw(v, i, len_i, len_x, K); while (h[id]) { for (R_xlen_t j = 0; j < len_x; ++j) { if (v[h[id]-1+j*len_i] != v[i+j*len_i]) { diff --git a/src/vswitch.c b/src/vswitch.c index 8bdde69..abff7d6 100644 --- a/src/vswitch.c +++ b/src/vswitch.c @@ -182,7 +182,7 @@ SEXP vswitchR(SEXP x, SEXP values, SEXP outputs, SEXP na, SEXP nthreads, SEXP ch } ans = PROTECT(allocVector(type_outputs, len_x)); nprotect++; copyMostAttrib(po[0], ans); - if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x)) { + if (len_values > 8 && len_values <= KIT_SWITCH_HASH_MAX_PAIRS && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x) && IS_VALID_TYPE(type_outputs)) { kit_switch_hash(ans, x, values, outputs, na, type_x, type_o, len_x, len_values, len_na, nth, nonna, utfcon, xans, vans); UNPROTECT(nprotect); @@ -353,7 +353,7 @@ SEXP vswitchR(SEXP x, SEXP values, SEXP outputs, SEXP na, SEXP nthreads, SEXP ch } ans = PROTECT(allocVector(type_o, len_x)); nprotect++; copyMostAttrib(outputs, ans); - if (len_values > 8 && len_values <= INT_MAX && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x)) { + if (len_values > 8 && len_values <= KIT_SWITCH_HASH_MAX_PAIRS && len_x <= INT_MAX && IS_SWITCH_HASH_TYPE(type_x) && IS_SWITCH_HASH_TYPE(type_o)) { kit_switch_hash(ans, x, values, outputs, na, type_x, type_o, len_x, len_values, len_na, nth, nonna, utfcon, xans, vans); UNPROTECT(nprotect); diff --git a/tools/benchmark-core.R b/tools/benchmark-core.R index deabe07..d612bdc 100644 --- a/tools/benchmark-core.R +++ b/tools/benchmark-core.R @@ -15,6 +15,7 @@ if (length(args) >= 1L && nzchar(args[[1]])) .libPaths(c(args[[1]], .libPaths()) label <- if (length(args) >= 2L) args[[2]] else "current" reps <- if (length(args) >= 3L) as.integer(args[[3]]) else 5L library(kit) +options(kit.nThread = 1L) has_dt <- requireNamespace("data.table", quietly = TRUE) bench <- function(f) { @@ -75,7 +76,7 @@ for (n in c(2000000L, n10)) { row("nswitch_str", n, m, f = function() { do.call(nswitch, c(list(xs), pairs_s, list(default = 0L))) }) - if (has_dt && m == 100L) { + if (has_dt) { row("ref_chmatch_str", n, m, f = function() data.table::chmatch(xs, vs)) } } @@ -89,13 +90,16 @@ for (n in c(2000000L, n10)) { df_int <- data.frame(a = xi, b = sample.int(1000L, n, TRUE)) df_mix <- data.frame(a = xi, b = rnorm(n)) row("funique_int", n, f = function() funique(xi)) - row("funique_seq", n, f = function() funique(xseq)) + row("funique_seq_cycle", n, f = function() funique(xseq)) row("funique_str", n, f = function() funique(xs)) row("uniqLen_int", n, f = function() uniqLen(xi)) row("uniqLen_df_int", n, f = function() uniqLen(df_int)) row("funique_df_int", n, f = function() funique(df_int)) row("uniqLen_df_mixed", n, f = function() uniqLen(df_mix)) row("funique_df_mixed", n, f = function() funique(df_mix)) + row("ref_unique_int", n, f = function() length(unique(xi))) + row("ref_unique_df_int", n, f = function() nrow(unique(df_int))) + row("ref_unique_df_mixed", n, f = function() nrow(unique(df_mix))) if (has_dt) { row("ref_uniqueN_int", n, f = function() data.table::uniqueN(xi)) row("ref_uniqueN_df_int", n, f = function() data.table::uniqueN(df_int)) From accaecf27ec52b30a64ba649a453188321133ad3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Mon, 2 Nov 2026 22:30:16 +0100 Subject: [PATCH 8/9] test(switch): keep output-type errors at 9+ pairs (#107) --- inst/tinytest/test-switch-hash.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/inst/tinytest/test-switch-hash.R b/inst/tinytest/test-switch-hash.R index 928c745..efc831a 100644 --- a/inst/tinytest/test-switch-hash.R +++ b/inst/tinytest/test-switch-hash.R @@ -216,3 +216,14 @@ expect_identical( list(default = dflt))), ref_na(x_i, vals_i, as.list(outs_i), default = dflt), info = "hash-nswitch-vector-default") + +# Unsupported output types also keep the value-major error at 9+ pairs. +expect_error(vswitch(1:9, 1:9, as.raw(1:9)), + pattern = "Type raw is not supported for argument 'outputs'", + fixed = TRUE, info = "hash-vswitch-raw-out") +expect_error( + do.call(nswitch, c(list(1:9), + unlist(lapply(1:9, function(i) list(i, as.raw(i))), + recursive = FALSE))), + pattern = "Type raw is not supported for argument 'outputs'", + fixed = TRUE, info = "hash-nswitch-raw-out") From 8db8de98ba8828efe2f742ba9a1bd3f0702e5824 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dawid=20Budzy=C5=84ski?= Date: Tue, 3 Nov 2026 07:23:35 +0100 Subject: [PATCH 9/9] fix(perf): keep edge-case switch and unique semantics (#107) - enc2UTF8() now checks every string instead of just the first and preserves NA_STRING. Value-major nswitch() compares each pair with its own converted value instead of the first. - Double hashes canonicalise -0/0 and NaN payloads the way REQUAL does, so funique(), fduplicated() and uniqLen() agree with base R on vectors, matrices and data frames. - Add regression tests and NEWS entries. Measurement: ISNAN() is inlined and R_IsNA() is only called for actual NaNs, so scalar double hashing is 11-14% faster. The double-frame row hash pays about 4% for the special-value check, leaving the PR's speedup intact. --- NEWS.md | 6 ++++++ inst/tinytest/test-enc.R | 14 ++++++++++++++ inst/tinytest/test-switch-hash.R | 11 +++++++++++ inst/tinytest/test-unique.R | 30 ++++++++++++++++++++++++++++++ src/dup.c | 10 +++++----- src/dupLen.c | 2 +- src/kit.h | 18 ++++++++++++++---- src/nswitch.c | 12 ++++++------ src/utils.c | 22 ++++++++++++++-------- 9 files changed, 101 insertions(+), 24 deletions(-) diff --git a/NEWS.md b/NEWS.md index 8d6d281..309e05a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,11 @@ # kit 0.0.24 (development version) +### Bug Fixes + +- Fix `vswitch()`/`nswitch()` with `checkEnc = TRUE` when the first string is already UTF-8 but later elements are latin1 or `NA`: `enc2UTF8()` now checks every element and preserves `NA_STRING`, and value-major `nswitch()` compares each pair against its own converted value instead of the first one. + +- Fix `funique()`/`fduplicated()`/`uniqLen()` hashing `-0` and differing `NaN` payloads as distinct doubles. Vector, matrix and data-frame paths now canonicalise doubles the same way `REQUAL` compares them, matching base R. + ### Notes - Speed up `vswitch()` and `nswitch()` when there are many value/output pairs. For more than 8 pairs the implementation builds a value-to-last-pair hash map once and scans `x` in cache-sized blocks instead of comparing `x` against every value. Matching semantics are unchanged: integer/logical `NA` still matches `NA`, doubles/complex canonicalise `-0` and never match `NA`/`NaN`, strings compare `CHARSXP` identity, duplicate values keep the last pair, and threaded results stay deterministic. On 2m elements, 20 values are about 2-2.5x faster and 100 values 4.5-5.7x faster; the value-major path is kept for 8 or fewer pairs. diff --git a/inst/tinytest/test-enc.R b/inst/tinytest/test-enc.R index ece2d7a..330c9b1 100644 --- a/inst/tinytest/test-enc.R +++ b/inst/tinytest/test-enc.R @@ -26,6 +26,20 @@ expect_identical(nswitch(c(enc1, enc2), enc1, 1, default = 0), c(1, 1), info="en expect_identical(nswitch(c(enc1, enc2), enc2, 1, default = 0), c(1, 1), info="enc-009") expect_identical(nswitch(c(enc1, enc2), enc1, 1, default = 0, checkEnc = TRUE), c(1, 1), info="enc-010") +# --- First element already UTF-8: later latin1 and NA must still convert (#107) --- +x_enc <- c(enc2, enc1, NA_character_) +v_enc <- c(enc1, enc2, NA_character_) +expect_identical(vswitch(x_enc, v_enc, 1:3, checkEnc = TRUE), c(2L, 2L, 3L), + info="enc-047") +expect_identical(nswitch(x_enc, enc1, 1L, enc2, 2L, NA_character_, 3L, + default = 0L, checkEnc = TRUE), c(2L, 2L, 3L), + info="enc-048") +# Each pair must compare against its own converted value, not the first one. +expect_identical(nswitch(c(enc2, "b", NA_character_), + enc1, 1L, "b", 2L, NA_character_, 3L, + default = 0L, checkEnc = TRUE), c(1L, 2L, 3L), + info="enc-049") + # --- checkEnc argument validation --- expect_error(vswitch("a", "b", 1, checkEnc = NA), pattern = "Argument 'checkEnc' must be TRUE or FALSE and length 1.", fixed = TRUE, info="enc-011") expect_error(vswitch("a", "b", 1, checkEnc = 2), pattern = "Argument 'checkEnc' must be TRUE or FALSE and length 1.", fixed = TRUE, info="enc-012") diff --git a/inst/tinytest/test-switch-hash.R b/inst/tinytest/test-switch-hash.R index efc831a..3afe705 100644 --- a/inst/tinytest/test-switch-hash.R +++ b/inst/tinytest/test-switch-hash.R @@ -62,6 +62,17 @@ x_e <- c(enc_lat, enc_utf, paste0("v", 1:8)) expect_identical(vswitch(x_e, vals_e, c(1:8, 9L, 10L)), c(10L, 10L, 1:8), info = "hash-vswitch-str-enc") +# First element UTF-8: enc2UTF8() must still convert later latin1 and keep NA. +vals_e10 <- c(paste0("v", 1:7), enc_utf, enc_lat, NA_character_) +x_e10 <- c(enc_utf, enc_lat, NA_character_, "v1") +pairs_e10 <- unlist(lapply(seq_along(vals_e10), function(i) list(vals_e10[i], i)), + recursive = FALSE) +expect_identical(vswitch(x_e10, vals_e10, seq_along(vals_e10)), + c(9L, 9L, 10L, 1L), info = "hash-vswitch-str-enc-first-utf8") +expect_identical( + do.call(nswitch, c(list(x_e10), pairs_e10, list(default = 0L))), + c(9L, 9L, 10L, 1L), info = "hash-nswitch-str-enc-first-utf8") + # Doubles: -0 == 0, Inf matches, but NA/NaN never match. vals_d <- c(1:8, Inf, 0, NA_real_, NaN) outs_d <- c(101:108, 109L, 110L, 111L, 112L) diff --git a/inst/tinytest/test-unique.R b/inst/tinytest/test-unique.R index 004ee2e..8278de0 100644 --- a/inst/tinytest/test-unique.R +++ b/inst/tinytest/test-unique.R @@ -721,3 +721,33 @@ local({ dimnames(a) <- dimnames(b) <- NULL expect_identical(a, b, info = "funique-0107.presize-mat") }) + +# issue #107: -0/0 and differing NaN payloads must hash equal because REQUAL +# treats them equal. Vector, matrix and data-frame paths all share this rule. +local({ + mk_nan <- function(lo) { + bits <- as.raw(c(lo, 0, 0, 0, 0, 0, 0xf8, 0x7f)) + if (.Platform$endian == "big") bits <- rev(bits) + readBin(bits, "double", n = 1L, size = 8L) + } + nans <- vapply(1:64, function(i) mk_nan(as.raw(i)), numeric(1)) + for (x in list(c(0, -0), nans)) { + df <- data.frame(a = x) + m <- matrix(x, ncol = 1L) + expect_identical(funique(x), unique(x), info = "funique-0107.dbl-equal") + expect_identical(fduplicated(x), duplicated(x), info = "fduplicated-0107.dbl-equal") + expect_identical(uniqLen(x), 1L, info = "uniqLen-0107.dbl-equal") + expect_identical(nrow(funique(df)), nrow(unique(df)), + info = "funique-0107.dbl-equal-df") + expect_identical(fduplicated(df), duplicated(df), + info = "fduplicated-0107.dbl-equal-df") + expect_identical(uniqLen(df), 1L, info = "uniqLen-0107.dbl-equal-df") + expect_identical(nrow(funique(m)), nrow(unique(m)), + info = "funique-0107.dbl-equal-mat") + expect_identical(fduplicated(m), as.vector(duplicated(m)), + info = "fduplicated-0107.dbl-equal-mat") + expect_identical(uniqLen(m), 1L, info = "uniqLen-0107.dbl-equal-mat") + } + expect_identical(uniqLen(data.frame(a = c(0, -0), b = c("x", "x"))), 1L, + info = "uniqLen-0107.dbl-equal-mixed-df") +}) diff --git a/src/dup.c b/src/dup.c index 7096ec6..cb353ac 100644 --- a/src/dup.c +++ b/src/dup.c @@ -957,7 +957,7 @@ SEXP dupVecR(SEXP x, SEXP uniq, SEXP fromLast) { if (buniq) { if (pfromLast) { for (int i = n-1; i > -1; --i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id]-1], px[i])) { @@ -973,7 +973,7 @@ SEXP dupVecR(SEXP x, SEXP uniq, SEXP fromLast) { } } else { for (int i = 0; i < n; ++i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id]-1], px[i])) { @@ -1004,7 +1004,7 @@ SEXP dupVecR(SEXP x, SEXP uniq, SEXP fromLast) { } else { if (pfromLast) { for (int i = n-1; i > -1; --i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id]-1], px[i])) { @@ -1021,7 +1021,7 @@ SEXP dupVecR(SEXP x, SEXP uniq, SEXP fromLast) { } } else { for (int i = 0; i < n; ++i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id]-1], px[i])) { @@ -1339,7 +1339,7 @@ SEXP dupVecIndexOnlyR(SEXP x) { size_t id = 0; union uno tpv; for (int i = 0; i < n; ++i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id]-1], px[i])) { diff --git a/src/dupLen.c b/src/dupLen.c index ba59e82..26949a6 100644 --- a/src/dupLen.c +++ b/src/dupLen.c @@ -334,7 +334,7 @@ SEXP dupLenVecR(SEXP x) { size_t id = 0; union uno tpv; for (int i = 0; i < n; ++i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id]-1], px[i])) { diff --git a/src/kit.h b/src/kit.h index 3f7b33b..d626dff 100644 --- a/src/kit.h +++ b/src/kit.h @@ -86,6 +86,18 @@ static inline size_t kit_hash_u64(uint64_t key, int K) { union uno { double d; unsigned int u[2]; uint64_t u64; }; +/* Canonical bits for hashing a double the way REQUAL/CEQUAL compare it. */ +static inline uint64_t kit_real_bits(double x) { + union uno v; + v.d = x; + if (ISNAN(x)) { + v.d = R_IsNA(x) ? NA_REAL : R_NaN; + } else if (x == 0.0) { + v.u64 = 0; // -0 == 0 + } + return v.u64; +} + /* * Growable duplicate tables. Each table stores 1-based input indices in an * open-addressed int array and grows at 75% load. Rehashing re-reads the @@ -136,10 +148,8 @@ static inline size_t kit_hash_rows_real(const double *px, const R_xlen_t i, const R_xlen_t len_i, const R_xlen_t len_x, const int K) { uint64_t key = 0; - union uno tpv; for (R_xlen_t j = 0; j < len_x; ++j) { - tpv.d = px[i+j*len_i]; - key = key * KIT_MIX64 + tpv.u64; + key = key * KIT_MIX64 + kit_real_bits(px[i+j*len_i]); } return kit_hash_u64(key, K); } @@ -302,7 +312,7 @@ static inline int *kit_rehash_real(const double *restrict px, int *restrict h, const int e = h[s]; if (e) { const int i = e - 1; - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN : px[i]); + tpv.u64 = kit_real_bits(px[i]); size_t id = HASH(tpv.u[0] + tpv.u[1], K2); while (h2[id]) { id++; id %= M2; } h2[id] = e; diff --git a/src/nswitch.c b/src/nswitch.c index 4d965e1..59657b4 100644 --- a/src/nswitch.c +++ b/src/nswitch.c @@ -238,7 +238,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { const SEXP *restrict px = STRING_PTR_RO(utfcon ? xans : x); for (ssize_t i = 0; i < n; ++i) { const int *restrict pto = LOGICAL(PTR_ETL(args, 2*i+1)); - const SEXP *restrict pvalues = STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i)); + const SEXP *restrict pvalues = utfcon ? STRING_PTR_RO(vans) + i : STRING_PTR_RO(PTR_ETL(args, 2*i)); OMP_PARALLEL_FOR(nth) for (ssize_t j = 0; j < len_x; ++j) { if (px[j] == pvalues[0]) { @@ -331,7 +331,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { const SEXP *restrict px = STRING_PTR_RO(utfcon ? xans : x); for (ssize_t i = 0; i < n; ++i) { const int *restrict pto = INTEGER(PTR_ETL(args, 2*i+1)); - const SEXP *restrict pvalues = STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i)); + const SEXP *restrict pvalues = utfcon ? STRING_PTR_RO(vans) + i : STRING_PTR_RO(PTR_ETL(args, 2*i)); OMP_PARALLEL_FOR(nth) for (ssize_t j = 0; j < len_x; ++j) { if (px[j] == pvalues[0]) { @@ -424,7 +424,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { const SEXP *restrict px = STRING_PTR_RO(utfcon ? xans : x); for (ssize_t i = 0; i < n; ++i) { const double *restrict pto = REAL(PTR_ETL(args, 2*i+1)); - const SEXP *restrict pvalues = STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i)); + const SEXP *restrict pvalues = utfcon ? STRING_PTR_RO(vans) + i : STRING_PTR_RO(PTR_ETL(args, 2*i)); OMP_PARALLEL_FOR(nth) for (ssize_t j = 0; j < len_x; ++j) { if (px[j] == pvalues[0]) { @@ -518,7 +518,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { const SEXP *restrict px = STRING_PTR_RO(utfcon ? xans : x); for (ssize_t i = 0; i < n; ++i) { const Rcomplex *restrict pto = COMPLEX(PTR_ETL(args, 2*i+1)); - const SEXP *restrict pvalues = STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i)); + const SEXP *restrict pvalues = utfcon ? STRING_PTR_RO(vans) + i : STRING_PTR_RO(PTR_ETL(args, 2*i)); OMP_PARALLEL_FOR(nth) for (ssize_t j = 0; j < len_x; ++j) { if (px[j] == pvalues[0]) { @@ -605,7 +605,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { const SEXP *restrict px = STRING_PTR_RO(utfcon ? xans : x); for (ssize_t i = 0; i < n; ++i) { const SEXP *restrict pto = STRING_PTR_RO(PTR_ETL(args, 2*i+1)); - const SEXP *restrict pvalues = STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i)); + const SEXP *restrict pvalues = utfcon ? STRING_PTR_RO(vans) + i : STRING_PTR_RO(PTR_ETL(args, 2*i)); for (ssize_t j = 0; j < len_x; ++j) { if (px[j] == pvalues[0]) { SET_STRING_ELT(ans, j, pto[j & amask[i]]); @@ -693,7 +693,7 @@ SEXP nswitchR(SEXP x, SEXP na, SEXP nthreads, SEXP chkenc, SEXP args) { const SEXP *restrict px = STRING_PTR_RO(utfcon ? xans : x); for (ssize_t i = 0; i < n; ++i) { const SEXP *restrict pto = SEXPPTR_RO(PTR_ETL(args, 2*i+1)); - const SEXP *restrict pvalues = STRING_PTR_RO(utfcon ? vans : PTR_ETL(args, 2*i)); + const SEXP *restrict pvalues = utfcon ? STRING_PTR_RO(vans) + i : STRING_PTR_RO(PTR_ETL(args, 2*i)); for (ssize_t j = 0; j < len_x; ++j) { if (px[j] == pvalues[0]) { SET_VECTOR_ELT(ans, j, pto[j & amask[i]]); diff --git a/src/utils.c b/src/utils.c index b75aa36..9ab838d 100644 --- a/src/utils.c +++ b/src/utils.c @@ -563,7 +563,7 @@ SEXP countOccurR(SEXP x) { // can be improved for factors size_t id = 0; union uno tpv; for (int i = 0; i < n; ++i) { - tpv.d = R_IsNA(px[i]) ? NA_REAL : (R_IsNaN(px[i]) ? R_NaN :px[i]); + tpv.u64 = kit_real_bits(px[i]); id = HASH(tpv.u[0] + tpv.u[1], K); while (h[id]) { if (REQUAL(px[h[id] - 1], px[i])) { @@ -824,13 +824,19 @@ SEXP enc2UTF8(SEXP x) { const R_xlen_t len = xlength(x); if (len == 0) return x; // avoid px[0] OOB on empty input const SEXP *px = STRING_PTR_RO(x); - if (getCharCE(px[0]) != CE_UTF8) { - SEXP ans = PROTECT(allocVector(STRSXP, len)); - for (R_xlen_t i = 0; i < len; ++i) { - SET_STRING_ELT(ans, i, mkCharCE(translateCharUTF8(px[i]), CE_UTF8)); + bool all_utf8 = true; + for (R_xlen_t i = 0; i < len; ++i) { + if (px[i] != NA_STRING && getCharCE(px[i]) != CE_UTF8) { + all_utf8 = false; + break; } - UNPROTECT(1); - return ans; } - return x; + if (all_utf8) return x; + SEXP ans = PROTECT(allocVector(STRSXP, len)); + for (R_xlen_t i = 0; i < len; ++i) { + SET_STRING_ELT(ans, i, px[i] == NA_STRING ? NA_STRING : + mkCharCE(translateCharUTF8(px[i]), CE_UTF8)); + } + UNPROTECT(1); + return ans; }