1# all non-exported / unused internal (utility) functions
2
3# R 3.5.0 made isTRUE longer but more efficient :
4#   `is.logical(x) && length(x)==1L && !is.na(x) && x`
5# Before R 3.5.0, isTRUE was defined as simply:
6#   identical(TRUE,x)
7# See PR#3421 for timings.
8# It was changed in R so that isTRUE(c(a=TRUE)) returned TRUE: https://github.com/wch/r-source/commit/828997ac6ecfb73aaa0aae9d1d0584a4ffc50881#diff-b41e3f9f1d389bb6f7a842cd5a3308b8
9if (base::getRversion() < "3.5.0") {
10  isTRUE  = function(x) is.logical(x) && length(x)==1L && !is.na(x) && x    # backport R's new implementation of isTRUE
11  isFALSE = function(x) is.logical(x) && length(x)==1L && !is.na(x) && !x   # backport isFALSE that was added in R 3.5.0
12}
13isTRUEorNA    = function(x) is.logical(x) && length(x)==1L && (is.na(x) || x)
14isTRUEorFALSE = function(x) is.logical(x) && length(x)==1L && !is.na(x)
15allNA = function(x) .Call(C_allNAR, x)
16# helper for nan argument (e.g. nafill): TRUE -> treat NaN as NA
17nan_is_na = function(x) {
18  if (length(x) != 1L) stop("Argument 'nan' must be length 1")
19  if (identical(x, NA) || identical(x, NA_real_)) return(TRUE)
20  if (identical(x, NaN)) return(FALSE)
21  stop("Argument 'nan' must be NA or NaN")
22}
23
24if (base::getRversion() < "3.2.0") {  # Apr 2015
25  isNamespaceLoaded = function(x) x %chin% loadedNamespaces()
26}
27
28# which.first
29which.first = function(x)
30{
31  if (!is.logical(x)) {
32    stop("x not boolean")
33  }
34  match(TRUE, x)
35}
36
37# which.last
38which.last = function(x)
39{
40  if (!is.logical(x)) {
41    stop("x not boolean")
42  }
43  length(x) - match(TRUE, rev(x)) + 1L
44}
45
46require_bit64_if_needed = function(DT) {
47  # called in fread and print.data.table
48  if (!isNamespaceLoaded("bit64") && any(sapply(DT,inherits,"integer64"))) {
49    # nocov start
50    # a test was attempted to cover the requireNamespace() by using unloadNamespace() first, but that fails when nanotime is loaded because nanotime also uses bit64
51    if (!requireNamespace("bit64",quietly=TRUE)) {
52      warning("Some columns are type 'integer64' but package bit64 is not installed. Those columns will print as strange looking floating point data. There is no need to reload the data. Simply install.packages('bit64') to obtain the integer64 print method and print the data again.")
53    }
54    # nocov end
55  }
56}
57
58# vapply for return value character(1)
59vapply_1c = function (x, fun, ..., use.names = TRUE) {
60  vapply(X = x, FUN = fun, ..., FUN.VALUE = NA_character_, USE.NAMES = use.names)
61}
62
63# vapply for return value logical(1)
64vapply_1b = function (x, fun, ..., use.names = TRUE) {
65  vapply(X = x, FUN = fun, ..., FUN.VALUE = NA, USE.NAMES = use.names)
66}
67
68# vapply for return value integer(1)
69vapply_1i = function (x, fun, ..., use.names = TRUE) {
70  vapply(X = x, FUN = fun, ..., FUN.VALUE = NA_integer_, USE.NAMES = use.names)
71}
72
73more = function(f) system(paste("more",f))    # nocov  (just a dev helper)
74
75# helper used to auto-name columns in data.table(x,y) as c("x","y"), CJ(x,y) and similar
76# naming of unnested matrices still handled by data.table()
77name_dots = function(...) {
78  dot_sub = as.list(substitute(list(...)))[-1L]
79  vnames = names(dot_sub)
80  if (is.null(vnames)) {
81    vnames = character(length(dot_sub))
82  } else {
83    vnames[is.na(vnames)] = ""
84  }
85  notnamed = vnames==""
86  if (any(notnamed)) {
87    syms = sapply(dot_sub, is.symbol)  # save the deparse() in most cases of plain symbol
88    for (i in which(notnamed)) {
89      tmp = if (syms[i]) as.character(dot_sub[[i]]) else deparse(dot_sub[[i]])[1L]
90      if (tmp == make.names(tmp)) vnames[i]=tmp
91    }
92  }
93  list(vnames=vnames, .named=!notnamed)
94}
95
96# convert a vector like c(1, 4, 3, 2) into a string like [1, 4, 3, 2]
97#   (common aggregation method for error messages)
98brackify = function(x, quote=FALSE) {
99  # arbitrary
100  CUTOFF = 10L
101  # keep one more than needed to trigger dots if needed
102  if (quote && is.character(x)) x = paste0("'",head(x,CUTOFF+1L),"'")
103  if (length(x) > CUTOFF) x = c(x[1:CUTOFF], '...')
104  sprintf('[%s]', paste(x, collapse = ', '))
105}
106
107# patterns done via NSE in melt.data.table and .SDcols in `[.data.table`
108do_patterns = function(pat_sub, all_cols) {
109  # received as substitute(patterns(...))
110  pat_sub = as.list(pat_sub)[-1L]
111  # identify cols = argument if present
112  idx = which(names(pat_sub) == "cols")
113  if (length(idx)) {
114    cols = eval(pat_sub[["cols"]], parent.frame(2L))
115    pat_sub = pat_sub[-idx]
116  } else cols = all_cols
117  pats = lapply(pat_sub, eval, parent.frame(2L))
118  matched = patterns(pats, cols=cols)
119  # replace with lengths when R 3.2.0 dependency arrives
120  if (length(idx <- which(sapply(matched, length) == 0L)))
121    stop('Pattern', if (length(idx) > 1L) 's', ' not found: [',
122         paste(pats[idx], collapse = ', '), ']')
123
124  return(matched)
125}
126
127# check UTC status
128is_utc = function(tz) {
129  # via grep('UTC|GMT', OlsonNames(), value = TRUE); ordered by "prior" frequency
130  utc_tz = c("UTC", "GMT", "Etc/UTC", "Etc/GMT", "GMT-0", "GMT+0", "GMT0")
131  if (is.null(tz)) tz = Sys.timezone()
132  return(tz %chin% utc_tz)
133}
134
135# very nice idea from Michael to avoid expression repetition (risk) in internal code, #4226
136"%iscall%" = function(e, f) { is.call(e) && e[[1L]] %chin% f }
137
138# nocov start #593 always return a data.table
139edit.data.table = function(name, ...) {
140  setDT(NextMethod('edit', name))[]
141}
142# nocov end
143