From 4f5ac7abb6144d4cd7269936a547e77bbcdd4cc0 Mon Sep 17 00:00:00 2001 From: Benjamin Schwendinger Date: Thu, 27 Aug 2026 14:08:06 +0200 Subject: [PATCH] add na.rm capabilites --- NEWS.md | 2 + R/data.table.R | 17 ++- R/last.R | 34 ++++- inst/tests/optimize.Rraw | 53 ++++++- man/last.Rd | 16 +- src/data.table.h | 4 +- src/gsumm.c | 320 +++++++++++++++++++++++++++++---------- 7 files changed, 345 insertions(+), 101 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1db2d95578..11428ff8b2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -50,6 +50,8 @@ 14. `first()` and `last()` with `n>1` are now GForce optimized (e.g. `DT[, first(x, n=3), by=grp]`), [#4239](https://github.com/Rdatatable/data.table/issues/4239). Also adds a new internal `gforce_dynamic` mechanism to track any GForce result which returns other than exactly 1 row per group so that results are correctly replicated. Thanks to @nbenn for the report and @ben-schwen and @mattdowle for the implementation. +15. `first()` and `last()` gain an `na.rm` argument to skip missing values (e.g. `DT[, first(x, na.rm=TRUE), by=grp]`), [#4239](https://github.com/Rdatatable/data.table/issues/4239) and [#4446](https://github.com/Rdatatable/data.table/issues/4446). A group with no non-missing values returns `NA` for `n=1` (matching `median()`/`var()`), or zero rows for `n>1`. GForce optimized. Thanks to @nbenn and @MichaelChirico for the reports and @ben-schwen and @mattdowle for the implementation. + ### BUG FIXES 1. `fread()` with `skip=0` and `(header=TRUE|FALSE)` no longer skips the first row when it has fewer fields than subsequent rows, [#7463](https://github.com/Rdatatable/data.table/issues/7463). Thanks @emayerhofer for the report and @ben-schwen for the fix. diff --git a/R/data.table.R b/R/data.table.R index 52bf50888a..d610e7e5ab 100644 --- a/R/data.table.R +++ b/R/data.table.R @@ -3337,8 +3337,8 @@ gfuns = c(gdtfuns, `g[` = `g[[` = function(x, n) .Call(Cgnthvalue, x, as.integer(n)) # n is of length=1 here. ghead = function(x, n) .Call(Cghead, x, as.integer(n)) gtail = function(x, n) .Call(Cgtail, x, as.integer(n)) -gfirst = function(x, n=1L) .Call(Cgfirst, x, as.integer(n)) -glast = function(x, n=1L) .Call(Cglast, x, as.integer(n)) +gfirst = function(x, n=1L, na.rm=FALSE) .Call(Cgfirst, x, as.integer(n), na.rm) +glast = function(x, n=1L, na.rm=FALSE) .Call(Cglast, x, as.integer(n), na.rm) gsum = function(x, na.rm=FALSE) .Call(Cgsum, x, na.rm) gmean = function(x, na.rm=FALSE) .Call(Cgmean, x, na.rm) gweighted.mean = function(x, w, ..., na.rm=FALSE) { @@ -3390,11 +3390,14 @@ is_constantish = function(q, check_singleton=FALSE) { length(q) == 3L && is_constantish(q[[3L]], check_singleton = TRUE) } -# first(x, n) / last(x, n) with n>1, #4446 #4239. +# first(x, n=, na.rm=) / last(x, n=, na.rm=), #4446 #4239. Called only when length(q)>=3 +# (the length(q)==2L case, i.e. first(x)/last(x), is already handled earlier in .gforce_ok). .gfirstlast_ok = function(q, envir) { - length(q) == 3L && - is_constantish(q[[3L]], check_singleton = TRUE) && - is.numeric(n <- eval(q[[3L]], envir)) && length(n)==1L && !is.na(n) && n>=1 + q = match.call(first, q) # first's signature is the same as last's: first(x, n=1L, na.rm=FALSE, ...) + (is.null(q[["n"]]) || (is_constantish(q[["n"]], check_singleton=TRUE) && + is.numeric(n <- eval(q[["n"]], envir)) && length(n)==1L && !is.na(n) && n>=1)) && + (is.null(q[["na.rm"]]) || (is_constantish(q[["na.rm"]], check_singleton=TRUE) && + isTRUEorFALSE(eval(q[["na.rm"]], envir)))) } `.g[_ok` = function(q, x, envir=parent.frame(3L)) { length(q) == 3L && @@ -3449,7 +3452,7 @@ is_constantish = function(q, check_singleton=FALSE) { if (!is.null(q1)) { q2 = .unwrap_conversions(q[[2L]]) if (!is.symbol(q2) || (!q2 %chin% names(x) && q2 != ".I")) return(FALSE) - if (length(q)==2L || (.arg_is_narm(q) && is_constantish(q[[3L]]) && + if (length(q)==2L || (length(q)==3L && .arg_is_narm(q) && is_constantish(q[[3L]]) && !(is.symbol(q[[3L]]) && q[[3L]] %chin% names(x)))) return(TRUE) return(switch(as.character(q1), "shift" = .gshift_ok(q), diff --git a/R/last.R b/R/last.R index a93ec31731..f7bdf50170 100644 --- a/R/last.R +++ b/R/last.R @@ -2,15 +2,20 @@ # for xts class objects it will dispatch to xts::last # reworked to avoid loading xts namespace (#3857) then again to fix dispatching of xts class (#4053) # nocov start. Tests 19.* in other.Rraw, not in the main suite. -last = function(x, n=1L, ...) { +last = function(x, n=1L, na.rm=FALSE, ...) { verbose = isTRUE(getOption("datatable.verbose", FALSE)) if (!inherits(x, "xts")) { if (nargs()>1L) { if ("package:xts" %chin% search()) { if (verbose) catf("%s: using %s: %s\n", "last", "xts::last", "!is.xts(x) & nargs>1 & 'package:xts'%in%search()") - xts::last(x, n=n, ...) + xts::last(x, n=n, na.rm=na.rm, ...) + } else if (is.null(dim(x)) && !is.data.frame(x)) { + if (verbose) + catf("%s: using %s: %s\n", "last", "'.firstlast'", "!is.xts(x) & nargs>1 & is.null(dim(x)) & !is.data.frame(x)") + .firstlast(x, n=n, first=FALSE, na.rm=na.rm) } else { + if (!isFALSE(na.rm)) stopf("na.rm=TRUE is not currently supported for '%s'", class(x)[1L]) # nocov start if (verbose) catf("%s: using %s: %s\n", "last", "utils::tail", "!is.xts(x) & nargs>1 & !'package:xts'%in%search()") @@ -39,19 +44,24 @@ last = function(x, n=1L, ...) { stopf("'xts' class passed to %s function but 'xts' is not available, you should have 'xts' installed already", "data.table::last") # nocov if (verbose) catf("%s: using %s: %s\n", "last", "xts::last", "is.xts(x)") - xts::last(x, n=n, ...) + xts::last(x, n=n, na.rm=na.rm, ...) } } -first = function(x, n=1L, ...) { +first = function(x, n=1L, na.rm=FALSE, ...) { verbose = isTRUE(getOption("datatable.verbose", FALSE)) if (!inherits(x, "xts")) { if (nargs()>1L) { if ("package:xts" %chin% search()) { if (verbose) catf("%s: using %s: %s\n", "first", "xts::first", "!is.xts(x) & nargs>1 & 'package:xts'%in%search()") - xts::first(x, n=n, ...) + xts::first(x, n=n, na.rm=na.rm, ...) + } else if (is.null(dim(x)) && !is.data.frame(x)) { + if (verbose) + catf("%s: using %s: %s\n", "first", "'.firstlast'", "!is.xts(x) & nargs>1 & is.null(dim(x)) & !is.data.frame(x)") + .firstlast(x, n=n, first=TRUE, na.rm=na.rm) } else { + if (!isFALSE(na.rm)) stopf("na.rm=TRUE is not currently supported for '%s'", class(x)[1L]) # nocov start if (verbose) catf("%s: using %s: %s\n", "first", "utils::head", "!is.xts(x) & nargs>1 & !'package:xts'%in%search()") @@ -80,7 +90,19 @@ first = function(x, n=1L, ...) { stopf("'xts' class passed to %s function but 'xts' is not available, you should have 'xts' installed already", "data.table::first") # nocov if (verbose) catf("%s: using %s: %s\n", "first", "xts::first", "is.xts(x)") - xts::first(x, n=n, ...) + xts::first(x, n=n, na.rm=na.rm, ...) } } # nocov end + +.firstlast = function(x, n, first, na.rm) { + if (!isTRUEorFALSE(na.rm)) stopf("'%s' must be TRUE or FALSE", "na.rm") + if (!na.rm) return(if (first) utils::head(x, n=n) else utils::tail(x, n=n)) + if (!length(x)) return(x) + # matches 'missing' used for GForce first()/last() + # for a list, an element is missing when it is NULL or a length-1 logical NA, not (only) when is.na() + isna = if (is.list(x)) vapply(x, function(el) is.null(el) || (is.logical(el) && length(el)==1L && is.na(el)), FALSE) else is.na(x) + nna = which(!isna) + if (!length(nna)) return(if (n==1L) x[NA_integer_] else x[0L]) + x[if (first) utils::head(nna, n) else utils::tail(nna, n)] +} diff --git a/inst/tests/optimize.Rraw b/inst/tests/optimize.Rraw index 6687961d8d..5685f12eea 100644 --- a/inst/tests/optimize.Rraw +++ b/inst/tests/optimize.Rraw @@ -522,4 +522,55 @@ test(2285.01, optimize=opt, DT5[, .(shift(x), mean(x)), by=g, verbose=TRUE], test(2285.02, copy(DT5)[, c("s","m") := .(shift(x), mean(x)), by=g], data.table(g=c(1,1,1,2,2), x=1:5, y=1:5, s=c(NA,1L,2L,NA,4L), m=c(2,2,2,4.5,4.5))) test(2285.03, optimize=opt, DT5[, .(head(x,2), head(y,3)), by=g], error="Supplied 2 items for column 1 of group 1 which has 3 rows") -# head/tail with := and mismatched n: previously errored (Supplied N items...), now aligns/pads instead, see tests 2233.28/2233.29 in tests.Rraw + +# first()/last() gain na.rm=, #4239 #4446. GForce optimized (gfirst()/glast()) for both the simple +# (n=1, always exactly 1 row per group) and n>1 (data-dependent rows per group, using the same +# gforce_dynamic mechanism as n>1 without na.rm) cases. +opt = 0:2 +DT = data.table(g=c(1,1,1,2,2), x=c(1,NA,3,NA,5), y=11:15) +out = c("GForce FALSE", "GForce FALSE", "GForce optimized j") +test(2286.01, optimize=opt, DT[, first(x, na.rm=TRUE), by=g, verbose=TRUE], + data.table(g=c(1,2), V1=c(1,5)), output=out) +test(2286.02, optimize=opt, DT[, .(first(x, na.rm=TRUE), mean(y)), by=g, verbose=TRUE], + data.table(g=c(1,2), V1=c(1,5), V2=c(12,14.5)), output=out) +test(2286.03, optimize=opt, DT[, last(x, na.rm=TRUE), by=g, verbose=TRUE], + data.table(g=c(1,2), V1=c(3,5)), output=out) +test(2286.04, optimize=opt, DT[, first(x, n=2, na.rm=TRUE), by=g, verbose=TRUE], + data.table(g=c(1,1,2), V1=c(1,3,5)), output=out) +test(2286.05, optimize=opt, DT[, last(x, n=2, na.rm=TRUE), by=g], + data.table(g=c(1,1,2), V1=c(1,3,5))) +test(2286.06, optimize=opt, DT[, .(first(x, n=2, na.rm=TRUE), mean(y)), by=g], + data.table(g=c(1,1,2), V1=c(1,3,5), V2=c(12,12,14.5))) +test(2286.07, optimize=opt, copy(DT)[, v := first(x, na.rm=TRUE), by=g, verbose=TRUE], + data.table(g=c(1,1,1,2,2), x=c(1,NA,3,NA,5), y=11:15, v=c(1,1,1,5,5)), output=out) +test(2286.08, DT[, v := first(x, n=2, na.rm=TRUE), by=g], + error="Supplied 3 items to be assigned to 5 items of column 'v'.") + +# all-NA group returns NA, like gmedian/gvar do for insufficient data, not an empty/dropped group +DT = data.table(g=c(1,1,2,2), x=c(NA,NA,3,4)) +test(2286.11, optimize=opt, DT[, first(x, na.rm=TRUE), by=g], + data.table(g=c(1,2), V1=c(NA,3))) +test(2286.12, optimize=opt, DT[, first(x, n=2, na.rm=TRUE), by=g], + data.table(g=2, V1=c(3,4))) +DT = data.table(g=c(1,1,1,1), x=c(1,2,3,4), y=c(NA,6,7,8)) +test(2286.13, optimize=opt, DT[, .(first(x, n=2), first(y, n=3, na.rm=TRUE)), by=g], + error="Supplied 2 items for column 1 of group 1 which has 3 rows") +DT = data.table(g=c(1,1,1,1), x=c(1,NA,3,4), y=c(NA,NA,NA,9)) +test(2286.14, optimize=opt, DT[, .(first(x, n=2, na.rm=TRUE), first(y, n=2, na.rm=TRUE)), by=g], + data.table(g=c(1,1), V1=c(1,3), V2=c(9,9))) +DT = data.table(g=c(1,1,1,2,2), s=c("a",NA,"c",NA,"e"), l=list(1,NA,3,NA,5), + lg=c(TRUE,NA,FALSE,NA,TRUE), cx=c(1+1i,NA,3+3i,NA,5+5i)) +test(2286.21, DT[, .(first(s,na.rm=TRUE)), by=g], data.table(g=c(1,2), V1=c("a","e"))) +test(2286.22, DT[, .(first(l,na.rm=TRUE)), by=g], data.table(g=c(1,2), V1=list(1,5))) +test(2286.23, DT[, .(first(lg,na.rm=TRUE)), by=g], data.table(g=c(1,2), V1=c(TRUE,TRUE))) +test(2286.24, DT[, .(first(cx,na.rm=TRUE)), by=g], data.table(g=c(1,2), V1=c(1+1i,5+5i))) +if (test_bit64) { + DT[, i64 := as.integer64(c(1,NA,3,NA,5))] + test(2286.25, DT[, .(first(i64,na.rm=TRUE)), by=g], data.table(g=c(1,2), V1=bit64::as.integer64(c(1,5)))) +} +test(2286.31, first(c(1,NA,3,NA,5), na.rm=TRUE), 1) +test(2286.32, first(c(1,NA,3,NA,5), n=2, na.rm=TRUE), c(1,3)) +test(2286.33, last(c(1,NA,3,NA,5), n=2, na.rm=TRUE), c(3,5)) +test(2286.34, first(c(NA_real_,NA_real_), na.rm=TRUE), NA_real_) +test(2286.35, first(list(1,NULL,3,NA,5), n=3, na.rm=TRUE), list(1,3,5)) +test(2286.36, first(x <- data.frame(a=1:2), na.rm=TRUE), error="na.rm=TRUE is not currently supported for 'data.frame'") diff --git a/man/last.Rd b/man/last.Rd index ce28145286..56ef4df5b1 100644 --- a/man/last.Rd +++ b/man/last.Rd @@ -8,13 +8,18 @@ or data.table. The main difference to head/tail is that the default for \code{n} rather than 6. } \usage{ -first(x, n=1L, \dots) -last(x, n=1L, \dots) +first(x, n=1L, na.rm=FALSE, \dots) +last(x, n=1L, na.rm=FALSE, \dots) } \arguments{ \item{x}{ A vector, list, data.frame or data.table. Otherwise the S3 method of \code{xts::first} is deployed. } \item{n}{ A numeric vector length 1. How many items to select. } +\item{na.rm}{ \code{TRUE} or \code{FALSE} (default). When \code{TRUE}, missing values in \code{x} +(\code{NA}, or \code{NULL} list elements) are skipped, so that the first/last \code{n} +\emph{non-missing} items are returned; fewer than \code{n} are returned if fewer than \code{n} +non-missing items are found. Only supported when \code{x} is a plain vector or list (not +\code{data.frame}, \code{data.table}, matrix/array, or \code{xts}). } \item{\dots}{ Not applicable for \code{data.table} first/last. Any arguments here are passed through to \code{xts}'s first/last. } } @@ -37,5 +42,12 @@ first(x) # same as head(x, 1) last(1:5) # [1] 5 x = data.table(x=1:5, y=6:10) last(x) # same as tail(x, 1) + +first(c(NA, 2, NA, 4), na.rm=TRUE) # [1] 2 +last(c(1, NA, 3, NA), n=2, na.rm=TRUE) # [1] 1 3 + +DT = data.table(g=c(1,1,1,2,2), x=c(1,NA,3,NA,5)) +DT[, first(x, na.rm=TRUE), by=g] # first non-missing x per group +DT[, first(x, n=2, na.rm=TRUE), by=g] # up to 2 non-missing x per group; fewer rows if fewer are non-missing } \keyword{ data } diff --git a/src/data.table.h b/src/data.table.h index a78327423f..2220556779 100644 --- a/src/data.table.h +++ b/src/data.table.h @@ -453,8 +453,8 @@ SEXP rleid(SEXP, SEXP); SEXP gmedian(SEXP, SEXP); SEXP gtail(SEXP, SEXP); SEXP ghead(SEXP, SEXP); -SEXP glast(SEXP, SEXP); -SEXP gfirst(SEXP, SEXP); +SEXP glast(SEXP, SEXP, SEXP); +SEXP gfirst(SEXP, SEXP, SEXP); SEXP gnthvalue(SEXP, SEXP); SEXP dim(SEXP); SEXP warn_matrix_column_r(SEXP); diff --git a/src/gsumm.c b/src/gsumm.c index 886dcaa29c..2052fb62f5 100644 --- a/src/gsumm.c +++ b/src/gsumm.c @@ -39,30 +39,59 @@ static int nbit(int n) /* Some GForce functions (currently gfirst/glast/ghead/gtail with n>1, and gshift) return, for at least one group, a different number of items than 1 (the norm for e.g. gmean, gsum). Such a column carries - a 'gforce_dynamic' attribute (set by gfirstlast and gshift, below): a scalar integer w, meaning the - column has MIN(w, grpsize[g]) items for group g (gshift sets w=INT_MAX, since it always returns - exactly grpsize[g]). When a query combines such a column with an ordinary (fixed, 1-per-group) result - in the same by= (e.g. .(shift(x), mean(y))), this function replicates the fixed result out to match, - #1414. When a query combines two dynamic columns that don't actually agree in length for some group - (e.g. .(head(x,2), head(y,3)) where the group has >=3 rows), this errors rather than reconciling them - with NA. Otherwise optimize>=2 (GForce) would succeed at a query that optimize<2 (dogroups.c) can't - do at all, making the optimize level change correctness rather than just speed Returns gans unchanged - (no allocation) when no column carries the attribute, so the (very common) case of no dynamic-length - GForce result in the query costs nothing extra. */ + a 'gforce_dynamic' attribute (set by gfirstlast and gshift, below), which is either: + - a scalar integer w, meaning the column has MIN(w, grpsize[g]) items for group g: deterministic + from w and grpsize[] alone (gshift sets w=INT_MAX, since it always returns exactly grpsize[g]); + or + - an integer vector of length ngrp giving the actual number of items for each group directly: used + when na.rm=TRUE (first/last with n>1), since how many non-NA values are found per group is data- + dependent and can't be derived from w and grpsize[] alone, #4239 #4446. + When a query combines such a column with an ordinary (fixed, 1-per-group) result in the same by= + (e.g. .(shift(x), mean(y))), this function replicates the fixed result out to match, #1414. When a + query combines two dynamic columns that don't actually agree in length for some group (e.g. + .(head(x,2), head(y,3)) where the group has >=3 rows, or .(first(x,n=2,na.rm=TRUE), first(y,n=3)) + where a group has fewer than 2 non-NA x values), this errors rather than reconciling them with NA. + Otherwise optimize>=2 (GForce) would succeed at a query that optimize<2 (dogroups.c) can't do at all, + making the optimize level change correctness rather than just speed, #4446 #4239 #5060 #523. Returns + gans unchanged (no allocation) when no column carries the attribute, so the (very common) case of no + dynamic-length GForce result in the query costs nothing extra. */ static SEXP gforce_align_dynamic(SEXP gans) { const int nans = length(gans); int max_w = 0; + SEXP lens = NULL; + bool lensCopied = false; + int nprotect = 0; for (int i=0; imax_w) max_w=this_w; + if (LENGTH(att)==1) { + const int this_w = INTEGER(att)[0]; + if (this_w>max_w) max_w=this_w; + } else if (!lens) { + lens = att; // first data-dependent (na.rm) column found; use its counts directly unless another is found below + } else { + if (!lensCopied) { lens=PROTECT(duplicate(lens)); nprotect++; lensCopied=true; } + int *lensp = INTEGER(lens); + const int *ss = INTEGER(att); + for (int g=0; glensp[g]) lensp[g]=ss[g]; + } } - if (!max_w) return gans; // nothing in this j is gforce_dynamic; most common case, return untouched with no allocation - int nprotect = 0; - SEXP lens = PROTECT(allocVector(INTSXP, ngrp)); nprotect++; - int *lensp = INTEGER(lens); - for (int g=0; glensp[g]) lensp[g]=this_w; + } + } + const int *lensp = INTEGER(lens); + int anslen=0; + for (int g=0; g1) // headw: select 1:w of each group when first=true, and (n-w+1):n when first=false (i.e. tail). // When TRUE, the result is marked with a 'gforce_dynamic' attribute #4239 // so that gforce() can correctly replicate ordinary (fixed, 1-per-group) results // against it, and validate it against other dynamic results, when combined in the same by=. + // narm: skip NA values while selecting, #4239 #4446. When headw (w>1), the number of non-NA values + // found per group is data-dependent (0 to w), so a first pass counts them (and finds, for + // first=FALSE, where the write pass should start scanning forward from) before ans is + // allocated; the gforce_dynamic attribute then carries these actual per-group counts rather + // than just w. When !headw (w==1), each group still contributes exactly one slot (NA when no + // non-NA value is found, like gmedian/gvar do for insufficient data), so no such marking, or + // counting pass, is needed there. const bool nosubset = irowslen == -1; const bool issorted = !isunsorted; // make a const-bool for use inside loops const int n = nosubset ? length(x) : irowslen; if (nrow != n) error(_("nrow [%d] != length(x) [%d] in %s"), nrow, n, first?"gfirst":"glast"); if (w==1 && headw) internal_error(__func__, "headw should only be true when w>1"); int anslen = ngrp; + int nprotect = 0; + SEXP takeSxp=NULL, startSxp=NULL; + int *takep=NULL, *startp=NULL; if (headw) { - anslen = 0; - for (int i=0; i1 */ \ - for (int i=0; i1 && first) { \ - /* gnthvalue */ \ - for (int i=0; igrpn) { const CTYPE val=RNA; ASSIGN; continue; } \ - const int j = ff[i]-1+w-1; \ - const int k = issorted ? j : oo[j]-1; \ - const CTYPE val = nosubset ? xd[k] : (irows[k]==NA_INTEGER ? RNA : xd[irows[k]-1]); \ - ASSIGN; \ - } \ - } else { \ - /* w>1 && !first not supported because -i in R means everything-but-i and gnthvalue */ \ - /* currently takes n>0 only. However, we could still support n'th from the end, somehow */ \ - internal_error(__func__, "unanticipated case first=%d w=%d headw=%d", first, w, headw); \ - } \ + #define DO(CTYPE, RTYPE, RNA, ASSIGN, ISNAT) { \ + const CTYPE *xd = (const CTYPE *)RTYPE(x); \ + if (headw && narm) { \ + /* the count pass above already determined how many, and where to start, for each group */\ + for (int i=0; i=jend) + internal_error(__func__, "gfirstlast narm write pass ran past group %d end", i); \ + const int k = issorted ? j : oo[j]-1; \ + const CTYPE val = nosubset ? xd[k] : (irows[k]==NA_INTEGER ? RNA : xd[irows[k]-1]); \ + if (!(ISNAT)) { ASSIGN; found++; } \ + j++; \ + } \ + } \ + } else if (headw) { \ + /* returning more than 1 per group; w>1 */ \ + for (int i=0; i1 && first) { \ + /* gnthvalue */ \ + for (int i=0; igrpn) { const CTYPE val=RNA; ASSIGN; continue; } \ + const int j = ff[i]-1+w-1; \ + const int k = issorted ? j : oo[j]-1; \ + const CTYPE val = nosubset ? xd[k] : (irows[k]==NA_INTEGER ? RNA : xd[irows[k]-1]); \ + ASSIGN; \ + } \ + } else { \ + /* w>1 && !first not supported because -i in R means everything-but-i and gnthvalue */ \ + /* currently takes n>0 only. However, we could still support n'th from the end, somehow */\ + internal_error(__func__, "unanticipated case first=%d w=%d headw=%d", first, w, headw); \ + } \ } switch(TYPEOF(x)) { - case LGLSXP: { int *ansd=LOGICAL(ans); DO(int, LOGICAL_RO, NA_LOGICAL, ansd[ansi++]=val) } break; - case INTSXP: { int *ansd=INTEGER(ans); DO(int, INTEGER_RO, NA_INTEGER, ansd[ansi++]=val) } break; + case LGLSXP: { + int *ansd=LOGICAL(ans); DO(int, LOGICAL_RO, NA_LOGICAL, ansd[ansi++]=val, val==NA_INTEGER) + } break; + case INTSXP: { + int *ansd=INTEGER(ans); DO(int, INTEGER_RO, NA_INTEGER, ansd[ansi++]=val, val==NA_INTEGER) + } break; case REALSXP: if (INHERITS(x, char_integer64)) { - int64_t *ansd=(int64_t *)REAL(ans); DO(int64_t, REAL_RO, NA_INTEGER64, ansd[ansi++]=val) } - else { double *ansd=REAL(ans); DO(double, REAL_RO, NA_REAL, ansd[ansi++]=val) } break; - case CPLXSXP: { Rcomplex *ansd=COMPLEX(ans); DO(Rcomplex, COMPLEX_RO, NA_CPLX, ansd[ansi++]=val) } break; - case STRSXP: DO(SEXP, STRING_PTR_RO, NA_STRING, SET_STRING_ELT(ans,ansi++,val)) break; - case VECSXP: DO(SEXP, SEXPPTR_RO, ScalarLogical(NA_LOGICAL), SET_VECTOR_ELT(ans,ansi++,val)) break; + int64_t *ansd=(int64_t *)REAL(ans); DO(int64_t, REAL_RO, NA_INTEGER64, ansd[ansi++]=val, val==NA_INTEGER64) + } else { + double *ansd=REAL(ans); DO(double, REAL_RO, NA_REAL, ansd[ansi++]=val, ISNAN(val)) + } break; + case CPLXSXP: { + Rcomplex *ansd=COMPLEX(ans); DO(Rcomplex, COMPLEX_RO, NA_CPLX, ansd[ansi++]=val, ISNAN_COMPLEX(val)) + } break; + case STRSXP: { + DO(SEXP, STRING_PTR_RO, NA_STRING, SET_STRING_ELT(ans,ansi++,val), val==NA_STRING) + } break; + case VECSXP: { + DO(SEXP, SEXPPTR_RO, ScalarLogical(NA_LOGICAL), SET_VECTOR_ELT(ans,ansi++,val), isNull(val) || (isLogical(val) && LENGTH(val)==1 && LOGICAL(val)[0]==NA_LOGICAL)) + } break; default: error(_("Type '%s' is not supported by GForce head/tail/first/last/`[`. Either add the namespace prefix (e.g. utils::head(.)) or turn off GForce optimization using options(datatable.optimize=1)"), type2char(TYPEOF(x))); } - if (headw) setAttrib(ans, sym_gforce_dynamic, ScalarInteger(w)); // so gforce() can recompute MIN(w, grpsize[g]) per group + #undef DO + if (headw && narm) setAttrib(ans, sym_gforce_dynamic, takeSxp); // actual per-group counts; data-dependent, #4239 #4446 + else if (headw) setAttrib(ans, sym_gforce_dynamic, ScalarInteger(w)); // so gforce() can recompute MIN(w, grpsize[g]) per group copyMostAttrib(x, ans); - UNPROTECT(1); + UNPROTECT(nprotect); return(ans); } -SEXP glast(SEXP x, SEXP nArg) { +SEXP glast(SEXP x, SEXP nArg, SEXP narmArg) { if (!isInteger(nArg) || LENGTH(nArg)!=1 || INTEGER(nArg)[0]<1) internal_error(__func__, "glast is only implemented for n>0. This should have been caught before"); // # nocov + if (!IS_TRUE_OR_FALSE(narmArg)) error(_("'%s' must be TRUE or FALSE"), "na.rm"); // # nocov const int n=INTEGER(nArg)[0]; - return gfirstlast(x, false, n, n>1); + const bool narm=LOGICAL(narmArg)[0]; + return gfirstlast(x, false, n, n>1, narm); } -SEXP gfirst(SEXP x, SEXP nArg) { +SEXP gfirst(SEXP x, SEXP nArg, SEXP narmArg) { if (!isInteger(nArg) || LENGTH(nArg)!=1 || INTEGER(nArg)[0]<1) internal_error(__func__, "gfirst is only implemented for n>0. This should have been caught before"); // # nocov + if (!IS_TRUE_OR_FALSE(narmArg)) error(_("'%s' must be TRUE or FALSE"), "na.rm"); // # nocov const int n=INTEGER(nArg)[0]; - return gfirstlast(x, true, n, n>1); + const bool narm=LOGICAL(narmArg)[0]; + return gfirstlast(x, true, n, n>1, narm); } SEXP gtail(SEXP x, SEXP nArg) { if (!isInteger(nArg) || LENGTH(nArg)!=1 || INTEGER(nArg)[0]<1) internal_error(__func__, "gtail is only implemented for n>0. This should have been caught before"); // # nocov const int n=INTEGER(nArg)[0]; - return gfirstlast(x, false, n, n>1); + return gfirstlast(x, false, n, n>1, false); } SEXP ghead(SEXP x, SEXP nArg) { if (!isInteger(nArg) || LENGTH(nArg)!=1 || INTEGER(nArg)[0]<1) internal_error(__func__, "ghead is only implemented for n>0. This should have been caught before"); // # nocov const int n=INTEGER(nArg)[0]; - return gfirstlast(x, true, n, n>1); + return gfirstlast(x, true, n, n>1, false); } SEXP gnthvalue(SEXP x, SEXP nArg) { if (!isInteger(nArg) || LENGTH(nArg)!=1 || INTEGER(nArg)[0]<1) internal_error(__func__, "`g[` (gnthvalue) is only implemented single value subsets with positive index, e.g., .SD[2]. This should have been caught before"); // # nocov - return gfirstlast(x, true, INTEGER(nArg)[0], false); + return gfirstlast(x, true, INTEGER(nArg)[0], false, false); } // TODO: gwhich.min, gwhich.max