packrat/lib-R/x86_64-w64-mingw32/3.6.1/base/demo/is.things.R

In jmcascalheira/LGMIberiaCluster: Research compendium for the paper "Human adaptations and palaeoenvironmental record during the Last Glacial Maximum in the Iberian Peninsula"

#  Copyright (C) 1997-2018 The R Core Team

### The Base package has a couple of non-functions:
##
## These may be in "base" when they exist;  discount them here
## (see also  'dont.mind' in checkConflicts() inside library()) :
xtraBaseNms <- c("last.dump", "last.warning", ".Last.value",
                 ".Random.seed", ".Traceback")
ls.base <- Filter(function(nm) is.na(match(nm, xtraBaseNms)),
                  ls("package:base", all=TRUE))
base.is.f <- sapply(ls.base, function(x) is.function(get(x)))
cat("\nNumber of all base objects:\t", length(ls.base),
    "\nNumber of functions from these:\t", sum(base.is.f),
    "\n\t starting with 'is.' :\t  ",
    sum(grepl("^is\\.", ls.base[base.is.f])), "\n", sep = "")
## R ver.| #{is*()}
## ------+---------
## 0.14  : 31
## 0.50  : 33
## 0.60  : 34
## 0.63  : 37
## 1.0.0 : 38
## 1.3.0 : 41
## 1.6.0 : 45
## 2.0.0 : 45
## 2.7.0 : 48
## 3.0.0 : 49
if(interactive()) {
    nonDots <- function(nm) substr(nm, 1L, 1L) != "."
    cat("Base non-functions not starting with \".\":\n")
    Filter(nonDots, ls.base[!base.is.f])
}

## Do we have a method (probably)?
is.method <- function(fname) {
    isFun <- function(name) (exists(name, mode="function") &&
                             is.na(match(name, c("is", "as"))))
    np <- length(sp <- strsplit(fname, split = "\\.")[[1]])
    if(np <= 1 )
        FALSE
    else
        (isFun(paste(sp[1:(np-1)], collapse = '.')) ||
         (np >= 3 &&
          isFun(paste(sp[1:(np-2)], collapse = '.'))))
}

is.ALL <- function(obj, func.names = ls(pos=length(search())),
		   not.using = c("is.single", "is.real", "is.loaded",
                     "is.empty.model", "is.R", "is.element", "is.unsorted"),
		   true.only = FALSE, debug = FALSE)
{
    ## Purpose: show many 'attributes' of  R object __obj__
    ## -------------------------------------------------------------------------
    ## Arguments: obj: any R object
    ## -------------------------------------------------------------------------
    ## Author: Martin Maechler, Date: 6 Dec 1996

    is.fn <- func.names[substring(func.names,1,3) == "is."]
    is.fn <- is.fn[substring(is.fn,1,7) != "is.na<-"]
    use.fn <- is.fn[ is.na(match(is.fn, not.using))
                    & ! sapply(is.fn, is.method) ]

    r <- if(true.only) character(0)
    else structure(vector("list", length= length(use.fn)), names= use.fn)
    for(f in use.fn) {
	if(any(f == c("is.na", "is.finite"))) {
	    if(!is.list(obj) && !is.vector(obj) && !is.array(obj)) {
		if(!true.only) r[[f]] <- NA
		next
	    }
	}
	if(any(f == c("is.nan", "is.finite", "is.infinite"))) {
	    if(!is.atomic(obj)) {
	    	if(!true.only) r[[f]] <- NA
	    	next
	    }
	}
	if(debug) cat(f,"")
	fn <- get(f)
	rr <- if(is.primitive(fn) || length(formals(fn))>0)  fn(obj) else fn()
	if(!is.logical(rr)) cat("f=",f," --- rr	 is NOT logical	 = ",rr,"\n")
	##if(1!=length(rr))   cat("f=",f," --- rr NOT of length 1; = ",rr,"\n")
	if(true.only && length(rr)==1 && !is.na(rr) && rr) r <- c(r, f)
	else if(!true.only) r[[f]] <- rr
    }
    if(debug)cat("\n")
    if(is.list(r)) structure(r, class = "isList") else r
}

print.isList <- function(x, ..., verbose = getOption("verbose"))
{
    ## Purpose:	 print METHOD  for `isList' objects
    ## ------------------------------------------------
    ## Author: Martin Maechler, Date: 12 Mar 1997
    if(is.list(x)) {
        if(verbose) cat("print.isList(): list case (length=",length(x),")\n")
	nm <- format(names(x))
	rr <- lapply(x, stats::symnum, na = "NA")
	for(i in seq_along(x)) cat(nm[i],":",rr[[i]],"\n", ...)
    } else NextMethod("print", ...)
}


is.ALL(NULL)
##fails: is.ALL(NULL, not.using = c("is.single", "is.loaded"))
is.ALL(NULL,   true.only = TRUE)
all.equal(NULL, pairlist())
## list() != NULL == pairlist() :
is.ALL(list(), true.only = TRUE)

(pl <- is.ALL(pairlist(1,    list(3,"A")), true.only = TRUE))
(ll <- is.ALL(    list(1,pairlist(3,"A")), true.only = TRUE))
all.equal(pl[pl != "is.pairlist"],
          ll[ll != "is.vector"])## TRUE

is.ALL(1:5)
is.ALL(array(1:24, 2:4))
is.ALL(1 + 3)
e13 <- expression(1 + 3)
is.ALL(e13)
is.ALL(substitute(expression(a + 3), list(a=1)), true.only = TRUE)
is.ALL(y ~ x) #--> NA	 for is.na & is.finite

is0 <- is.ALL(numeric(0))
is0.ok <- 1 == (lis0 <- sapply(is0, length))
is0[!is0.ok]
is0 <- unlist(is0)
is0
ispi <- unlist(is.ALL(pi))
all(ispi[is0.ok] == is0)

is.ALL(numeric(0), true=TRUE)
is.ALL(array(1,1:3), true=TRUE)
is.ALL(cbind(1:3), true=TRUE)

is.ALL(structure(1:7, names = paste("a",1:7,sep="")))
is.ALL(structure(1:7, names = paste("a",1:7,sep="")), true.only = TRUE)

x <- 1:20 ; y <- 5 + 6*x + rnorm(20)
lm.xy <- lm(y ~ x)
is.ALL(lm.xy)
is.ALL(structure(1:7, names = paste("a",1:7,sep="")))
is.ALL(structure(1:7, names = paste("a",1:7,sep="")), true.only = TRUE)