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