Skip to content

Fix forder-order equivalence test for atypical collate locales #7837

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
MichaelChirico wants to merge 5 commits into
base: master
Choose a base branch
from
+75 −57
Open

Fix forder-order equivalence test for atypical collate locales #7837

Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
b999e94
Fix forder-order equivalence test for atypical collate locales
MichaelChirico Jul 24, 2026
37a4852
Fix other test, and change tack: use a C-sortable subset of letters
MichaelChirico Jul 24, 2026
3269442
Better variable name
MichaelChirico Jul 24, 2026
ab9279d
rm_all() kills c_sortable_letters though it's needed later in the tes…
MichaelChirico Jul 26, 2026
e40fca4
Use _pairs_ of letters to get more stable sorting
MichaelChirico Jul 27, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
132 changes: 75 additions & 57 deletions inst/tests/tests.Rraw
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -233,6 +233,32 @@ ForderObj = function(x, starts=NULL, maxgrpn=NULL, anyna=0L, anyinfnan=0L, anyno
x
}

c_sortable_pairs = apply(expand.grid(letters, letters), 1L, paste, collapse="")
# For some tests of forder() compatibility with base sorting methods.
# Subset the pairs of letters until the collation order matches C. This way we don't totally ignore
# any possible issues with sorting strings in unusual locales (even though this _should_
# be impossible given we _always_ use C-collated order, such a regression test is still
# beneficial as a sanity check). Pairs of letters are needed for languages like Latvian which
# have some '<='-like letters e.g. 'i' and 'y' are considered something of a 'tie', except when a
# tie-breaker is needed. For example, 'ya' comes before 'ib' because of 'a' < 'b' and 'i' <= 'y',
# but the letters alone sort as 'i' < 'y'.
if (!identical(order(c_sortable_pairs, method='shell'), order(c_sortable_pairs, method='radix'))) {
repeat {
sorted_c = c_sortable_pairs[order(c_sortable_pairs, method='radix')]
sorted_r = c_sortable_pairs[order(c_sortable_pairs, method='shell')]

mismatch = which(sorted_c != sorted_r)
if (!length(mismatch)) break
c_sortable_pairs = c_sortable_pairs[-mismatch[1L]]
}
} else {
# don't pull all 676 pairs, but also not sample() for stability
c_sortable_pairs = c_sortable_pairs[seq(1L, length(c_sortable_pairs), length.out=75L)]
}
if (length(c_sortable_pairs) < 5L) {
stop("This locale collates too differently from C; please report.")
}

##########################
.do_not_rm = ls() # objects that exist at this point should not be removed by rm_all(); e.g. test_*, base_messages, Ctest_dt_win_snprintf, prevtest, etc
##########################
Expand Down Expand Up @@ -4452,50 +4478,48 @@ test(1221, DT[.(1),b], c("a","c","e"))
# - Generate a random seed each time; the randomness allows catching errors quicker
# - But save the seed so that we can generate the same data back if any error occurs
seed = as.integer(Sys.time()) # sample(9999L, 1L) temporary fix, because all the set.seed(.) used above makes this sample() step deterministic (always seed=9107)
seedInfo = paste("forder decreasing argument test: seed = ", seed," ", sep="")
# no NaN (because it's hard to match with base::order); tested below in 1988.4-8
set.seed(seed)
foo <- function(n) apply(matrix(sample(letters, n*8L, TRUE), ncol=8L), 1, paste, collapse="")
foo <- function(n) apply(matrix(sample(c_sortable_pairs, n*4L, TRUE), ncol=4L), 1, paste, collapse="")
i1 = as.integer(sample(c(-100:100), 1e3, TRUE))
i2 = as.integer(sample(c(-100:100, -1e6, 1e6), 1e3, TRUE))
d1 = as.numeric(sample(c(-100:100,Inf,-Inf), 1e3, TRUE))
d2 = as.numeric(rnorm(1e3))
c1 = sample(letters, 1e3, TRUE)
c1 = sample(c_sortable_pairs, 1e3, TRUE)
c2 = sample(foo(50), 1e3, TRUE)

DT = data.table(i1, i2, d1, d2, c1, c2)
# randomise col order as well
colorder=sample(ncol(DT))
setcolorder(DT, names(DT)[colorder])
seedInfo = paste(seedInfo, "colorder = ", paste(colorder, collapse=","), sep="")
setcolorder(DT, sample(ncol(DT)))

test_no = 0L
oldnfail = nfail
for (nvars in seq_along(names(DT))) {
signs = expand.grid(replicate(nvars, c(-1L, 1L), simplify=FALSE))
combn(names(DT), nvars, simplify=FALSE, function(x) { # simplify=FALSE needed for R 3.1.0
for (i in seq_len(nrow(signs))) {
test_no <<- test_no + 1L
orders_grid = expand.grid(replicate(nvars, c(-1L, 1L), simplify=FALSE))
for (cols in combn(names(DT), nvars, simplify=FALSE)) {
for (i in seq_len(nrow(orders_grid))) {
orders = orders_grid[i, ]
test_no <- test_no + 1L
ll = as.call(c(
as.name("order"),
method="radix",
lapply(seq_along(x), function(j) {
if (signs[i,j] == 1L)
as.name(x[j])
else {
if (is.character(DT[[x[j]]]))
as.call(c(as.name("-"), as.call(list(as.name("xtfrm"), as.name(x[j])))))
else
as.call(list(as.name("-"), as.name(x[j])))
}
lapply(seq_along(cols), function(j) {
col = cols[j]
col_nm = as.name(col)
if (orders[j] == 1L)
col_nm
else if (is.character(DT[[col]]))
call("-", call("xtfrm", col_nm))
else
call("-", col_nm)
})
))
test(1223.0 + test_no*0.001, forderv(DT, by=x, order=signs[i,]), with(DT, eval(ll)), context=sprintf("signs[%d, ]==%s", i, paste(unlist(signs[i, ]), collapse=",")))
test(1223.0 + test_no*0.001, forderv(DT, by=cols, order=orders), with(DT, eval(ll)),
context=sprintf(
"seed = %d; setorder(DT, %s)",
seed, toString(paste0(fifelse(orders == 1L, "", "-"), cols))))
}
integer()
})
}
}
if (nfail > oldnfail) cat(seedInfo, "\n") # to reproduce
rm_all()

# fix for bug #44 - unique on null data.table should return null data.table
Expand Down Expand Up @@ -4728,58 +4752,52 @@ seed = as.integer(Sys.time())
# This choice of seed by Arun was very good as it revealed problems that a fixed seed would not.
# Test 1844 is now added to consistently run the rare cases discovered here (depending on the seed) to cover all lines in
# forder consistently to save pull requests failing coverage tests randomly, issue #2346
seedInfo = paste("forder decreasing argument test: seed = ", seed," ", sep="")
set.seed(seed)
# these variable try to simulate groups of length 1, 2, < 200, > 200 so as to cover all different internal implementations
foo <- function(n) apply(matrix(sample(letters, n*8L, TRUE), ncol=8L), 1, paste, sep="")
foo <- function(n) apply(matrix(sample(c_sortable_pairs, n*4L, TRUE), ncol=4L), 1, paste, collapse="")
i1 = as.integer(sample(rep(c(-3:3, NA_integer_), c(1, 2, 190, 300, 7, 190, 210, 100))))
i2 = as.integer(sample(rep(c(-2:2, -1e6, 1e6, NA_integer_), c(1, 2, 190, 300, 7, 190, 210, 100))))
d1 = as.numeric(sample(rep(c(-2:2,Inf,-Inf, NA_real_, 5, -1e3), c(1, 190, 2, 300, 7, 50, 50, 100, 150, 150))))
c1 = sample(rep(c(letters[1:5], NA_character_, "z"), c(1, 2, 190, 7, 300, 200, 300)))
c1 = sample(rep(c(c_sortable_pairs[1:5], NA_character_, "z"), c(1, 2, 190, 7, 300, 200, 300)))
c2 = sample(c(foo(200), NA_character_), 1e3, TRUE)

DT = data.table(i1, i2, d1, c1, c2)
# randomise col order as well
colorder=sample(ncol(DT))
setcolorder(DT, names(DT)[colorder])
seedInfo = paste(seedInfo, "colorder = ", paste(colorder, collapse=","), sep="")
ans = vector("list", length(names(DT)))
setcolorder(DT, sample(ncol(DT)))

test_no = 0L
oldnfail = nfail
for (i in seq_along(names(DT))) {
cj = as.matrix(do.call(CJ, split(rep(c(1L,-1L), each=i), 1:i)))
ans[[i]] = combn(names(DT), i, function(x) {
tmp = apply(cj, 1, function(y) {
test_no <<- test_no + 1L
for (nvars in seq_along(names(DT))) {
orders_grid = expand.grid(replicate(nvars, c(-1L, 1L), simplify=FALSE))
for (cols in combn(names(DT), nvars, simplify=FALSE)) {
for (i in seq_len(nrow(orders_grid))) {
orders = orders_grid[i, ]
test_no <- test_no + 1L
ll = as.call(c(
as.name("base_order"),
method = "radix",
lapply(seq_along(x), function(j) {
x_nm = as.name(x[j])
if (y[j] == 1L)
x_nm
else {
if (is.character(DT[[x[j]]]))
as.call(c(as.name("-"), as.call(list(as.name("xtfrm"), x_nm))))
else
as.call(list(as.name("-"), x_nm))
}
lapply(seq_along(cols), function(j) {
col = cols[j]
col_nm = as.name(col)
if (orders[j] == 1L)
col_nm
else if (is.character(DT[[col]]))
call("-", call("xtfrm", col_nm))
else
call("-", col_nm)
})
))
ans1 = forderv(DT, by=x, order=y, na.last=TRUE) # adding tests for both nalast=TRUE and nalast=NA
ans1 = forderv(DT, by=cols, order=orders, na.last=TRUE) # adding tests for both nalast=TRUE and nalast=NA
test(1252.0 + test_no*0.001, ans1, with(DT, eval(ll)), context=sprintf("ll=%s", format(ll)))
test_no <<- test_no + 1L
test_no <- test_no + 1L
ll <- as.call(c(as.list(ll), na.last=NA))
ans1 = forderv(DT, by=x, order=y, na.last=NA) # nalast=NA here.
test(1252.0 + test_no*0.001, ans1[ans1 != 0], with(DT, eval(ll)), context=sprintf("ll=%s", format(ll)))
})
dim(tmp)=NULL
list(tmp)
})
ans1 = forderv(DT, by=cols, order=orders, na.last=NA) # nalast=NA here.
test(1252.0 + test_no*0.001, ans1[ans1 != 0], with(DT, eval(ll)),
context=sprintf(
"seed = %d; setorder(DT, %s)",
seed, toString(paste0(fifelse(orders == 1L, "", "-"), cols))))
}
}
}
ans = NULL
if (nfail > oldnfail) cat(seedInfo, "\n") # to reproduce

###############
# turning off tolerance for UPCs (> 11 s.f. stored in numeric), #342
Expand Down
Loading