Skip to content

Commit e665d2a

Browse files
ben-schwenBenjamin SchwendingerMichaelChirico
authored
gshift cannot eval variables used in [ (#5548)
* add fix for escaping gforce using [variables in function call * push * escape gshift * update * add fix * add test for coverage * add news * update shift tests * move tests * update tests * simplify tests * simplify * working version * add comments * update test info * add dropped DT * add raw tests * update tests * add more tests for nested jsub * add more tests * make qforce_ok more robust * update comments * simplify logical * remove comment since n is used * update eval environment * add Jans testcase * add helper functions * remove unused assignments * update test nums * escape evaluating values present int x * update eval of vars * add spaces * overwrite call * all.vars==0L and unique=FALSE * add comment about noCall_noVars * shorten switch Co-authored-by: Michael Chirico <[email protected]> * add extra check to noCall_noVars * rename noCall_noVars * simplify switch * update match.call gweighted.mean * simplify * rename zip and name args * remove redundant switch() entry * deduplicate code * update g[_ok signature * whitespace suggestion * just check if 'give.names' in names * Change check= to check_singleton= * name argument * update check constantish * update NEWS item * standardize spelling * infix spacing --------- Co-authored-by: Benjamin Schwendinger <[email protected]> Co-authored-by: Michael Chirico <[email protected]> Co-authored-by: Michael Chirico <[email protected]>
1 parent 0fa568e commit e665d2a

File tree

4 files changed

+156
-47
lines changed

4 files changed

+156
-47
lines changed

‎NEWS.md‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -168,12 +168,12 @@
168168

169169
28. `setkey()` now supports type `raw` as value columns (not as key columns), [#5100](https://github.com/Rdatatable/data.table/issues/5100). Thanks Hugh Parsonage for requesting, and Benjamin Schwendinger for the PR.
170170

171-
29. `shift()` is now optimised by group, [#1534](https://github.com/Rdatatable/data.table/issues/1534). Thanks to Gerhard Nachtmann for requesting, and Benjamin Schwendinger for the PR.
171+
29. `shift()` is now optimized by group, [#1534](https://github.com/Rdatatable/data.table/issues/1534). Thanks to Gerhard Nachtmann for requesting, and Benjamin Schwendinger for the PR. Thanks to @neovom for testing dev and filing a bug report, [#5547](https://github.com/Rdatatable/data.table/issues/5547) which was fixed before release. This helped also in improving the logic for when to turn on optimization by group in general, making it more robust.
172172

173173
```R
174174
N = 1e7
175175
DT = data.table(x=sample(N), y=sample(1e6,N,TRUE))
176-
shift_no_opt = shift # different name not optimised as a way to compare
176+
shift_no_opt = shift # different name not optimized as a way to compare
177177
microbenchmark(
178178
DT[, c(NA, head(x,-1)), y],
179179
DT[, shift_no_opt(x, 1, type="lag"), y],
@@ -263,7 +263,7 @@
263263
# 2: 2 4 b
264264
```
265265

266-
34. `weighted.mean()` is now optimised by group, [#3977](https://github.com/Rdatatable/data.table/issues/3977). Thanks to @renkun-ken for requesting, and Benjamin Schwendinger for the PR.
266+
34. `weighted.mean()` is now optimized by group, [#3977](https://github.com/Rdatatable/data.table/issues/3977). Thanks to @renkun-ken for requesting, and Benjamin Schwendinger for the PR.
267267

268268
35. `as.xts.data.table()` now supports non-numeric xts coredata matrixes, [5268](https://github.com/Rdatatable/data.table/issues/5268). Existing numeric only functionality is supported by a new `numeric.only` parameter, which defaults to `TRUE` for backward compatability and the most common use case. To convert non-numeric columns, set this parameter to `FALSE`. Conversions of `data.table` columns to a `matrix` now uses `data.table::as.matrix`, with all its performance benefits. Thanks to @ethanbsmith for the report and fix.
269269

‎R/data.table.R‎

Lines changed: 66 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -1739,41 +1739,84 @@ replace_dot_alias = function(e) {
17391739
GForce = FALSE
17401740
} else {
17411741
# Apply GForce
1742+
# GForce needs to evaluate all arguments not present in the data.table before calling C part #5547
1743+
# Safe cases: variables [i], calls without variables [c(0,1), list(1)] # TODO extend this list
1744+
# Unsafe cases: functions containing variables [c(i), abs(i)], .N
1745+
is_constantish = function(expr, check_singleton=FALSE) {
1746+
if (!is.call(expr)) {
1747+
return(!dotN(expr))
1748+
}
1749+
if (check_singleton) {
1750+
return(FALSE)
1751+
}
1752+
# calls are allowed <=> there's no SYMBOLs in the sub-AST
1753+
return(length(all.vars(expr, max.names=1L, unique=FALSE)) == 0L)
1754+
}
1755+
.gshift_ok = function(q) {
1756+
q = match.call(shift, q)
1757+
is_constantish(q[["n"]]) &&
1758+
is_constantish(q[["fill"]]) &&
1759+
is_constantish(q[["type"]]) &&
1760+
!"give.names" %chin% names(q)
1761+
}
1762+
.ghead_ok = function(q) {
1763+
length(q) == 3L &&
1764+
is_constantish(q[[3L]], check_singleton = TRUE)
1765+
}
1766+
`.g[_ok` = function(q, x) {
1767+
length(q) == 3L &&
1768+
is_constantish(q[[3L]], check_singleton = TRUE) &&
1769+
(q[[1L]] != "[[" || eval(call('is.atomic', q[[2L]]), envir=x)) &&
1770+
eval(q[[3L]], parent.frame(3L)) > 0L
1771+
}
1772+
.gweighted.mean_ok = function(q, x) { #3977
1773+
q = match.call(gweighted.mean, q)
1774+
is_constantish(q[["na.rm"]]) &&
1775+
(is.null(q[["w"]]) || eval(call('is.numeric', q[["w"]]), envir=x))
1776+
}
17421777
.gforce_ok = function(q) {
17431778
if (dotN(q)) return(TRUE) # For #334
17441779
# run GForce for simple f(x) calls and f(x, na.rm = TRUE)-like calls where x is a column of .SD
17451780
# is.symbol() is for #1369, #1974 and #2949
1746-
if (!(is.call(q) && is.symbol(q[[1L]]) && is.symbol(q[[2L]]) && (q1 <- q[[1L]]) %chin% gfuns)) return(FALSE)
1781+
if (!(is.call(q) && is.symbol(q[[1L]]) && is.symbol(q[[2L]]) && (q[[1L]]) %chin% gfuns)) return(FALSE)
17471782
if (!(q2 <- q[[2L]]) %chin% names(SDenv$.SDall) && q2 != ".I") return(FALSE) # 875
1748-
if ((length(q)==2L || (!is.null(names(q)) && startsWith(names(q)[3L], "na")))) return(TRUE)
1783+
if (length(q)==2L || (!is.null(names(q)) && startsWith(names(q)[3L], "na") && is_constantish(q[[3L]]))) return(TRUE)
17491784
# ^^ base::startWith errors on NULL unfortunately
1750-
if (length(q)>=2L && q[[1L]] == "shift") {
1751-
q_named = match.call(shift, q)
1752-
if (!is.call(q_named[["fill"]]) && is.null(q_named[["give.names"]])) return(TRUE)
1753-
}
1754-
if (length(q)>=3L && q[[1L]] == "weighted.mean") return(TRUE) #3977
1755-
# otherwise there must be three arguments
1756-
length(q)==3L && length(q3 <- q[[3L]])==1L && is.numeric(q3) &&
1757-
( (q1 %chin% c("head", "tail")) || ((q1 == "[" || (q1 == "[[" && eval(call('is.atomic', q[[2L]]), envir=x))) && q3>0L) )
1785+
switch(as.character(q[[1L]]),
1786+
"shift" = .gshift_ok(q),
1787+
"weighted.mean" = .gweighted.mean_ok(q, x),
1788+
"tail" = , "head" = .ghead_ok(q),
1789+
"[[" = , "[" = `.g[_ok`(q, x),
1790+
FALSE
1791+
)
17581792
}
17591793
if (jsub[[1L]]=="list") {
17601794
GForce = TRUE
17611795
for (ii in seq.int(from=2L, length.out=length(jsub)-1L)) {
17621796
if (!.gforce_ok(jsub[[ii]])) {GForce = FALSE; break}
17631797
}
17641798
} else GForce = .gforce_ok(jsub)
1799+
gforce_jsub = function(x, names_x) {
1800+
x[[1L]] = as.name(paste0("g", x[[1L]]))
1801+
# gforce needs to evaluate arguments before calling C part TODO: move the evaluation into gforce_ok
1802+
# do not evaluate vars present as columns in x
1803+
if (length(x) >= 3L) {
1804+
for (i in 3:length(x)) {
1805+
if (is.symbol(x[[i]]) && !(x[[i]] %chin% names_x)) x[[i]] = eval(x[[i]], parent.frame(2L)) # tests 1187.2 & 1187.4
1806+
}
1807+
}
1808+
x
1809+
}
17651810
if (GForce) {
17661811
if (jsub[[1L]]=="list")
17671812
for (ii in seq_along(jsub)[-1L]) {
17681813
if (dotN(jsub[[ii]])) next; # For #334
1769-
jsub[[ii]][[1L]] = as.name(paste0("g", jsub[[ii]][[1L]]))
1770-
if (length(jsub[[ii]])>=3L && is.symbol(jsub[[ii]][[3L]]) && !(jsub[[ii]][[3L]] %chin% sdvars)) jsub[[ii]][[3L]] = eval(jsub[[ii]][[3L]], parent.frame()) # tests 1187.2 & 1187.4
1814+
jsub[[ii]] = gforce_jsub(jsub[[ii]], names_x)
17711815
}
17721816
else {
17731817
# adding argument to ghead/gtail if none is supplied to g-optimized head/tail
17741818
if (length(jsub) == 2L && jsub[[1L]] %chin% c("head", "tail")) jsub[["n"]] = 6L
1775-
jsub[[1L]] = as.name(paste0("g", jsub[[1L]]))
1776-
if (length(jsub)>=3L && is.symbol(jsub[[3L]]) && !(jsub[[3L]] %chin% sdvars)) jsub[[3L]] = eval(jsub[[3L]], parent.frame()) # tests 1187.3 & 1187.5
1819+
jsub = gforce_jsub(jsub, names_x)
17771820
}
17781821
if (verbose) catf("GForce optimized j to '%s'\n", deparse(jsub, width.cutoff=200L, nlines=1L))
17791822
} else if (verbose) catf("GForce is on, left j unchanged\n");
@@ -1868,7 +1911,7 @@ replace_dot_alias = function(e) {
18681911
if (!is.symbol(jsub)) {
18691912
headTail_arg = function(q) {
18701913
if (length(q)==3L && length(q3 <- q[[3L]])==1L && is.numeric(q3) &&
1871-
(q1 <- q[[1L]]) %chin% c("ghead", "gtail") && q3!=1) q3
1914+
(q[[1L]]) %chin% c("ghead", "gtail") && q3!=1) q3
18721915
else 0
18731916
}
18741917
if (jsub[[1L]] == "list"){
@@ -1882,6 +1925,11 @@ replace_dot_alias = function(e) {
18821925
g = lapply(g, rep.int, times=grplens)
18831926
} else if (.is_nrows(jsub)) {
18841927
g = lapply(g, rep.int, times=len__)
1928+
# unpack list of lists for nrows functions
1929+
zip_items = function(ll) do.call(mapply, c(list(FUN = c), ll, SIMPLIFY=FALSE, USE.NAMES=FALSE))
1930+
if (all(vapply_1b(ans, is.list))) {
1931+
ans = lapply(ans, zip_items)
1932+
}
18851933
}
18861934
ans = c(g, ans)
18871935
} else {
@@ -3000,13 +3048,13 @@ rleidv = function(x, cols=seq_along(x), prefix=NULL) {
30003048
gfuns = c("[", "[[", "head", "tail", "first", "last", "sum", "mean", "prod",
30013049
"median", "min", "max", "var", "sd", ".N", "shift", "weighted.mean") # added .N for #334
30023050
`g[` = `g[[` = function(x, n) .Call(Cgnthvalue, x, as.integer(n)) # n is of length=1 here.
3003-
ghead = function(x, n) .Call(Cghead, x, as.integer(n)) # n is not used at the moment
3004-
gtail = function(x, n) .Call(Cgtail, x, as.integer(n)) # n is not used at the moment
3051+
ghead = function(x, n) .Call(Cghead, x, as.integer(n))
3052+
gtail = function(x, n) .Call(Cgtail, x, as.integer(n))
30053053
gfirst = function(x) .Call(Cgfirst, x)
30063054
glast = function(x) .Call(Cglast, x)
30073055
gsum = function(x, na.rm=FALSE) .Call(Cgsum, x, na.rm)
30083056
gmean = function(x, na.rm=FALSE) .Call(Cgmean, x, na.rm)
3009-
gweighted.mean = function(x, w, na.rm=FALSE) {
3057+
gweighted.mean = function(x, w, ..., na.rm=FALSE) {
30103058
if (missing(w)) gmean(x, na.rm)
30113059
else {
30123060
if (na.rm) { # take those indices out of the equation by setting them to 0

‎inst/tests/tests.Rraw‎

Lines changed: 62 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6736,6 +6736,18 @@ test(1463.69, shift(x, -6, type="cyclic"), shift(x, -1, type="cyclic"))
67366736
# test warning
67376737
test(1463.70, shift(x, 1, fill=1, type="cyclic"), c(5L, 1L:4L), warning="Provided argument fill=1 will be ignored since type='shift'.")
67386738

6739+
# test raw #5547
6740+
x=as.raw(1:5)
6741+
test(1463.71, shift(x,1L), as.raw(c(0L, 1:4)))
6742+
test(1463.72, shift(x,1:2), list(as.raw(c(0L, 1:4)), as.raw(c(0L, 0L, 1:3))))
6743+
test(1463.73, shift(x,1L, fill=0L), as.raw(c(0L, 1:4)))
6744+
test(1463.74, shift(x,1L, type="lead"), as.raw(c(2:5, 0L)))
6745+
test(1463.75, shift(x,1:2, type="lead"), list(as.raw(c(2:5, 0L)), as.raw(c(3:5, 0L, 0L))))
6746+
test(1463.76, shift(x,1L, fill=0L,type="lead"), as.raw(c(2:5, 0L)))
6747+
test(1463.77, shift(x,1L, type="cyclic"), as.raw(c(5, 1:4)))
6748+
test(1463.78, shift(x,1:2, type="cyclic"), list(as.raw(c(5, 1:4)), as.raw(c(4:5, 1:3))))
6749+
test(1463.79, shift(x,-1L, type="cyclic"), as.raw(c(2:5, 1)))
6750+
test(1463.80, shift(x,-(1:2),type="cyclic"), list(as.raw(c(2:5, 1)), as.raw(c(3:5,1:2))))
67396751

67406752
# FR #686
67416753
DT = data.table(a=rep(c("A", "B", "C", "A", "B"), c(2,2,3,1,2)), foo=1:10)
@@ -13628,7 +13640,8 @@ test(1963.07, shift(DT, -1:1),
1362813640
c(NA, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L, 2L)))
1362913641
## some coverage tests for good measure
1363013642
test(1963.08, shift(DT$x, type = 'some_other_type'), error='should be one of.*lag.*lead')
13631-
test(1963.09, shift(as.raw(0:1)), error = "Type 'raw' is not supported")
13643+
test(1963.09, shift(as.raw(0:1)), as.raw(c(0,0)))
13644+
test(1963.095, shift(list(expression(1))), error = "Type 'expression' is not supported")
1363213645
test(1963.10, shift(DT, -1:1, type="shift", give.names = TRUE), # new type="shift" #3223
1363313646
ans <- list(`x_shift_-1` = c(2L, 3L, 4L, 5L, 6L, 7L, 8L, 9L, 10L, NA),
1363413647
x_shift_0 = 1:10,
@@ -17946,6 +17959,12 @@ test(2231.50, DT[, weighted.mean(x, w, na.rm=TRUE), g, verbose=TRUE], data.table
1794617959
DT = data.table(x=c(1L,NA,NaN,3L,4L,5L,5L,6L), w=c(1L,NaN,NA,1L,2L,2L,2L,2L), g=rep(1L:2L, each=4L))
1794717960
test(2231.51, DT[, weighted.mean(x, w, na.rm=FALSE), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(NA, 5)), output="GForce optimized j to")
1794817961
test(2231.52, DT[, weighted.mean(x, w, na.rm=TRUE), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(2, 5)), output="GForce optimized j to")
17962+
# let wrongly named arguments get lost in ellipsis #5543
17963+
DT = data.table(x=c(3.7,3.3,3.5,2.8), w=c(5,5,4,1), g=1L)
17964+
test(2231.61, DT[, weighted.mean(x, w), g, verbose=TRUE], data.table(g=1L, V1=3.45+1/300), output="GForce optimized j to")
17965+
test(2231.62, DT[, weighted.mean(x, weight=w), g, verbose=TRUE], data.table(g=1L, V1=3.325), output="GForce optimized j to")
17966+
test(2231.63, DT[, weighted.mean(x, w, na.rm=FALSE), g], DT[, stats::weighted.mean(x, w, na.rm=FALSE), g])
17967+
test(2231.64, DT[, weighted.mean(x, weight=w, na.rm=TRUE)], DT[, stats::weighted.mean(x, weight=w, na.rm=TRUE)])
1794917968
options(old)
1795017969

1795117970
# cols argument for unique.data.table, #5243
@@ -18184,3 +18203,45 @@ test(2241.14, r, data.table(id=1:2, x=c(5L,2L)))
1818418203
DT = data.table(a=1, b=2, c=3)
1818518204
test(2242.1, DT[, .SD, .SDcols=2-1], DT[, .(a)])
1818618205
test(2242.2, DT[, .SD, .SDcols=length(DT)-1], DT[, .SD, .SDcols=2])
18206+
18207+
# turn off GForce where arguments are calls but still allow variables, #5547
18208+
options(datatable.optimize=2L)
18209+
dt = data.table(x=c("a","b","c","d"), y=c(1L,1L,2L,2L))
18210+
i = c(0,1)
18211+
j = 1L
18212+
t = "lead"
18213+
f = shift
18214+
test(2243.01, dt[, shift(x, i, type=t), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead"), by=y], output="GForce optimized j to")
18215+
test(2243.02, dt[, shift(x, abs(c(0,1)), type=t), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead"), by=y], output="GForce optimized j to")
18216+
test(2243.03, dt[, shift(x, abs(i), type=t), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead"), by=y], output="GForce FALSE")
18217+
test(2243.04, dt[, shift(x, i, type=as.character(t)), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead"), by=y], output="GForce FALSE")
18218+
test(2243.05, dt[, shift(x, i, type=t, fill=1), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead", fill=1), by=y], output="GForce optimized j to")
18219+
test(2243.06, dt[, shift(x, i, type=t, fill=abs(1)), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead", fill=1), by=y], output="GForce optimized j to")
18220+
test(2243.07, dt[, shift(x, i, type=t, fill=abs(j)), by=y, verbose=TRUE], dt[, f(x, c(0,1), type="lead", fill=1), by=y], output="GForce FALSE")
18221+
test(2243.08, dt[, .(shift(x, i, type=t)), by=y, verbose=TRUE], dt[, .(f(x, c(0,1), type="lead")), by=y], output="GForce optimized j to")
18222+
# GForce only var or call without vars as n of head/tail/"["(x, n)
18223+
dt = data.table(id=c(1L,1L,2L), v=1:3)
18224+
j = 1L
18225+
test(2243.11, dt[, head(v, j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(1L,3L)), output="GForce optimized j to")
18226+
test(2243.12, dt[, tail(v, j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(2L,3L)), output="GForce optimized j to")
18227+
test(2243.13, dt[, v[j], id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(1L,3L)), output="GForce optimized j to")
18228+
# GForce only var or call without vars as na.rm of sum, mean, median, prod, min, max, var
18229+
j = FALSE
18230+
test(2243.21, dt[, sum(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(3L,3L)), output="GForce optimized j to")
18231+
test(2243.22, dt[, mean(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(1.5,3)), output="GForce optimized j to")
18232+
test(2243.23, dt[, median(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(1.5,3)), output="GForce optimized j to")
18233+
test(2243.24, dt[, prod(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(2,3)), output="GForce optimized j to")
18234+
test(2243.25, dt[, min(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(1L,3L)), output="GForce optimized j to")
18235+
test(2243.26, dt[, max(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(2L,3L)), output="GForce optimized j to")
18236+
test(2243.27, dt[, var(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(0.5,NA)), output="GForce optimized j to")
18237+
test(2243.28, dt[, sd(v, na.rm=j), id, verbose=TRUE], data.table(id=c(1L,2L), V1=c(sqrt(0.5),NA)), output="GForce optimized j to")
18238+
dt = data.table(g=1:2, y=1:4)
18239+
j = TRUE
18240+
test(2243.31, dt[, sum(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(4L,6L)), output="GForce FALSE")
18241+
test(2243.32, dt[, mean(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(2,3)), output="GForce FALSE")
18242+
test(2243.33, dt[, median(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(2,3)), output="GForce FALSE")
18243+
test(2243.34, dt[, prod(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(3,8)), output="GForce FALSE")
18244+
test(2243.35, dt[, min(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(1L,2L)), output="GForce FALSE")
18245+
test(2243.36, dt[, max(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(3L,4L)), output="GForce FALSE")
18246+
test(2243.37, dt[, var(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(2,2)), output="GForce FALSE")
18247+
test(2243.38, dt[, sd(y, na.rm=as.logical(j)), g, verbose=TRUE], data.table(g=c(1L,2L), V1=c(sqrt(c(2,2)))), output="GForce FALSE")

‎src/shift.c‎

Lines changed: 25 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -42,11 +42,11 @@ SEXP shift(SEXP obj, SEXP k, SEXP fill, SEXP type)
4242
R_xlen_t xrows = xlength(elem);
4343
SEXP thisfill = PROTECT(coerceAs(fill, elem, ScalarLogical(0))); nprotect++; // #4865 use coerceAs for type coercion
4444
switch (TYPEOF(elem)) {
45-
case INTSXP : {
45+
case INTSXP: case LGLSXP: {
4646
const int ifill = INTEGER(thisfill)[0];
4747
for (int j=0; j<nk; j++) {
4848
SEXP tmp;
49-
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(INTSXP, xrows) );
49+
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(TYPEOF(elem), xrows) );
5050
const int *restrict ielem = INTEGER(elem);
5151
int *restrict itmp = INTEGER(tmp);
5252
size_t thisk = cycle ? abs(kd[j]) % xrows : MIN(abs(kd[j]), xrows);
@@ -114,29 +114,6 @@ SEXP shift(SEXP obj, SEXP k, SEXP fill, SEXP type)
114114
copyMostAttrib(elem, tmp);
115115
}
116116
} break;
117-
case LGLSXP : {
118-
const int lfill = LOGICAL(thisfill)[0];
119-
for (int j=0; j<nk; j++) {
120-
SEXP tmp;
121-
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(LGLSXP, xrows) );
122-
const int *restrict lelem = LOGICAL(elem);
123-
int *restrict ltmp = LOGICAL(tmp);
124-
size_t thisk = cycle ? abs(kd[j]) % xrows : MIN(abs(kd[j]), xrows);
125-
size_t tailk = xrows-thisk;
126-
if (((stype == LAG || stype == CYCLIC) && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
127-
if (tailk > 0) memmove(ltmp+thisk, lelem, tailk*size);
128-
if (cycle) {
129-
if (thisk > 0) memmove(ltmp, lelem+tailk, thisk*size);
130-
} else for (int m=0; m<thisk; m++) ltmp[m] = cycle ? lelem[m+tailk] : lfill;
131-
} else {
132-
if (tailk > 0) memmove(ltmp, lelem+thisk, tailk*size);
133-
if (cycle) {
134-
if (thisk > 0) memmove(ltmp+tailk, lelem, thisk*size);
135-
} else for (int m=tailk; m<xrows; m++) ltmp[m] = cycle ? lelem[m-tailk] : lfill;
136-
}
137-
copyMostAttrib(elem, tmp);
138-
}
139-
} break;
140117
case STRSXP : {
141118
const SEXP sfill = STRING_ELT(thisfill, 0);
142119
for (int j=0; j<nk; j++) {
@@ -167,6 +144,29 @@ SEXP shift(SEXP obj, SEXP k, SEXP fill, SEXP type)
167144
copyMostAttrib(elem, tmp);
168145
}
169146
} break;
147+
case RAWSXP : {
148+
const Rbyte rfill = RAW(thisfill)[0];
149+
for (int j=0; j<nk; j++) {
150+
SEXP tmp;
151+
SET_VECTOR_ELT(ans, i*nk+j, tmp=allocVector(RAWSXP, xrows) );
152+
const Rbyte *restrict delem = RAW(elem);
153+
Rbyte *restrict dtmp = RAW(tmp);
154+
size_t thisk = cycle ? abs(kd[j]) % xrows : MIN(abs(kd[j]), xrows);
155+
size_t tailk = xrows-thisk;
156+
if (((stype == LAG || stype == CYCLIC) && kd[j] >= 0) || (stype == LEAD && kd[j] < 0)) {
157+
if (tailk > 0) memmove(dtmp+thisk, delem, tailk*size);
158+
if (cycle) {
159+
if (thisk > 0) memmove(dtmp, delem+tailk, thisk*size);
160+
} else for (int m=0; m<thisk; m++) dtmp[m] = rfill;
161+
} else {
162+
if (tailk > 0) memmove(dtmp, delem+thisk, tailk*size);
163+
if (cycle) {
164+
if (thisk > 0) memmove(dtmp+tailk, delem, thisk*size);
165+
} else for (int m=tailk; m<xrows; m++) dtmp[m] = rfill;
166+
}
167+
copyMostAttrib(elem, tmp);
168+
}
169+
} break;
170170
default :
171171
error(_("Type '%s' is not supported"), type2char(TYPEOF(elem)));
172172
}

0 commit comments

Comments
 (0)