./Defunct.R-.Defunct <- function(new, package=NULL) {
./Defunct.R: msg <- gettextf("'%s' is defunct.\n",
./Defunct.R- as.character(sys.call(sys.parent())[[1]]))
./Defunct.R- if(!missing(new))
./Defunct.R- msg <- c(msg, gettextf("Use '%s' instead.\n", new))
./Defunct.R-.Defunct <- function(new, package=NULL) {
./Defunct.R- msg <- gettextf("'%s' is defunct.\n",
./Defunct.R- as.character(sys.call(sys.parent())[[1]]))
./Defunct.R- if(!missing(new))
./Defunct.R: msg <- c(msg, gettextf("Use '%s' instead.\n", new))
./Defunct.R- if(!is.null(package))
./Defunct.R- msg <- c(msg,
./Defunct.R- gettextf("See help(\"Defunct\") and help(\"%s-defunct\").", package))
--
./Deprecated.R-### --------------------
./Deprecated.R-.Deprecated <- function(new, package=NULL) {
./Deprecated.R- msg <- gettextf("'%s' is deprecated.\n",
./Deprecated.R- as.character(sys.call(sys.parent())[[1]]))
./Deprecated.R- if(!missing(new))
./Deprecated.R: msg <- c(msg, gettextf("Use '%s' instead.\n", new))
./Deprecated.R- if(!is.null(package))
./Deprecated.R- msg <- c(msg,
./Deprecated.R- gettextf("See help(\"Deprecated\") and help(\"%s-deprecated\").", package))
./Deprecated.R-###----- NOTE: ../man/Deprecated.Rd must be synchronized with this!
./Deprecated.R-### --------------------
./Deprecated.R-.Deprecated <- function(new, package=NULL) {
./Deprecated.R: msg <- gettextf("'%s' is deprecated.\n",
./Deprecated.R- as.character(sys.call(sys.parent())[[1]]))
./Deprecated.R- if(!missing(new))
./Deprecated.R- msg <- c(msg, gettextf("Use '%s' instead.\n", new))
./LAPACK.R-La.svd <- function(x, nu = min(n, p), nv = min(n, p),
./LAPACK.R- method = c("dgesdd", "dgesvd"))
./LAPACK.R-{
./LAPACK.R- if(!is.numeric(x) && !is.complex(x))
./LAPACK.R: stop("argument to 'La.svd' must be numeric or complex")
./LAPACK.R- if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./LAPACK.R- method <- match.arg(method)
./LAPACK.R- if(is.complex(x) && method == "dgesdd") {
./LAPACK.R-La.svd <- function(x, nu = min(n, p), nv = min(n, p),
./LAPACK.R- method = c("dgesdd", "dgesvd"))
./LAPACK.R-{
./LAPACK.R- if(!is.numeric(x) && !is.complex(x))
./LAPACK.R- stop("argument to 'La.svd' must be numeric or complex")
./LAPACK.R: if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./LAPACK.R- method <- match.arg(method)
./LAPACK.R- if(is.complex(x) && method == "dgesdd") {
./LAPACK.R- method <- "dgesvd"
--
./eigen.R- if (!n) stop("0 x 0 matrix")
./eigen.R- if (n != ncol(x)) stop("non-square matrix in 'eigen'")
./eigen.R-
./eigen.R- complex.x <- is.complex(x)
./eigen.R-
./eigen.R: if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./eigen.R-
./eigen.R- if(complex.x) {
./eigen.R- if(missing(symmetric)) {
--
./svd.R-svd <- function(x, nu = min(n,p), nv = min(n,p), LINPACK = FALSE)
./svd.R-{
./svd.R- x <- as.matrix(x)
./svd.R: if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./svd.R- dx <- dim(x)
./svd.R- n <- dx[1]
./svd.R- p <- dx[2]
./LAPACK.R- }
./LAPACK.R- x <- as.matrix(x)
./LAPACK.R- if (is.numeric(x)) storage.mode(x) <- "double"
./LAPACK.R- n <- nrow(x)
./LAPACK.R- p <- ncol(x)
./LAPACK.R: if(!n || !p) stop("0 extent dimensions")
./LAPACK.R-
./LAPACK.R- if(method == "dgesvd") {
./LAPACK.R- if(nu == 0) {
--
./svd.R- x <- as.matrix(x)
./svd.R- if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./svd.R- dx <- dim(x)
./svd.R- n <- dx[1]
./svd.R- p <- dx[2]
./svd.R: if(!n || !p) stop("0 extent dimensions")
./svd.R- if (is.complex(x)) {
./svd.R- res <- La.svd(x, nu, nv)
./svd.R- return(list(d = res$d, u = if(nu) res$u, v = if(nv) Conj(t(res$vt))))
./LAPACK.R- else if(nu == p) {
./LAPACK.R- jobu <- ifelse(n > p, 'S', 'A')
./LAPACK.R- u <- matrix(0, n, p)
./LAPACK.R- }
./LAPACK.R- else
./LAPACK.R: stop("'nu' must be 0, nrow(x) or ncol(x)")
./LAPACK.R-
./LAPACK.R- if (nv == 0) {
./LAPACK.R- jobv <- 'N'
--
./svd.R- else if(nu == p) {
./svd.R- job <- 20
./svd.R- u <- matrix(0, n, p)
./svd.R- }
./svd.R- else
./svd.R: stop("'nu' must be 0, nrow(x) or ncol(x)")
./svd.R-
./svd.R- job <- job +
./svd.R- if(nv == 0) 0 else if(nv == p || nv == n) 1 else
./LAPACK.R- else if (nv == p) {
./LAPACK.R- jobv <- ifelse(n > p, 'S', 'A')
./LAPACK.R- v <- matrix(0, p, p)
./LAPACK.R- }
./LAPACK.R- else
./LAPACK.R: stop("'nv' must be 0, nrow(x) or ncol(x)")
./LAPACK.R- } else {
./LAPACK.R- if(nu > 0 || nv > 0) {
./LAPACK.R- np <- min(n, p)
./New-Internal.R- "deparse options %s are not recognized"),
./New-Internal.R- paste(sQuote(control[is.na(opts)]), collapse=", ")),
./New-Internal.R- call. = FALSE, domain = NA)
./New-Internal.R- if (any(opts == 6)) {
./New-Internal.R- if (length(opts) != 1)
./New-Internal.R: stop("all can not be used with other deparse options",
./New-Internal.R- call. = FALSE)
./New-Internal.R- else
./New-Internal.R- return(31)
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R-do.call <- function(what,args,quote=FALSE) {
./New-Internal.R- enquote <- function(x) as.call(list(as.name("quote"), x))
./New-Internal.R- if( !is.list(args) )
./New-Internal.R: stop("second argument must be a list")
./New-Internal.R- if( quote ) args = lapply(args, enquote)
./New-Internal.R- .Internal(do.call(what,args))
./New-Internal.R-}
./RNG.R- "user-supplied", "Inversion", "Kinderman-Ramage",
./RNG.R- "default")
./RNG.R- do.set <- length(kind) > 0
./RNG.R- if(do.set) {
./RNG.R- if(!is.character(kind) || length(kind) > 1)
./RNG.R: stop("'kind' must be a character string of length 1 (RNG to be used).")
./RNG.R- if(is.na(i.knd <- pmatch(kind, kinds) - 1))
./RNG.R- stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind),
./RNG.R- domain = NA)
--
./RNG.R- kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
./RNG.R- "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
./RNG.R- "Knuth-TAOCP-2002", "default")
./RNG.R- if(length(kind) > 0) {
./RNG.R- if(!is.character(kind) || length(kind) > 1)
./RNG.R: stop("'kind' must be a character string of length 1 (RNG to be used).")
./RNG.R- if(is.na(i.knd <- pmatch(kind, kinds) - 1))
./RNG.R- stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind),
./RNG.R- domain = NA)
./RNG.R- do.set <- length(kind) > 0
./RNG.R- if(do.set) {
./RNG.R- if(!is.character(kind) || length(kind) > 1)
./RNG.R- stop("'kind' must be a character string of length 1 (RNG to be used).")
./RNG.R- if(is.na(i.knd <- pmatch(kind, kinds) - 1))
./RNG.R: stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind),
./RNG.R- domain = NA)
./RNG.R- if(i.knd == length(kinds) - 1) i.knd <- -1
./RNG.R- } else i.knd <- NULL
--
./RNG.R- "Knuth-TAOCP-2002", "default")
./RNG.R- if(length(kind) > 0) {
./RNG.R- if(!is.character(kind) || length(kind) > 1)
./RNG.R- stop("'kind' must be a character string of length 1 (RNG to be used).")
./RNG.R- if(is.na(i.knd <- pmatch(kind, kinds) - 1))
./RNG.R: stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind),
./RNG.R- domain = NA)
./RNG.R- if(i.knd == length(kinds) - 1) i.knd <- -1
./RNG.R- } else i.knd <- NULL
./RNG.R- if(i.knd == length(kinds) - 1) i.knd <- -1
./RNG.R- } else i.knd <- NULL
./RNG.R-
./RNG.R- if(!is.null(normal.kind)) {
./RNG.R- if(!is.character(normal.kind) || length(normal.kind) > 1)
./RNG.R: stop("'normal.kind' must be a character string of length 1.")
./RNG.R- if (normal.kind == "Buggy Kinderman-Ramage")
./RNG.R- warning("Buggy version of Kinderman-Ramage generator used.")
./RNG.R- normal.kind <- pmatch(normal.kind, n.kinds) - 1
./RNG.R-
./RNG.R- if(!is.null(normal.kind)) {
./RNG.R- if(!is.character(normal.kind) || length(normal.kind) > 1)
./RNG.R- stop("'normal.kind' must be a character string of length 1.")
./RNG.R- if (normal.kind == "Buggy Kinderman-Ramage")
./RNG.R: warning("Buggy version of Kinderman-Ramage generator used.")
./RNG.R- normal.kind <- pmatch(normal.kind, n.kinds) - 1
./RNG.R- if(is.na(normal.kind))
./RNG.R- stop(gettextf("'%s' is not a valid choice", normal.kind),
./RNG.R- stop("'normal.kind' must be a character string of length 1.")
./RNG.R- if (normal.kind == "Buggy Kinderman-Ramage")
./RNG.R- warning("Buggy version of Kinderman-Ramage generator used.")
./RNG.R- normal.kind <- pmatch(normal.kind, n.kinds) - 1
./RNG.R- if(is.na(normal.kind))
./RNG.R: stop(gettextf("'%s' is not a valid choice", normal.kind),
./RNG.R- domain = NA)
./RNG.R- if(normal.kind == length(n.kinds) - 1) normal.kind <- -1
./RNG.R- }
./RNG.R-
./RNG.R-RNGversion <- function(vstr)
./RNG.R-{
./RNG.R- vnum <- as.numeric(strsplit(vstr,".", fixed=TRUE)[[1]])
./RNG.R- if (length(vnum) < 2)
./RNG.R: stop("malformed version string")
./RNG.R- if (vnum[1] == 0 && vnum[2] < 99)
./RNG.R- RNGkind("Wichmann-Hill", "Buggy Kinderman-Ramage")
./RNG.R- else if (vnum[1] == 0 || vnum[1] == 1 && vnum[2] <= 6)
./apply.R-
./apply.R- ## Ensure that X is an array object
./apply.R- d <- dim(X)
./apply.R- dl <- length(d)
./apply.R- if(dl == 0)
./apply.R: stop("dim(X) must have a positive length")
./apply.R- ds <- 1:dl
./apply.R- if(length(oldClass(X)) > 0)
./apply.R- X <- if(dl == 2) as.matrix(X) else as.array(X)
./array.R-{
./array.R- data <- as.vector(data)
./array.R- vl <- prod(dim)
./array.R- if(length(data) != vl) {
./array.R- if(vl > .Machine$integer.max)
./array.R: stop("'dim' specifies too large an array")
./array.R- data <- rep(data, length.out=vl)
./array.R- }
./array.R- if(length(dim))
./array.R- if(is.null(d))
./array.R- d <- length(x)
./array.R- n <- length(d)
./array.R-
./array.R- if((length(MARGIN) > 1) || (MARGIN < 1) || (MARGIN > n))
./array.R: stop("incorrect value for 'MARGIN'")
./array.R-
./array.R- if(any(d == 0)) return(array(integer(0), d))
./array.R-
./as.R-as.name <- as.symbol
./as.R-## would work too: as.name <- function(x) .Internal(as.vector(x, "name"))
./as.R-
./as.R-## as.call <- function(x) stop("type call cannot be assigned")
./as.R-as.numeric <- as.double
./as.R:as.qr <- function(x) stop("you cannot be serious")
./as.R-## as.ts <- function(x) if(is.ts(x)) x else ts(x) # in ts.R
./attach.R-attach <- function(what, pos=2, name=deparse(substitute(what)))
./attach.R-{
./attach.R- if(pos == 1) {
./attach.R: warning("*** 'pos=1' is not possible; setting 'pos=2' for now.\n",
./attach.R- "*** Note that 'pos=1' will give an error in the future")
./attach.R- pos <- 2
./attach.R- }
./attach.R-attach <- function(what, pos=2, name=deparse(substitute(what)))
./attach.R-{
./attach.R- if(pos == 1) {
./attach.R- warning("*** 'pos=1' is not possible; setting 'pos=2' for now.\n",
./attach.R: "*** Note that 'pos=1' will give an error in the future")
./attach.R- pos <- 2
./attach.R- }
./attach.R- if (is.character(what) && (length(what)==1)){
./attach.R- "*** Note that 'pos=1' will give an error in the future")
./attach.R- pos <- 2
./attach.R- }
./attach.R- if (is.character(what) && (length(what)==1)){
./attach.R- if (!file.exists(what))
./attach.R: stop(gettextf("file '%s' not found", what), domain = NA)
./attach.R- name <- paste("file:", what, sep="")
./attach.R- value <- .Internal(attach(NULL, pos, name))
./attach.R- load(what, envir=as.environment(pos))
./attach.R- if (!missing(version))
./attach.R- name <- manglePackageName(name, version)
./attach.R- match(name, search())
./attach.R- }
./attach.R- if(is.na(pos))
./attach.R: stop("invalid name")
./attach.R- }
./attach.R- env <- as.environment(pos)
./attach.R- packageName <- search()[[pos]]
./attach.R- ## .required there)
./attach.R- for(pkgs in search()[-1]) {
./attach.R- if(!isNamespace(as.environment(pkgs)) &&
./attach.R- exists(".required", pkgs, inherits = FALSE) &&
./attach.R- packageName %in% paste("package:", get(".required", pkgs, inherits = FALSE),sep=""))
./attach.R: warning(packageName, " is required by ", pkgs, " (still attached)")
./attach.R- }
./attach.R- if(.isMethodsDispatchOn())
./attach.R- methods:::cacheMetaData(env, FALSE)
--
./library.R- stop(gettext("package '%s' required by '%s' could not be found",
./library.R- pkg, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R- if (!eval(parse(text=paste("current", z$op, "z$version"))))
./library.R: stop(gettextf("package '%s' %s was found, but %s %s is required by '%s'",
./library.R- pkg, current, z$op, z$version, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- }
--
./library.R- if (length(z) > 1) {
./library.R- pfile <- system.file("Meta", "package.rds",
./library.R- package = pkg, lib.loc = lib.loc)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R- if (!eval(parse(text=paste("current", z$op, "z$version"))))
./library.R: stop(gettextf("package '%s' %s is loaded, but %s %s is required by '%s'",
./library.R- pkg, current, z$op, z$version, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./attach.R- ## .required there)
./attach.R- for(pkgs in search()[-1]) {
./attach.R- if(!isNamespace(as.environment(pkgs)) &&
./attach.R- exists(".required", pkgs, inherits = FALSE) &&
./attach.R- packageName %in% paste("package:", get(".required", pkgs, inherits = FALSE),sep=""))
./attach.R: warning(packageName, " is required by ", pkgs, " (still attached)")
./attach.R- }
./attach.R- if(.isMethodsDispatchOn())
./attach.R- methods:::cacheMetaData(env, FALSE)
./attr.R-"mostattributes<-" <- function(obj, value) {
./attr.R- if(length(value)) {
./attr.R: if(!is.list(value)) stop("RHS must be list")
./attr.R- if(h.nam <- !is.na(inam <- match("names", names(value)))) {
./attr.R- n1 <- value[[inam]]; value <- value[-inam] }
./attr.R- if(h.dim <- !is.na(idin <- match("dim", names(value)))) {
./autoload.R-autoload <- function(name, package, reset=FALSE, ...)
./autoload.R-{
./autoload.R- if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
./autoload.R: stop("an object with that name already exists")
./autoload.R- m <- match.call()
./autoload.R- m[[1]] <- as.name("list")
./autoload.R- newcall <- eval(m, parent.frame())
./autoload.R- ## reevaluate the object
./autoload.R- where <- match(paste("package", package, sep = ":"), search())
./autoload.R- if (exists(name, where = where, inherits = FALSE))
./autoload.R- eval(as.name(name), as.environment(where))
./autoload.R- else
./autoload.R: stop(gettextf("autoloader did not find '%s' in '%s'", name, package),
./autoload.R- domain = NA)
./autoload.R-}
./backsolve.R- storage.mode(r) <- "double"
./backsolve.R- x.mat <- is.matrix(x)
./backsolve.R- if(!x.mat) x <- as.matrix(x)# k x nb
./backsolve.R- storage.mode(x) <- "double"
./backsolve.R- k <- as.integer(k)
./backsolve.R: if(k <= 0 || nrow(x) < k) stop("invalid argument values in 'backsolve'")
./backsolve.R- nb <- ncol(x)
./backsolve.R- upper.tri <- as.logical(upper.tri)
./backsolve.R- transpose <- as.logical(transpose)
./chol.R-chol <- function(x, pivot = FALSE, LINPACK = pivot)
./chol.R-{
./chol.R- if (is.complex(x))
./chol.R: stop("complex matrices not permitted at present")
./chol.R- else if(!is.numeric(x))
./chol.R- stop("non-numeric argument to 'chol'")
./chol.R-
./chol.R-chol <- function(x, pivot = FALSE, LINPACK = pivot)
./chol.R-{
./chol.R- if (is.complex(x))
./chol.R- stop("complex matrices not permitted at present")
./chol.R- else if(!is.numeric(x))
./chol.R: stop("non-numeric argument to 'chol'")
./chol.R-
./chol.R- if(is.matrix(x)) {
./chol.R- if(nrow(x) != ncol(x))
./chol.R- else if(!is.numeric(x))
./chol.R- stop("non-numeric argument to 'chol'")
./chol.R-
./chol.R- if(is.matrix(x)) {
./chol.R- if(nrow(x) != ncol(x))
./chol.R: stop("non-square matrix in 'chol'")
./chol.R- n <- nrow(x)
./chol.R- }
./chol.R- else {
./chol.R- stop("non-square matrix in 'chol'")
./chol.R- n <- nrow(x)
./chol.R- }
./chol.R- else {
./chol.R- if(length(x) != 1)
./chol.R: stop("non-matrix argument to 'chol'")
./chol.R- n <- as.integer(1)
./chol.R- }
./chol.R- if(!pivot && !LINPACK) return(.Call("La_chol", as.matrix(x), PACKAGE = "base"))
./chol.R- piv = as.integer(rep.int(0, n)),
./chol.R- as.integer(pivot),
./chol.R- rank = integer(1),
./chol.R- DUP = FALSE, PACKAGE = "base")
./chol.R- if (!pivot && z$rank < n)
./chol.R: stop("matrix not positive definite")
./chol.R- robj <- z$x
./chol.R- if (pivot) {
./chol.R- attr(robj, "pivot") <- z$piv
./chol.R- n,
./chol.R- v = matrix(0, nr=n, nc=n),
./chol.R- info = integer(1),
./chol.R- DUP = FALSE, PACKAGE = "base")
./chol.R- if(z$info)
./chol.R: stop("non-positive definite matrix in 'chol'")
./chol.R- z$v
./chol.R- }
./chol.R-}
./chol.R-}
./chol.R-
./chol.R-chol2inv <- function(x, size=NCOL(x), LINPACK=FALSE)
./chol.R-{
./chol.R- if(!is.numeric(x))
./chol.R: stop("non-numeric argument to 'chol2inv'")
./chol.R- if(!LINPACK) return(La.chol2inv(x, size))
./chol.R-
./chol.R- if(is.matrix(x)) {
./chol.R- nr <- length(x)
./chol.R- nc <- as.integer(1)
./chol.R- }
./chol.R- size <- as.integer(size)
./chol.R- if(size <= 0 || size > nr || size > nc)
./chol.R: stop("invalid 'size' argument in 'chol2inv'")
./chol.R- if(!is.double(x)) storage.mode(x) <- "double"
./chol.R- z <- .Fortran("ch2inv",
./chol.R- x=x,
./chol.R- size,
./chol.R- v=matrix(0, nr=size, nc=size),
./chol.R- info=integer(1),
./chol.R- DUP=FALSE, PACKAGE="base")
./chol.R- if(z$info)
./chol.R: stop("singular matrix in 'chol2inv'")
./chol.R- z$v
./chol.R-}
./colSums.R-colSums <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R: stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- n <- prod(dn[1:dims])
--
./colSums.R-
./colSums.R-colMeans <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R: stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- n <- prod(dn[1:dims])
--
./colSums.R-
./colSums.R-rowSums <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R: stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- p <- prod(dn[-(1:dims)])
--
./colSums.R-
./colSums.R-rowMeans <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R: stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- p <- prod(dn[-(1:dims)])
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R- stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R: stop("invalid 'dims'")
./colSums.R- n <- prod(dn[1:dims])
./colSums.R- dn <- dn[-(1:dims)]
./colSums.R- z <- if(is.complex(x))
--
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R- stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R: stop("invalid 'dims'")
./colSums.R- n <- prod(dn[1:dims])
./colSums.R- dn <- dn[-(1:dims)]
./colSums.R- z <- if(is.complex(x))
--
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R- stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R: stop("invalid 'dims'")
./colSums.R- p <- prod(dn[-(1:dims)])
./colSums.R- dn <- dn[1:dims]
./colSums.R- z <- if(is.complex(x))
--
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
./colSums.R- stop("'x' must be an array of at least two dimensions")
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R: stop("invalid 'dims'")
./colSums.R- p <- prod(dn[-(1:dims)])
./colSums.R- dn <- dn[1:dims]
./colSums.R- z <- if(is.complex(x))
./conditions.R- on.exit(finally)
./conditions.R- handlers <- list(...)
./conditions.R- classes <- names(handlers)
./conditions.R- parentenv <- parent.frame()
./conditions.R- if (length(classes) != length(handlers))
./conditions.R: stop("bad handler specification")
./conditions.R- tryCatchList(expr, classes, parentenv, handlers)
./conditions.R-}
./conditions.R-
./conditions.R-withCallingHandlers <- function(expr, ...) {
./conditions.R- handlers <- list(...)
./conditions.R- classes <- names(handlers)
./conditions.R- parentenv <- parent.frame()
./conditions.R- if (length(classes) != length(handlers))
./conditions.R: stop("bad handler specification")
./conditions.R- .Internal(.addCondHands(classes, handlers, parentenv, NULL, TRUE))
./conditions.R- expr
./conditions.R-}
./conditions.R-
./conditions.R-invokeRestart <- function(r, ...) {
./conditions.R- if (! isRestart(r)) {
./conditions.R- res <- findRestart(r)
./conditions.R- if (is.null(res))
./conditions.R: stop(gettextf("no 'restart' '%s' found", as.character(r)),
./conditions.R- domain = NA)
./conditions.R- r <- res
./conditions.R- }
--
./conditions.R- if (! interactive())
./conditions.R- stop("not an interactive session")
./conditions.R- if (! isRestart(r)) {
./conditions.R- res <- findRestart(r)
./conditions.R- if (is.null(res))
./conditions.R: stop(gettextf("no 'restart' '%s' found", as.character(r)),
./conditions.R- domain = NA)
./conditions.R- r <- res
./conditions.R- }
./conditions.R- .Internal(.invokeRestart(r, list(...)))
./conditions.R-}
./conditions.R-
./conditions.R-invokeRestartInteractively <- function(r) {
./conditions.R- if (! interactive())
./conditions.R: stop("not an interactive session")
./conditions.R- if (! isRestart(r)) {
./conditions.R- res <- findRestart(r)
./conditions.R- if (is.null(res))
./conditions.R- else if (is.character(spec))
./conditions.R- restarts[[i]] <- makeRestart(description = spec)
./conditions.R- else if (is.list(spec))
./conditions.R- restarts[[i]] <- docall("makeRestart", spec)
./conditions.R- else
./conditions.R: stop("not a valid restart specification")
./conditions.R- restarts[[i]]$name <- name
./conditions.R- }
./conditions.R- restarts
./conflicts.R-conflicts <- function(where=search(), detail = FALSE)
./conflicts.R-{
./conflicts.R: if(length(where) < 1) stop("argument where of length 0")
./conflicts.R- z <- vector(length(where), mode="list")
./conflicts.R- names(z) <- where
./conflicts.R- for(i in seq(along=where))
./connections.R-seek.connection <- function(con, where = NA, origin = "start", rw = "", ...)
./connections.R-{
./connections.R- origin <- pmatch(origin, c("start", "current", "end"))
./connections.R- rw <- pmatch(rw, c("read", "write"), 0)
./connections.R- if(is.na(origin))
./connections.R: stop("'origin' must be one of 'start', 'current' or 'end'")
./connections.R- .Internal(seek(con, as.double(where), origin, rw))
./connections.R-}
./connections.R-
./connections.R-truncate <- function(con, ...)
./connections.R- UseMethod("truncate")
./connections.R-
./connections.R-truncate.connection <- function(con, ...)
./connections.R-{
./connections.R: if(!isOpen(con)) stop("can only truncate an open connection")
./connections.R- .Internal(truncate(con))
./connections.R-}
./connections.R-
./connections.R-
./connections.R-writeBin <- function(object, con, size = NA, endian = .Platform$endian)
./connections.R-{
./connections.R- swap <- endian != .Platform$endian
./connections.R- if(!is.vector(object) || mode(object) == "list")
./connections.R: stop("can only write vector objects")
./connections.R- if(is.character(con)) {
./connections.R- con <- file(con, "wb")
./connections.R- on.exit(close(con))
./connections.R-
./connections.R-writeChar <- function(object, con, nchars = nchar(object, type="chars"),
./connections.R- eos = "")
./connections.R-{
./connections.R- if(!is.character(object))
./connections.R: stop("can only write character objects")
./connections.R- if(is.character(con)) {
./connections.R- con <- file(con, "wb")
./connections.R- on.exit(close(con))
./connections.R-
./connections.R-socketSelect <- function(socklist, write = FALSE, timeout = NULL) {
./connections.R- if (is.null(timeout))
./connections.R- timeout <- -1
./connections.R- else if (timeout < 0)
./connections.R: stop("supplied timeout must be NULL or a non-negative number")
./connections.R- if (length(write) < length(socklist))
./connections.R- write <- rep(write, length.out = length(socklist))
./connections.R- .Internal(sockSelect(socklist, write, timeout))
./cut.R-cut <- function(x, ...) UseMethod("cut")
./cut.R-
./cut.R-cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE,
./cut.R- right=TRUE, dig.lab=3, ...)
./cut.R-{
./cut.R: if (!is.numeric(x)) stop("'x' must be numeric")
./cut.R- if (length(breaks) == 1) {
./cut.R- if (is.na(breaks) | breaks < 2)
./cut.R- stop("invalid number of intervals")
--
./pretty.R-pretty <- function(x, n=5, min.n= n %/% 3, shrink.sml = 0.75,
./pretty.R- high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,
./pretty.R- eps.correct = 0)
./pretty.R-{
./pretty.R- if(!is.numeric(x))
./pretty.R: stop("'x' must be numeric")
./pretty.R- if(length(x)==0)
./pretty.R- return(x)
./pretty.R- x <- x[is.finite(x)]
--
./rowsum.R-rowsum<-function(x,group,reorder=TRUE,...)
./rowsum.R- UseMethod("rowsum")
./rowsum.R-
./rowsum.R-rowsum.default <-function(x,group,reorder=TRUE,...){
./rowsum.R- if (!is.numeric(x))
./rowsum.R: stop("'x' must be numeric")
./rowsum.R- if (length(group) != NROW(x))
./rowsum.R- stop("incorrect length for 'group'")
./rowsum.R- if (any(is.na(group)))
./cut.R- right=TRUE, dig.lab=3, ...)
./cut.R-{
./cut.R- if (!is.numeric(x)) stop("'x' must be numeric")
./cut.R- if (length(breaks) == 1) {
./cut.R- if (is.na(breaks) | breaks < 2)
./cut.R: stop("invalid number of intervals")
./cut.R- nb <- as.integer(breaks + 1)# one more than #{intervals}
./cut.R- dx <- diff(rx <- range(x,na.rm=TRUE))
./cut.R- if(dx==0) dx <- rx[1]
./cut.R- dx <- diff(rx <- range(x,na.rm=TRUE))
./cut.R- if(dx==0) dx <- rx[1]
./cut.R- breaks <- seq(rx[1] - dx/1000,
./cut.R- rx[2] + dx/1000, len=nb)
./cut.R- } else nb <- length(breaks <- sort(breaks))
./cut.R: if (any(duplicated(breaks))) stop("'breaks' are not unique")
./cut.R- codes.only <- FALSE
./cut.R- if (is.null(labels)) {#- try to construct nice ones ..
./cut.R- for(dig in dig.lab:max(12, dig.lab)) {
./cut.R- nchar(labels[nb-1], type="char")) <- "]" # was ")"
./cut.R- }
./cut.R- } else if (is.logical(labels) && !labels)
./cut.R- codes.only <- TRUE
./cut.R- else if (length(labels) != nb-1)
./cut.R: stop("labels/breaks length conflict")
./cut.R- code <- .C("bincode",
./cut.R- x = as.double(x),
./cut.R- n = as.integer(length(x)),
./data.matrix.R- log <- unlist(lapply(frame, is.logical))
./data.matrix.R- num <- unlist(lapply(frame, is.numeric))
./data.matrix.R- fac <- unlist(lapply(frame, is.factor))
./data.matrix.R-
./data.matrix.R- if(!all(log|fac|num))
./data.matrix.R: stop("non-numeric data type in frame")
./data.matrix.R- cl <- sapply(frame[log|num], function(x) {
./data.matrix.R- cl <- class(x)
./data.matrix.R- length(cl) > 1 || ! (cl %in% c("numeric", "integer", "logical"))
./data.matrix.R- cl <- sapply(frame[log|num], function(x) {
./data.matrix.R- cl <- class(x)
./data.matrix.R- length(cl) > 1 || ! (cl %in% c("numeric", "integer", "logical"))
./data.matrix.R- })
./data.matrix.R- if(length(cl) && any(cl))
./data.matrix.R: warning("class information lost from one or more columns")
./data.matrix.R- }
./data.matrix.R- x <- matrix(nr=d[1], nc=d[2], dimnames=dimnames(frame))
./data.matrix.R- for(i in seq(len=d[2])) {
./dataframe.R-"row.names<-.data.frame" <- function(x, value) {
./dataframe.R- if (!is.data.frame(x))
./dataframe.R- x <- as.data.frame(x)
./dataframe.R- old <- attr(x, "row.names")
./dataframe.R- if (!is.null(old) && length(value) != length(old))
./dataframe.R: stop("invalid 'row.names' length")
./dataframe.R- value <- as.character(value)
./dataframe.R- if (any(duplicated(value)))
./dataframe.R- stop("duplicate 'row.names' are not allowed")
./dataframe.R- old <- attr(x, "row.names")
./dataframe.R- if (!is.null(old) && length(value) != length(old))
./dataframe.R- stop("invalid 'row.names' length")
./dataframe.R- value <- as.character(value)
./dataframe.R- if (any(duplicated(value)))
./dataframe.R: stop("duplicate 'row.names' are not allowed")
./dataframe.R- if (any(is.na(value)))
./dataframe.R- stop("missing 'row.names' are not allowed")
./dataframe.R- attr(x, "row.names") <- value
./dataframe.R- stop("invalid 'row.names' length")
./dataframe.R- value <- as.character(value)
./dataframe.R- if (any(duplicated(value)))
./dataframe.R- stop("duplicate 'row.names' are not allowed")
./dataframe.R- if (any(is.na(value)))
./dataframe.R: stop("missing 'row.names' are not allowed")
./dataframe.R- attr(x, "row.names") <- value
./dataframe.R- x
./dataframe.R-}
./dataframe.R-"dimnames<-.data.frame" <- function(x, value) {
./dataframe.R- d <- dim(x)
./dataframe.R- if(!is.list(value) || length(value) != 2
./dataframe.R- || d[[1]] != length(value[[1]])
./dataframe.R- || d[[2]] != length(value[[2]]))
./dataframe.R: stop("invalid 'dimnames' given for data frame")
./dataframe.R- row.names(x) <- as.character(value[[1]]) # checks validity
./dataframe.R- names(x) <- as.character(value[[2]])
./dataframe.R- x
./dataframe.R- if(i > 1)
./dataframe.R- class(x) <- cl[ - (1:(i-1))]
./dataframe.R- if(is.character(row.names)){
./dataframe.R- if(length(row.names) == length(attr(x, "row.names")))
./dataframe.R- attr(x, "row.names") <- row.names
./dataframe.R: else stop(gettextf("invalid 'row.names', length %d for a data frame with %d rows",
./dataframe.R- length(row.names), length(attr(x, "row.names"))),
./dataframe.R- domain = NA)
./dataframe.R- }
./dataframe.R- x <- eval(as.call(c(expression(data.frame), x, check.names = !optional)))
./dataframe.R- if(any(m > 0)) names(x) <- sub("^\\.\\.adfl\\.", "", names(x))
./dataframe.R- if(!is.null(row.names)) {
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(length(row.names) != dim(x)[[1]])
./dataframe.R: stop(gettextf("supplied %d row names for %d rows",
./dataframe.R- length(row.names), dim(x)[[1]]), domain = NA)
./dataframe.R- attr(x, "row.names") <- row.names
./dataframe.R- }
--
./dataframe.R- row.names <- dn[[1]]
./dataframe.R- value <- list(x)
./dataframe.R- if(!is.null(row.names)) {
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(length(row.names) != nrows)
./dataframe.R: stop(gettextf("supplied %d row names for %d rows",
./dataframe.R- length(row.names), nrows), domain = NA)
./dataframe.R- }
./dataframe.R- else if(optional) row.names <- character(nrows)
./dataframe.R- stop(gettextf("mismatch of row names in arguments of 'data.frame\', item %d", i), domain = NA)
./dataframe.R- }
./dataframe.R- else function(current, new, i) {
./dataframe.R- if(is.null(current)) {
./dataframe.R- if(any(dup <- duplicated(new <- as.character(new)))) {
./dataframe.R: warning("some row.names duplicated: ",
./dataframe.R- paste(which(dup), collapse=","),
./dataframe.R- " --> row.names NOT used")
./dataframe.R- current
./Bessel.R-gammaCody <- function(x) .Internal(gammaCody(x))
./Bessel.R-
./Bessel.R:besselI <- function(x, nu, expon.scaled = FALSE)
./Bessel.R-{
./Bessel.R: .Internal(besselI(x,nu, 1+ as.logical(expon.scaled)))
./Bessel.R-}
./Bessel.R:besselK <- function(x, nu, expon.scaled = FALSE)
./Bessel.R-{
./Bessel.R: .Internal(besselK(x,nu, 1+ as.logical(expon.scaled)))
./Bessel.R-}
./Bessel.R:besselJ <- function(x, nu) .Internal(besselJ(x,nu))
./Bessel.R:besselY <- function(x, nu) .Internal(besselY(x,nu))
--
./Defunct.R:.Defunct <- function(new, package=NULL) {
./Defunct.R: msg <- gettextf("'%s' is defunct.\n",
./Defunct.R- as.character(sys.call(sys.parent())[[1]]))
./Defunct.R- if(!missing(new))
./Defunct.R: msg <- c(msg, gettextf("Use '%s' instead.\n", new))
./Defunct.R- if(!is.null(package))
./Defunct.R: msg <- c(msg,
./Defunct.R: gettextf("See help(\"Defunct\") and help(\"%s-defunct\").", package))
./Defunct.R: else msg <- c(msg, gettext("See help(\"Defunct\")"))
./Defunct.R: stop(paste(msg, collapse=""), call. = FALSE, domain = NA)
./Defunct.R-}
./Defunct.R-
./Defunct.R-Version <- function() .Defunct("R.Version")
--
./Defunct.R-##
./Defunct.R-
./Defunct.R-##
./Defunct.R-## Deprecated in 1.3.0
./Defunct.R-## Defunct in 1.4.0
./Defunct.R:read.table.url <- function(url, method, ...) .Defunct("read.table(url())")
./Defunct.R:scan.url <- function(url, file = tempfile(), method, ...)
./Defunct.R- .Defunct("scan(url())")
./Defunct.R:source.url <- function(url, file = tempfile(), method, ...)
./Defunct.R- .Defunct("source(url())")
./Defunct.R:httpclient <- function(url, port=80, error.is.fatal=TRUE, check.MIME.type=TRUE,
./Defunct.R: file=tempfile(), drop.ctrl.z=TRUE)
./Defunct.R- .Defunct()
./Defunct.R:parse.dcf <- function(text = NULL, file = "", fields = NULL,
./Defunct.R- versionfix = FALSE) .Defunct("read.dcf")
./Defunct.R-##
./Defunct.R-
./Defunct.R-##
./Defunct.R-## Deprecated in 1.4.0
./Defunct.R-## Defunct in 1.5.0
./Defunct.R-.Alias <- function(expr) .Defunct()
./Defunct.R:reshapeWide <- function(x, i, j, val, jnames = levels(j)) .Defunct("reshape")
./Defunct.R:reshapeLong <- function(x,jvars, ilev = row.names(x),
./Defunct.R: jlev = names(x)[jvars], iname = "reshape.i",
./Defunct.R: jname = "reshape.j", vname = "reshape.v")
./Defunct.R- .Defunct("reshape")
./Defunct.R-##
./Defunct.R-
./Defunct.R-##
./Defunct.R-## Deprecated in 1.5.0
./Defunct.R-## Defunct in 1.6.0
./Defunct.R:piechart <- function(x, labels = names(x), edges = 200, radius = 0.8,
./Defunct.R: density = NULL, angle = 45, col = NULL, main = NULL, ...)
./Defunct.R- .Defunct("pie")
./Defunct.R-##
./Defunct.R-
--
./Defunct.R-##
./Defunct.R-
./Defunct.R-##
./Defunct.R-## Deprecated in 1.7.0
./Defunct.R-## Defunct in 1.8.0
./Defunct.R:printNoClass <- function(x, digits = NULL, quote = TRUE, na.print = NULL,
./Defunct.R: print.gap = NULL, right = FALSE, ...)
./Defunct.R- .Defunct()
./Defunct.R-##
./Defunct.R-
./Defunct.R-##
./Defunct.R-## Deprecated in 1.8.0
./Defunct.R-## Defunct in 1.9.0
./Defunct.R:print.coefmat <- function(x, digits=max(3, getOption("digits") - 2),
./Defunct.R: signif.stars = getOption("show.signif.stars"),
./Defunct.R: dig.tst = max(1, min(5, digits - 1)),
./Defunct.R: cs.ind, tst.ind, zap.ind = integer(0),
./Defunct.R: P.values = NULL,
./Defunct.R: has.Pvalue,
./Defunct.R: eps.Pvalue = .Machine$double.eps,
./Defunct.R: na.print = "", ...) .Defunct()
./Defunct.R:codes <- function(x, ...) .Defunct()
./Defunct.R:codes.factor <- function(x, ...) .Defunct("unclass")
./Defunct.R:codes.ordered <- function(x, ...) .Defunct("unclass")
./Defunct.R:"codes<-" <- function(x, ..., value) .Defunct()
./Defunct.R:anovalist.lm <- function (object, ..., test = NULL) .Defunct()
./Defunct.R:lm.fit.null <- function(x, y, method = "qr", tol = 1e-07, ...)
./Defunct.R- .Defunct("lm.fit")
./Defunct.R:lm.wfit.null <- function(x, y, w, method = "qr", tol = 1e-07, ...)
./Defunct.R- .Defunct("lm.wfit")
./Defunct.R:glm.fit.null <- function(x, y, weights , start = NULL,
./Defunct.R: etastart = NULL, mustart = NULL, offset,
./Defunct.R: family = gaussian(), control = glm.control(),
./Defunct.R- intercept = FALSE)
./Defunct.R- .Defunct("glm.fit")
./Defunct.R:print.atomic <- function(x, quote = TRUE, ...) .Defunct("print.default")
./Defunct.R-##
./Defunct.R-
./Defunct.R-##
./Defunct.R-## Deprecated in 1.9.0
./Defunct.R-## Defunct in 2.0.0
./Defunct.R:La.eigen <- function(x, symmetric, only.values = FALSE,
./Defunct.R: method = c("dsyevr", "dsyev")) .Defunct("eigen")
./Defunct.R-tetragamma <- function(x) .Defunct("psigamma")
./Defunct.R-pentagamma <- function(x) .Defunct("psigamma")
./Defunct.R:package.description <- function(pkg, lib.loc = NULL, fields = NULL)
./Defunct.R- .Defunct("packageDescription")
./Defunct.R-##
--
./Deprecated.R-###----- NOTE: ../man/Deprecated.Rd must be synchronized with this!
./Deprecated.R-### --------------------
./Deprecated.R:.Deprecated <- function(new, package=NULL) {
./Deprecated.R: msg <- gettextf("'%s' is deprecated.\n",
./Deprecated.R- as.character(sys.call(sys.parent())[[1]]))
./Deprecated.R- if(!missing(new))
./Deprecated.R: msg <- c(msg, gettextf("Use '%s' instead.\n", new))
./Deprecated.R- if(!is.null(package))
./Deprecated.R: msg <- c(msg,
./Deprecated.R: gettextf("See help(\"Deprecated\") and help(\"%s-deprecated\").", package))
./Deprecated.R: else msg <- c(msg, gettext("See help(\"Deprecated\")"))
./Deprecated.R: warning(paste(msg, collapse=""), call. = FALSE, domain = NA)
./Deprecated.R-}
./Deprecated.R-
./Deprecated.R:## consider keeping one (commented) entry here, for easier additions
./Deprecated.R-
./Deprecated.R-##
./Deprecated.R-## Deprecated in 2.1.0
./Deprecated.R:loadURL <- function (url, envir = parent.frame(), quiet = TRUE, ...)
./Deprecated.R-{
./Deprecated.R- .Deprecated("load(url())")
./Deprecated.R- tmp <- tempfile("url")
./Deprecated.R: download.file(url, tmp, quiet = quiet, ...)
./Deprecated.R- on.exit(unlink(tmp))
./Deprecated.R: load(tmp, envir = envir)
./Deprecated.R-}
./Deprecated.R-##
./Deprecated.R-
./Deprecated.R-##
./Deprecated.R-## Deprecated in 2.1.0
./Deprecated.R:delay <- function(x, env=.GlobalEnv) {
./Deprecated.R- .Deprecated("delayedAssign")
./Deprecated.R: .Internal(delay(substitute(x), env))
./Deprecated.R-}
./Deprecated.R-##
--
./LAPACK.R:La.svd <- function(x, nu = min(n, p), nv = min(n, p),
./LAPACK.R: method = c("dgesdd", "dgesvd"))
./LAPACK.R-{
./LAPACK.R- if(!is.numeric(x) && !is.complex(x))
./LAPACK.R- stop("argument to 'La.svd' must be numeric or complex")
--
./LAPACK.R- if(!n || !p) stop("0 extent dimensions")
./LAPACK.R-
./LAPACK.R- if(method == "dgesvd") {
./LAPACK.R- if(nu == 0) {
./LAPACK.R- jobu <- 'N'
./LAPACK.R: u <- matrix(0, 1, 1) # dim is checked
./LAPACK.R- }
./LAPACK.R- else if(nu == n) {
./LAPACK.R: jobu <- ifelse(n > p, 'A', 'S')
./LAPACK.R: u <- matrix(0, n, n)
./LAPACK.R- }
./LAPACK.R- else if(nu == p) {
./LAPACK.R: jobu <- ifelse(n > p, 'S', 'A')
./LAPACK.R: u <- matrix(0, n, p)
./LAPACK.R- }
./LAPACK.R- else
./LAPACK.R: stop("'nu' must be 0, nrow(x) or ncol(x)")
./LAPACK.R-
./LAPACK.R- if (nv == 0) {
./LAPACK.R- jobv <- 'N'
./LAPACK.R: v <- matrix(0, 1, 1) # dim is checked
./LAPACK.R- }
./LAPACK.R- else if (nv == n) {
./LAPACK.R: jobv <- ifelse(n > p, 'A', 'S')
./LAPACK.R: v <- matrix(0, min(n, p), p)
./LAPACK.R- }
./LAPACK.R- else if (nv == p) {
./LAPACK.R: jobv <- ifelse(n > p, 'S', 'A')
./LAPACK.R: v <- matrix(0, p, p)
./LAPACK.R- }
./LAPACK.R- else
./LAPACK.R: stop("'nv' must be 0, nrow(x) or ncol(x)")
./LAPACK.R- } else {
./LAPACK.R- if(nu > 0 || nv > 0) {
./LAPACK.R: np <- min(n, p)
./LAPACK.R- if(nu <= np && nv <= np) {
./LAPACK.R- jobu <- 'S'
./LAPACK.R: u <- matrix(0, n, np)
./LAPACK.R: v <- matrix(0, np, p)
./LAPACK.R- } else {
./LAPACK.R- jobu <- 'A'
./LAPACK.R: u <- matrix(0, n, n)
./LAPACK.R: v <- matrix(0, p, p)
./LAPACK.R- }
./LAPACK.R- } else {
./LAPACK.R- jobu <- 'N'
./LAPACK.R: # these dimensions _are_ checked, but unused
./LAPACK.R: u <- matrix(0, 1, 1)
./LAPACK.R: v <- matrix(0, 1, 1)
./LAPACK.R- }
./LAPACK.R- jobv <- ''
./LAPACK.R: res <- .Call("La_svd", jobu, jobv, x, double(min(n,p)), u, v,
./LAPACK.R: method, PACKAGE = "base")
./LAPACK.R: res <- res[c("d", if(nu) "u", if(nv) "vt")]
./LAPACK.R: if(nu) res$u <- res$u[, 1:min(n, nu), drop = FALSE]
./LAPACK.R: if(nv) res$vt <- res$vt[1:min(p, nv), , drop = FALSE]
./LAPACK.R- return(res)
./LAPACK.R- }
./LAPACK.R-
./LAPACK.R- if(is.complex(x)) {
./LAPACK.R- u[] <- as.complex(u)
./LAPACK.R- v[] <- as.complex(v)
./LAPACK.R: res <- .Call("La_svd_cmplx", jobu, jobv, x, double(min(n, p)), u, v,
./LAPACK.R- PACKAGE = "base")
./LAPACK.R- } else
./LAPACK.R: res <- .Call("La_svd", jobu, jobv, x, double(min(n, p)), u, v,
./LAPACK.R: method, PACKAGE = "base")
./LAPACK.R: res[c("d", if(nu) "u", if(nv) "vt")]
./LAPACK.R-}
./LAPACK.R-
./LAPACK.R:La.chol <- function(x) .Call("La_chol", as.matrix(x), PACKAGE = "base")
./LAPACK.R-
./LAPACK.R:La.chol2inv <- function(x, size = ncol(x)) {
./LAPACK.R- x <- as.matrix(x) # do it this way so ncol(x) is defined
./LAPACK.R: .Call("La_chol2inv", x, size, PACKAGE = "base")
./LAPACK.R-}
--
./New-Internal.R-geterrmessage <- function() .Internal(geterrmessage())
./New-Internal.R-
./New-Internal.R:try <- function(expr, silent = FALSE)
./New-Internal.R-{
./New-Internal.R: if (! exists("first", inherits = FALSE)) {
./New-Internal.R- first <- FALSE
./New-Internal.R: # turn on the restart bit of the current context, push an
./New-Internal.R: # error handler on the condition handler stack, and push
./New-Internal.R- # a tryRestart restart on the restart stack
./New-Internal.R- .Internal(.addTryHandlers())
./New-Internal.R- if (silent) {
--
./New-Internal.R- on.exit(options(op))
./New-Internal.R- options(show.error.messages = FALSE)
./New-Internal.R- }
./New-Internal.R- expr
./New-Internal.R- }
./New-Internal.R: else invisible(structure(.Internal(geterrmessage()), class = "try-error"))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R-
./New-Internal.R-comment <- function(x).Internal(comment(x))
./New-Internal.R:"comment<-" <- function(x,value).Internal("comment<-"(x,value))
./New-Internal.R-
./New-Internal.R:round <- function(x, digits = 0).Internal(round(x,digits))
./New-Internal.R:signif <- function(x, digits = 6).Internal(signif(x,digits))
./New-Internal.R:logb <- log <- function(x, base=exp(1))
./New-Internal.R: if(missing(base)).Internal(log(x)) else .Internal(log(x,base))
./New-Internal.R-log1p <- function(x).Internal(log1p(x))
./New-Internal.R-expm1 <- function(x).Internal(expm1(x))
./New-Internal.R-
./New-Internal.R:atan2 <- function(y, x).Internal(atan2(y, x))
./New-Internal.R-
./New-Internal.R:beta <- function(a, b).Internal( beta(a, b))
./New-Internal.R:lbeta <- function(a, b).Internal(lbeta(a, b))
./New-Internal.R-
./New-Internal.R-gamma <- function(x).Internal( gamma(x))
./New-Internal.R-lgamma <- function(x).Internal(lgamma(x))
./New-Internal.R-digamma <- function(x).Internal( digamma(x))
./New-Internal.R-trigamma <- function(x).Internal( trigamma(x))
./New-Internal.R:psigamma <- function(x, deriv=0) .Internal(psigamma(x, deriv))
./New-Internal.R:## tetragamma, pentagamma : deprecated in 1.9.0
./New-Internal.R-
./New-Internal.R-factorial <- function(x) gamma(x + 1)
./New-Internal.R-lfactorial <- function(x) lgamma(x + 1)
./New-Internal.R-
./New-Internal.R:choose <- function(n,k).Internal(choose(n,k))
./New-Internal.R:lchoose <- function(n,k).Internal(lchoose(n,k))
./New-Internal.R-
./New-Internal.R-##-- 2nd part --
./New-Internal.R-# Machine <- function().Internal(Machine())
./New-Internal.R-R.Version <- function().Internal(Version())
./New-Internal.R-commandArgs <- function() .Internal(commandArgs())
./New-Internal.R-
./New-Internal.R-args <- function(name).Internal(args(name))
./New-Internal.R-
./New-Internal.R:##=== Problems here [[ attr(f, "class") <- "factor" fails in factor(..) ]]:
./New-Internal.R:##- attr <- function(x, which).Internal(attr(x, which))
./New-Internal.R:##- "attr<-" <- function(x, which, value).Internal("attr<-"(x, which, value))
./New-Internal.R-
./New-Internal.R:cbind <- function(..., deparse.level=1) {
./New-Internal.R- if(deparse.level != 1) .NotYetUsed("deparse.level != 1")
./New-Internal.R- .Internal(cbind(...))
./New-Internal.R-}
./New-Internal.R:rbind <- function(..., deparse.level=1) {
./New-Internal.R- if(deparse.level != 1) .NotYetUsed("deparse.level != 1")
./New-Internal.R- .Internal(rbind(...))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R-# convert deparsing options to bitmapped integer
./New-Internal.R-
./New-Internal.R-.deparseOpts <- function(control) {
./New-Internal.R: opts <- pmatch(as.character(control), c("keepInteger", "quoteExpressions",
./New-Internal.R: "showAttributes", "useSource", "warnIncomplete", "all", "delayPromises"))
./New-Internal.R- if (any(is.na(opts)))
./New-Internal.R: stop(sprintf(ngettext(as.integer(sum(is.na(opts))),
./New-Internal.R: "deparse option %s is not recognized",
./New-Internal.R: "deparse options %s are not recognized"),
./New-Internal.R: paste(sQuote(control[is.na(opts)]), collapse=", ")),
./New-Internal.R: call. = FALSE, domain = NA)
./New-Internal.R- if (any(opts == 6)) {
./New-Internal.R- if (length(opts) != 1)
./New-Internal.R: stop("all can not be used with other deparse options",
./New-Internal.R- call. = FALSE)
./New-Internal.R- else
./New-Internal.R- return(31)
./New-Internal.R- } else return(sum(2^(opts-1)))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R:deparse <- function(expr, width.cutoff = 60,
./New-Internal.R: backtick = mode(expr) %in% c("call","expression","("),
./New-Internal.R- control = "showAttributes") {
./New-Internal.R- opts <- .deparseOpts(control)
./New-Internal.R: .Internal(deparse(expr, width.cutoff, backtick, opts))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R:do.call <- function(what,args,quote=FALSE) {
./New-Internal.R: enquote <- function(x) as.call(list(as.name("quote"), x))
./New-Internal.R- if( !is.list(args) )
./New-Internal.R- stop("second argument must be a list")
./New-Internal.R: if( quote ) args = lapply(args, enquote)
./New-Internal.R: .Internal(do.call(what,args))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R-drop <- function(x).Internal(drop(x))
./New-Internal.R:format.info <- function(x, nsmall=0).Internal(format.info(x, nsmall))
./New-Internal.R:gc <- function(verbose = getOption("verbose"), reset=FALSE)
./New-Internal.R-{
./New-Internal.R: res <-.Internal(gc(verbose,reset))/c(1, 1, 10, 10, 1, 1, rep(10,4),rep(1,2),rep(10,2))
./New-Internal.R: res <- matrix(res, 2, 7,
./New-Internal.R: dimnames = list(c("Ncells","Vcells"),
./New-Internal.R: c("used", "(Mb)", "gc trigger", "(Mb)", "limit (Mb)","max used", "(Mb)")))
./New-Internal.R: if(all(is.na(res[, 5]))) res[, -5] else res
./New-Internal.R-}
./New-Internal.R-gcinfo <- function(verbose).Internal(gcinfo(verbose))
./New-Internal.R-gctorture <- function(on=TRUE)invisible(.Internal(gctorture(on)))
./New-Internal.R-
./New-Internal.R:is.unsorted <- function(x, na.rm = FALSE) {
./New-Internal.R- if(is.null(x)) return(FALSE)
./New-Internal.R- if(!is.atomic(x) ||
./New-Internal.R- (!na.rm && any(is.na(x))))
--
./New-Internal.R- if(na.rm && any(ii <- is.na(x)))
./New-Internal.R- x <- x[!ii]
./New-Internal.R- .Internal(is.unsorted(x))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R:mem.limits <- function(nsize=NA, vsize=NA)
./New-Internal.R-{
./New-Internal.R: structure(.Internal(mem.limits(as.integer(nsize), as.integer(vsize))),
./New-Internal.R: names=c("nsize", "vsize"))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R:nchar <- function(x, type = c( "bytes", "chars", "width"))
./New-Internal.R: .Internal(nchar(x, match.arg(type)))
./New-Internal.R-
./New-Internal.R-polyroot <- function(z).Internal(polyroot(z))
./New-Internal.R-
--
./New-Internal.R-search <- function().Internal(search())
./New-Internal.R-searchpaths <- function()
./New-Internal.R-{
./New-Internal.R- s <- search()
./New-Internal.R- paths <-
./New-Internal.R: lapply(1:length(s), function(i) attr(as.environment(i), "path"))
./New-Internal.R- paths[[length(s)]] <- system.file()
./New-Internal.R: m <- grep("^package:", s)
./New-Internal.R- if(length(m)) paths[-m] <- as.list(s[-m])
./New-Internal.R- unlist(paths)
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R:sprintf <- function(fmt, ...) .Internal(sprintf(fmt, ...))
./New-Internal.R-
./New-Internal.R-##-- DANGER ! --- substitute(list(...)) inside functions !!!
./New-Internal.R:##substitute <- function(expr, env=NULL).Internal(substitute(expr, env))
./New-Internal.R-
./New-Internal.R-t.default <- function(x).Internal(t.default(x))
./New-Internal.R-typeof <- function(x).Internal(typeof(x))
--
./New-Internal.R-capabilities <- function(what = NULL)
./New-Internal.R-{
./New-Internal.R- z <- .Internal(capabilities())
./New-Internal.R- if(is.null(what)) return(z)
./New-Internal.R- nm <- names(z)
./New-Internal.R: i <- pmatch(what, nm)
./New-Internal.R- if(is.na(i)) logical(0) else z[i]
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R:inherits <- function(x, what, which = FALSE)
./New-Internal.R: .Internal(inherits(x, what, which))
./New-Internal.R-
./New-Internal.R:NextMethod <- function(generic=NULL, object=NULL, ...)
./New-Internal.R: .Internal(NextMethod(generic, object,...))
./New-Internal.R-
./New-Internal.R-data.class <- function(x) {
./New-Internal.R- if (length(cl <- oldClass(x)))
--
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R-is.numeric.factor <- function(x) FALSE
./New-Internal.R-is.integer.factor <- function(x) FALSE
./New-Internal.R-
./New-Internal.R:encodeString <- function(x, w = 0, quote = "", na = TRUE,
./New-Internal.R: justify = c("left", "right", "centre"))
./New-Internal.R-{
./New-Internal.R- at <- attributes(x)
./New-Internal.R- x <- as.character(x) # we want e.g. NULL to work
./New-Internal.R: attributes(x) <- at # preserve names, dim etc
./New-Internal.R- oldClass(x) <- NULL # but not class
./New-Internal.R: justify <- match(match.arg(justify), c("left", "right", "centre")) - 1
./New-Internal.R: .Internal(encodeString(x, w, quote, justify, na))
./New-Internal.R-}
./New-Internal.R-
./New-Internal.R-l10n_info <- function() .Internal(l10n_info())
--
./RNG.R-## Random Number Generator
./RNG.R-
./RNG.R-## The available kinds are in
./RNG.R-## ../../../include/Random.h and ../../../main/RNG.c [RNG_Table]
./RNG.R-##
./RNG.R:RNGkind <- function(kind = NULL, normal.kind = NULL)
./RNG.R-{
./RNG.R: kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
./RNG.R: "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
./RNG.R: "Knuth-TAOCP-2002", "default")
./RNG.R: n.kinds <- c("Buggy Kinderman-Ramage", "Ahrens-Dieter", "Box-Muller",
./RNG.R: "user-supplied", "Inversion", "Kinderman-Ramage",
./RNG.R- "default")
./RNG.R- do.set <- length(kind) > 0
./RNG.R- if(do.set) {
./RNG.R- if(!is.character(kind) || length(kind) > 1)
./RNG.R- stop("'kind' must be a character string of length 1 (RNG to be used).")
./RNG.R: if(is.na(i.knd <- pmatch(kind, kinds) - 1))
./RNG.R: stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind),
./RNG.R- domain = NA)
./RNG.R- if(i.knd == length(kinds) - 1) i.knd <- -1
./RNG.R- } else i.knd <- NULL
--
./RNG.R- if(!is.null(normal.kind)) {
./RNG.R- if(!is.character(normal.kind) || length(normal.kind) > 1)
./RNG.R- stop("'normal.kind' must be a character string of length 1.")
./RNG.R- if (normal.kind == "Buggy Kinderman-Ramage")
./RNG.R- warning("Buggy version of Kinderman-Ramage generator used.")
./RNG.R: normal.kind <- pmatch(normal.kind, n.kinds) - 1
./RNG.R- if(is.na(normal.kind))
./RNG.R: stop(gettextf("'%s' is not a valid choice", normal.kind),
./RNG.R- domain = NA)
./RNG.R- if(normal.kind == length(n.kinds) - 1) normal.kind <- -1
./RNG.R- }
./RNG.R: r <- 1 + .Internal(RNGkind(i.knd, normal.kind))
./RNG.R: r <- c(kinds[r[1]], n.kinds[r[2]])
./RNG.R- if(do.set || !is.null(normal.kind)) invisible(r) else r
./RNG.R-}
./RNG.R-
./RNG.R:set.seed <- function(seed, kind = NULL)
./RNG.R-{
./RNG.R: kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
./RNG.R: "Mersenne-Twister", "Knuth-TAOCP", "user-supplied",
./RNG.R: "Knuth-TAOCP-2002", "default")
./RNG.R- if(length(kind) > 0) {
./RNG.R- if(!is.character(kind) || length(kind) > 1)
./RNG.R- stop("'kind' must be a character string of length 1 (RNG to be used).")
./RNG.R: if(is.na(i.knd <- pmatch(kind, kinds) - 1))
./RNG.R: stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind),
./RNG.R- domain = NA)
./RNG.R- if(i.knd == length(kinds) - 1) i.knd <- -1
./RNG.R- } else i.knd <- NULL
./RNG.R-
./RNG.R: invisible(.Internal(set.seed(seed, i.knd)))
./RNG.R-}
./RNG.R-
./RNG.R-# Compatibility function to set RNGkind as in a given R version
./RNG.R-
./RNG.R-RNGversion <- function(vstr)
./RNG.R-{
./RNG.R: vnum <- as.numeric(strsplit(vstr,".", fixed=TRUE)[[1]])
./RNG.R- if (length(vnum) < 2)
./RNG.R- stop("malformed version string")
./RNG.R- if (vnum[1] == 0 && vnum[2] < 99)
./RNG.R: RNGkind("Wichmann-Hill", "Buggy Kinderman-Ramage")
./RNG.R- else if (vnum[1] == 0 || vnum[1] == 1 && vnum[2] <= 6)
./RNG.R: RNGkind("Marsaglia-Multicarry", "Buggy Kinderman-Ramage")
./RNG.R- else
./RNG.R: RNGkind("Mersenne-Twister", "Inversion")
./RNG.R-}
--
./Scripts.R-.Script <-
./Scripts.R:function(interpreter, script, args, ...)
./Scripts.R-{
./Scripts.R- if(.Platform$OS.type == "windows") {
./Scripts.R: cmd <- paste(file.path(R.home(), "bin", "Rcmd"),
./Scripts.R: file.path("..", "share", interpreter, script),
./Scripts.R- args)
./Scripts.R: system(cmd, invisible = TRUE)
./Scripts.R- }
./Scripts.R- else
./Scripts.R: system(paste(shQuote(file.path(R.home(), "bin", "Rcmd")),
./Scripts.R: interpreter,
./Scripts.R: shQuote(file.path(R.home(), "share",
./Scripts.R: interpreter, script)),
./Scripts.R: args),
./Scripts.R- ...)
./Scripts.R-}
--
./all.equal.R:all.equal <- function(target, current, ...) UseMethod("all.equal")
./all.equal.R-
./all.equal.R:## NO: is.*(x) should be like S4 is(x, *) ! -- use isTRUE(all.equal(*))
./all.equal.R:## is.all.equal <- function(target, current, ...)
./all.equal.R:## identical(TRUE, all.equal(target, current, ...))
./all.equal.R-
./all.equal.R:all.equal.default <- function(target, current, ...)
./all.equal.R-{
./all.equal.R- ## Really a dispatcher given mode() of args :
./all.equal.R- ## use data.class as unlike class it does not give "Integer"
./all.equal.R- if(is.language(target) || is.function(target))
./all.equal.R: return(all.equal.language(target, current, ...))
./all.equal.R- if(is.recursive(target))
./all.equal.R: return(all.equal.list(target, current, ...))
./all.equal.R: msg <- c(attr.all.equal(target, current, ...),
./all.equal.R- if(is.numeric(target)) {
./all.equal.R: all.equal.numeric(target, current, ...)
./all.equal.R- } else
./all.equal.R: switch (mode(target),
./all.equal.R: logical = ,
./all.equal.R: complex = ,
./all.equal.R: numeric = all.equal.numeric(target, current, ...),
./all.equal.R: character = all.equal.character(target, current, ...),
./all.equal.R- if(data.class(target) != data.class(current)) {
./all.equal.R: paste("target is ", data.class(target), ", current is ",
./all.equal.R: data.class(current), sep = "")
./all.equal.R- } else NULL))
./all.equal.R- if(is.null(msg)) TRUE else msg
./all.equal.R-}
./all.equal.R-
./all.equal.R-all.equal.numeric <-
./all.equal.R:function(target, current, tolerance = .Machine$double.eps ^ .5,
./all.equal.R: scale=NULL, ...)
./all.equal.R-{
./all.equal.R- if(data.class(target) != data.class(current))
./all.equal.R: return(paste("target is ", data.class(target), ", current is ",
./all.equal.R: data.class(current), sep = ""))
./all.equal.R- lt <- length(target)
./all.equal.R- lc <- length(current)
./all.equal.R- cplx <- is.complex(target)
./all.equal.R- if(lt != lc)
./all.equal.R: return(paste(if(cplx)"Complex" else "Numeric",
./all.equal.R: ": lengths (", lt, ", ", lc, ") differ", sep = ""))
./all.equal.R- target <- as.vector(target)
./all.equal.R- current <- as.vector(current)
./all.equal.R- out <- is.na(target)
./all.equal.R- if(any(out != is.na(current)))
./all.equal.R: return(paste("`is.NA' value mismatches:", sum(is.na(current)),
./all.equal.R: "in current,", sum(out), " in target"))
./all.equal.R- out <- out | target == current
./all.equal.R- if(all(out)) return(TRUE)
./all.equal.R- target <- target[!out]
--
./all.equal.R- } else {
./all.equal.R- xy <- xy/scale
./all.equal.R- "scaled"
./all.equal.R- }
./all.equal.R- if(is.na(xy) || xy > tolerance)
./all.equal.R: paste("Mean", what, if(cplx)"Mod", "difference:", format(xy)) else TRUE
./all.equal.R-}
./all.equal.R-
./all.equal.R:all.equal.character <- function(target, current, ...)
./all.equal.R-{
./all.equal.R- if(data.class(target) != data.class(current))
./all.equal.R: return(paste("target is ", data.class(target), ", current is ",
./all.equal.R: data.class(current), sep = ""))
./all.equal.R- lt <- length(target)
./all.equal.R- lc <- length(current)
./all.equal.R- if(lt != lc) {
./all.equal.R: msg <- paste("Lengths (", lt, ", ", lc,
./all.equal.R: ") differ (string compare on first ", ll <- min(lt, lc),
./all.equal.R: ")", sep = "")
./all.equal.R- ll <- seq(length = ll)
./all.equal.R- target <- target[ll]
./all.equal.R- current <- current[ll]
./all.equal.R- } else msg <- NULL
./all.equal.R- nas <- is.na(target)
./all.equal.R- if (any(nas != is.na(current)))
./all.equal.R: return(paste("`is.NA' value mismatches:", sum(is.na(current)),
./all.equal.R: "in current,", sum(nas), " in target"))
./all.equal.R- ne <- !nas & (target != current)
./all.equal.R- if(!any(ne) && is.null(msg)) TRUE
./all.equal.R: else if(any(ne)) c(msg, paste(sum(ne), "string mismatches"))
./all.equal.R- else msg
./all.equal.R-}
./all.equal.R-
./all.equal.R:all.equal.factor <- function(target, current, ...)
./all.equal.R-{
./all.equal.R: if(!inherits(current, "factor"))
./all.equal.R- return("`current' is not a factor")
./all.equal.R: msg <- attr.all.equal(target, current)
./all.equal.R- class(target) <- class(current) <- NULL
./all.equal.R- nax <- is.na(target)
./all.equal.R- nay <- is.na(current)
./all.equal.R- if(n <- sum(nax != nay))
./all.equal.R: msg <- c(msg, paste("NA mismatches:", n))
./all.equal.R- else {
./all.equal.R- target <- levels(target)[target[!nax]]
./all.equal.R- current <- levels(current)[current[!nay]]
./all.equal.R: if(is.character(n <- all.equal(target, current)))
./all.equal.R: msg <- c(msg, n)
./all.equal.R- }
./all.equal.R- if(is.null(msg)) TRUE else msg
./all.equal.R-}
./all.equal.R-
./all.equal.R:all.equal.formula <- function(target, current, ...)
./all.equal.R-{
./all.equal.R- if(length(target) != length(current))
./all.equal.R: return(paste("target, current differ in having response: ",
./all.equal.R: length(target) == 3, ", ", length(current) == 3))
./all.equal.R- if(all(deparse(target) != deparse(current)))
./all.equal.R- "formulas differ in contents"
./all.equal.R- else TRUE
./all.equal.R-}
./all.equal.R-
./all.equal.R:all.equal.language <- function(target, current, ...)
./all.equal.R-{
./all.equal.R- mt <- mode(target)
./all.equal.R- mc <- mode(current)
./all.equal.R- if(mt == "expression" && mc == "expression")
./all.equal.R: return(all.equal.list(target, current, ...))
./all.equal.R: ttxt <- paste(deparse(target), collapse = "\n")
./all.equal.R: ctxt <- paste(deparse(current), collapse = "\n")
./all.equal.R- msg <- c(if(mt != mc)
./all.equal.R: paste("Modes of target, current: ", mt, ", ", mc, sep = ""),
./all.equal.R- if(ttxt != ctxt) {
./all.equal.R: if(pmatch(ttxt, ctxt, FALSE))
./all.equal.R- "target a subset of current"
./all.equal.R: else if(pmatch(ctxt, ttxt, FALSE))
./all.equal.R- "current a subset of target"
./all.equal.R: else "target, current don't match when deparsed"
./all.equal.R- })
./all.equal.R- if(is.null(msg)) TRUE else msg
./all.equal.R-}
./all.equal.R-
./all.equal.R:all.equal.list <- function(target, current, ...)
./all.equal.R-{
./all.equal.R: msg <- attr.all.equal(target, current, ...)
./all.equal.R-# nt <- names(target)
./all.equal.R- nc <- names(current)
./all.equal.R- iseq <-
./all.equal.R- ##
./all.equal.R: ## Commenting this eliminates PR#674, and assumes that lists are
./all.equal.R: ## regarded as generic vectors, so that they are equal iff they
./all.equal.R- ## have identical names attributes and all components are equal.
./all.equal.R- ## if(length(nt) && length(nc)) {
./all.equal.R: ## if(any(not.in <- (c.in.t <- match(nc, nt, 0)) == 0))
./all.equal.R: ## msg <- c(msg, paste("Components not in target:",
./all.equal.R: ## paste(nc[not.in], collapse = ", ")))
./all.equal.R: ## if(any(not.in <- match(nt, nc, 0) == 0))
./all.equal.R: ## msg <- c(msg, paste("Components not in current:",
./all.equal.R: ## paste(nt[not.in], collapse = ", ")))
./all.equal.R- ## nt[c.in.t]
./all.equal.R- ## } else
./all.equal.R- ##
./all.equal.R- if(length(target) == length(current)) {
./all.equal.R- seq(along = target)
./all.equal.R- } else {
./all.equal.R: nc <- min(length(target), length(current))
./all.equal.R: msg <- c(msg, paste("Length mismatch: comparison on first",
./all.equal.R: nc, "components"))
./all.equal.R- seq(length = nc)
./all.equal.R- }
./all.equal.R- for(i in iseq) {
./all.equal.R: mi <- all.equal(target[[i]], current[[i]], ...)
./all.equal.R- if(is.character(mi))
./all.equal.R: msg <- c(msg, paste("Component ", i, ": ", mi, sep=""))
./all.equal.R- }
./all.equal.R- if(is.null(msg)) TRUE else msg
./all.equal.R-}
./all.equal.R-
./all.equal.R-
./all.equal.R:attr.all.equal <- function(target, current, ...)
./all.equal.R-{
./all.equal.R- ##--- "all.equal(.)" for attributes ---
./all.equal.R- ##--- Auxiliary in all.equal(.) methods --- return NULL or character()
./all.equal.R- msg <- NULL
./all.equal.R- if(mode(target) != mode(current))
./all.equal.R: msg <- paste("Modes: ", mode(target), ", ", mode(current), sep = "")
./all.equal.R- if(length(target) != length(current))
./all.equal.R: msg <- c(msg, paste("Lengths: ", length(target), ", ",
./all.equal.R: length(current), sep = ""))
./all.equal.R- ax <- attributes(target)
./all.equal.R- ay <- attributes(current)
./all.equal.R- nx <- names(target)
./all.equal.R- ny <- names(current)
./all.equal.R- if((lx <- length(nx)) | (ly <- length(ny))) {
./all.equal.R- ## names() treated now; hence NOT with attributes()
./all.equal.R- ax$names <- ay$names <- NULL
./all.equal.R- if(lx && ly) {
./all.equal.R: if(is.character(m <- all.equal.character(nx, ny)))
./all.equal.R: msg <- c(msg, paste("Names:", m))
./all.equal.R- } else if(lx)
./all.equal.R: msg <- c(msg, "names for target but not for current")
./all.equal.R: else msg <- c(msg, "names for current but not for target")
./all.equal.R- }
./all.equal.R- if(length(ax) || length(ay)) {# some (more) attributes
./all.equal.R- ## order by names before comparison:
./all.equal.R- nx <- names(ax)
./all.equal.R- ny <- names(ay)
./all.equal.R- if(length(nx)) ax <- ax[order(nx)]
./all.equal.R- if(length(ny)) ay <- ay[order(ny)]
./all.equal.R: tt <- all.equal(ax, ay, ...)
./all.equal.R: if(is.character(tt)) msg <- c(msg, paste("Attributes: <", tt, ">"))
./all.equal.R- }
./all.equal.R- msg # NULL or character
./all.equal.R-}
--
./allnames.R:all.names <- function(expr, functions = TRUE, max.names = 200, unique = FALSE)
./allnames.R: .Internal(all.names(expr, functions, max.names, unique))
./allnames.R-
./allnames.R:all.vars <- function(expr, functions = FALSE, max.names = 200, unique = TRUE)
./allnames.R: .Internal(all.names(expr, functions, max.names, unique))
--
./aperm.R:aperm <- function(a, perm, resize=TRUE)
./aperm.R-{
./aperm.R- if (missing(perm))
./aperm.R- perm <- integer(0) # will reverse the order
./aperm.R: .Internal(aperm(a, perm, resize))
./aperm.R-}
--
./append.R:append <- function (x, values, after = length(x))
./append.R-{
./append.R- lengx <- length(x)
./append.R- if (after <= 0)
./append.R: c(values, x)
./append.R- else if (after >= lengx)
./append.R: c(x, values)
./append.R: else c(x[1:after], values, x[(after + 1):lengx])
./append.R-}
--
./apply.R:apply <- function(X, MARGIN, FUN, ...)
./apply.R-{
./apply.R- FUN <- match.fun(FUN)
./apply.R-
--
./apply.R- d2 <- prod(d.ans)
./apply.R- if(d2 == 0) {
./apply.R- ## arrays with some 0 extents: return ``empty result'' trying
./apply.R- ## to use proper mode and dimension:
./apply.R- ## The following is still a bit `hackish': use non-empty X
./apply.R: newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1))
./apply.R: ans <- FUN(if(length(d.call) < 2) newX[,1] else
./apply.R: array(newX[,1], d.call, dn.call), ...)
./apply.R- return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1]
./apply.R: else array(ans, d.ans, dn.ans))
./apply.R- }
./apply.R- ## else
./apply.R: newX <- aperm(X, c(s.call, s.ans))
./apply.R: dim(newX) <- c(prod(d.call), d2)
./apply.R: ans <- vector("list", d2)
./apply.R- if(length(d.call) < 2) {# vector
./apply.R: if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL))
./apply.R: for(i in 1:d2) ans[[i]] <- FUN(newX[,i], ...)
./apply.R- } else
./apply.R: for(i in 1:d2) ans[[i]] <- FUN(array(newX[,i], d.call, dn.call), ...)
./apply.R-
./apply.R- ## answer dims and dimnames
./apply.R-
./apply.R- ans.list <- is.recursive(ans[[1]])
./apply.R- l.ans <- length(ans[[1]])
./apply.R-
./apply.R- ans.names <- names(ans[[1]])
./apply.R- if(!ans.list)
./apply.R: ans.list <- any(unlist(lapply(ans, length)) != l.ans)
./apply.R- if(!ans.list && length(ans.names)) {
./apply.R: all.same <- sapply(ans, function(x) identical(names(x), ans.names))
./apply.R- if (!all(all.same)) ans.names <- NULL
./apply.R- }
./apply.R: len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE))
./apply.R- if(length(MARGIN) == 1 && len.a == d2) {
./apply.R- names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] # else NULL
./apply.R- return(ans)
./apply.R- }
./apply.R- if(len.a == d2)
./apply.R: return(array(ans, d.ans, dn.ans))
./apply.R- if(len.a > 0 && len.a %% d2 == 0) {
./apply.R: if(is.null(dn.ans)) dn.ans <- vector(mode="list", length(d.ans))
./apply.R: dn.ans <- c(list(ans.names), dn.ans)
./apply.R: return(array(ans, c(len.a %/% d2, d.ans),
./apply.R: if(!all(sapply(dn.ans, is.null))) dn.ans))
./apply.R- }
./apply.R- return(ans)
./apply.R-}
--
./array.R-array <-
./array.R:function(data = NA, dim = length(data), dimnames = NULL)
./array.R-{
./array.R- data <- as.vector(data)
./array.R- vl <- prod(dim)
./array.R- if(length(data) != vl) {
./array.R- if(vl > .Machine$integer.max)
./array.R- stop("'dim' specifies too large an array")
./array.R: data <- rep(data, length.out=vl)
./array.R- }
./array.R- if(length(dim))
./array.R- dim(data) <- dim
--
./array.R- dimnames(data) <- dimnames
./array.R- data
./array.R-}
./array.R-
./array.R-slice.index <-
./array.R:function(x, MARGIN)
./array.R-{
./array.R- d <- dim(x)
./array.R- if(is.null(d))
--
./array.R- n <- length(d)
./array.R-
./array.R- if((length(MARGIN) > 1) || (MARGIN < 1) || (MARGIN > n))
./array.R- stop("incorrect value for 'MARGIN'")
./array.R-
./array.R: if(any(d == 0)) return(array(integer(0), d))
./array.R-
./array.R: y <- rep.int(rep.int(seq(1 : d[MARGIN]),
./array.R: prod(d[seq(length = MARGIN - 1)]) * rep.int(1, d[MARGIN])),
./array.R: prod(d[seq(from = MARGIN + 1, length = n - MARGIN)]))
./array.R- dim(y) <- d
./array.R- y
./array.R-}
--
./as.R:as.logical <- function(x,...) UseMethod("as.logical")
./as.R:as.logical.default<-function(x,...) .Internal(as.vector(x,"logical"))
./as.R-
./as.R:as.integer <- function(x,...) UseMethod("as.integer")
./as.R:as.integer.default <- function(x,...) .Internal(as.vector(x,"integer"))
./as.R-
./as.R:as.double <- function(x,...) UseMethod("as.double")
./as.R:as.double.default <- function(x,...) .Internal(as.vector(x,"double"))
./as.R-as.real <- as.double
./as.R-
./as.R:as.complex <- function(x,...) UseMethod("as.complex")
./as.R:as.complex.default <- function(x,...) .Internal(as.vector(x, "complex"))
./as.R-
./as.R:as.single <- function(x,...) UseMethod("as.single")
./as.R:as.single.default <- function(x,...) {
./as.R: structure(.Internal(as.vector(x,"double")), Csingle=TRUE)
./as.R-}
./as.R-
./as.R-# as.character is now internal. The default method remains here to
./as.R-# preserve the semantics that for a call with an object argument
./as.R-# dispatching is done first on as.character and then on as.vector.
./as.R:as.character.default <- function(x,...) .Internal(as.vector(x,"character"))
./as.R-
./as.R:as.expression <- function(x,...) UseMethod("as.expression")
./as.R:as.expression.default <- function(x,...) .Internal(as.vector(x,"expression"))
./as.R-
./as.R:as.list <- function(x,...) UseMethod("as.list")
./as.R:as.list.default <- function (x,...)
./as.R-{
./as.R- if (is.function(x))
./as.R: return(c(formals(x), list(body(x))))
./as.R- if (is.expression(x)) {
./as.R- n <- length(x)
./as.R: l <- vector("list", n)
./as.R- i <- 0
./as.R- for (sub in x) l[[i <- i + 1]] <- sub
./as.R- return(l)
./as.R- }
./as.R: .Internal(as.vector(x, "list"))
./as.R-}
./as.R:## FIXME: Really the above as.vector(x, "list") should work for data.frames!
./as.R:as.list.data.frame <- function(x,...) {
./as.R- x <- unclass(x)
./as.R: attr(x,"row.names") <- NULL
./as.R- x
./as.R-}
./as.R-
./as.R:as.list.environment <- function(x, all.names=FALSE, ...)
./as.R: .Internal(env2list(x, all.names))
./as.R-
./as.R-##as.vector dispatches internally so no need for a generic
./as.R:as.vector <- function(x, mode="any") .Internal(as.vector(x,mode))
./as.R-as.matrix <- function(x) UseMethod("as.matrix")
./as.R-as.matrix.default <- function(x) {
./as.R- if (is.matrix(x))
./as.R- x
./as.R- else
./as.R: array(x, c(length(x),1),
./as.R: if(!is.null(names(x))) list(names(x), NULL) else NULL)
./as.R-}
./as.R:as.null <- function(x,...) UseMethod("as.null")
./as.R:as.null.default <- function(x,...) NULL
./as.R-
./as.R:as.function <- function(x,...) UseMethod("as.function")
./as.R:as.function.default <- function (x, envir = parent.frame(), ...)
./as.R: if (is.function(x)) x else .Internal(as.function.default(x, envir))
./as.R-
./as.R-as.array <- function(x)
./as.R-{
--
./as.R- dim(x) <- length(x)
./as.R- if(length(n)) dimnames(x) <- list(n)
./as.R- return(x)
./as.R-}
./as.R-
./as.R:as.symbol <- function(x) .Internal(as.vector(x, "symbol"))
./as.R-as.name <- as.symbol
./as.R:## would work too: as.name <- function(x) .Internal(as.vector(x, "name"))
./as.R-
./as.R-## as.call <- function(x) stop("type call cannot be assigned")
./as.R-as.numeric <- as.double
--
./assign.R-assign <-
./assign.R: function (x, value, pos = -1, envir = as.environment(pos),
./assign.R: inherits = FALSE, immediate = TRUE)
./assign.R: .Internal(assign(x, value, envir, inherits))
--
./attach.R:attach <- function(what, pos=2, name=deparse(substitute(what)))
./attach.R-{
./attach.R- if(pos == 1) {
./attach.R: warning("*** 'pos=1' is not possible; setting 'pos=2' for now.\n",
./attach.R- "*** Note that 'pos=1' will give an error in the future")
./attach.R- pos <- 2
./attach.R- }
./attach.R- if (is.character(what) && (length(what)==1)){
./attach.R- if (!file.exists(what))
./attach.R: stop(gettextf("file '%s' not found", what), domain = NA)
./attach.R: name <- paste("file:", what, sep="")
./attach.R: value <- .Internal(attach(NULL, pos, name))
./attach.R: load(what, envir=as.environment(pos))
./attach.R- }
./attach.R- else
./attach.R: value <- .Internal(attach(what, pos, name))
./attach.R: if((length(objects(envir = value, all=TRUE)) > 0)
./attach.R- && .isMethodsDispatchOn())
./attach.R: methods:::cacheMetaData(value, TRUE)
./attach.R- invisible(value)
./attach.R-}
./attach.R-
./attach.R:detach <- function(name, pos=2, version)
./attach.R-{
./attach.R- if(!missing(name)) {
./attach.R- name <- substitute(name)# when a name..
--
./attach.R- name
./attach.R- else {
./attach.R- if (!is.character(name))
./attach.R- name <- deparse(name)
./attach.R- if (!missing(version))
./attach.R: name <- manglePackageName(name, version)
./attach.R: match(name, search())
./attach.R- }
./attach.R- if(is.na(pos))
./attach.R- stop("invalid name")
./attach.R- }
./attach.R- env <- as.environment(pos)
./attach.R- packageName <- search()[[pos]]
./attach.R: libpath <- attr(env, "path")
./attach.R: if(length(grep("^package:", packageName))) {
./attach.R: pkgname <- sub("^package:", "", packageName)
./attach.R: hook <- getHook(packageEvent(pkgname, "detach")) # might be list()
./attach.R: for(fun in rev(hook)) try(fun(pkgname, libpath))
./attach.R- }
./attach.R: if(exists(".Last.lib", mode = "function", where = pos, inherits=FALSE)) {
./attach.R: .Last.lib <- get(".Last.lib", mode = "function", pos = pos,
./attach.R- inherits=FALSE)
./attach.R- if(!is.null(libpath)) try(.Last.lib(libpath))
./attach.R- }
./attach.R- .Internal(detach(pos))
./attach.R- ## note: here the code internally assumes the separator is "/" even
./attach.R- ## on Windows.
./attach.R: if(length(grep("^package:", packageName)))
./attach.R: .Call("R_lazyLoadDBflush",
./attach.R: paste(libpath, "/R/", pkgname, ".rdb", sep=""), PACKAGE="base")
./attach.R- ## Check for detaching a package required by another package (not
./attach.R- ## by .GlobalEnv because detach() can't currently fix up the
./attach.R- ## .required there)
./attach.R- for(pkgs in search()[-1]) {
./attach.R- if(!isNamespace(as.environment(pkgs)) &&
./attach.R: exists(".required", pkgs, inherits = FALSE) &&
./attach.R: packageName %in% paste("package:", get(".required", pkgs, inherits = FALSE),sep=""))
./attach.R: warning(packageName, " is required by ", pkgs, " (still attached)")
./attach.R- }
./attach.R- if(.isMethodsDispatchOn())
./attach.R: methods:::cacheMetaData(env, FALSE)
./attach.R-}
./attach.R-
./attach.R-ls <- objects <-
./attach.R: function (name, pos = -1, envir = as.environment(pos), all.names = FALSE,
./attach.R- pattern)
./attach.R-{
./attach.R- if (!missing(name)) {
./attach.R- nameValue <- try(name)
./attach.R: if(identical(class(nameValue), "try-error")) {
./attach.R- name <- substitute(name)
./attach.R- if (!is.character(name))
./attach.R- name <- deparse(name)
./attach.R- pos <- name
./attach.R- }
./attach.R- else
./attach.R- pos <- nameValue
./attach.R- }
./attach.R: all.names <- .Internal(ls(envir, all.names))
./attach.R- if (!missing(pattern)) {
./attach.R: if ((ll <- length(grep("[", pattern, fixed=TRUE))) > 0 &&
./attach.R: ll != length(grep("]", pattern, fixed=TRUE))) {
./attach.R- if (pattern == "[") {
./attach.R- pattern <- "\\["
./attach.R- warning("replaced regular expression pattern '[' by '\\\\['")
./attach.R- }
./attach.R: else if (length(grep("[^\\\\]\\[<-", pattern) > 0)) {
./attach.R: pattern <- sub("\\[<-", "\\\\\\[<-", pattern)
./attach.R- warning("replaced '[<-' by '\\\\[<-' in regular expression pattern")
./attach.R- }
./attach.R- }
./attach.R: grep(pattern, all.names, value = TRUE)
./attach.R- }
./attach.R- else all.names
./attach.R-}
--
./attr.R:"mostattributes<-" <- function(obj, value) {
./attr.R- if(length(value)) {
./attr.R- if(!is.list(value)) stop("RHS must be list")
./attr.R: if(h.nam <- !is.na(inam <- match("names", names(value)))) {
./attr.R- n1 <- value[[inam]]; value <- value[-inam] }
./attr.R: if(h.dim <- !is.na(idin <- match("dim", names(value)))) {
./attr.R- d1 <- value[[idin]]; value <- value[-idin] }
./attr.R: if(h.dmn <- !is.na(idmn <- match("dimnames", names(value)))) {
./attr.R- dn1 <- value[[idmn]]; value <- value[-idmn] }
./attr.R- attributes(obj) <- value
./attr.R- dm <- dim(obj)
./attr.R- if(h.nam && is.null(dm) && length(obj) == length(n1))
./attr.R- names(obj) <- n1
./attr.R- if(h.dim && length(obj) == prod(d1))
./attr.R- dim(obj) <- dm <- d1
./attr.R- if(h.dmn && !is.null(dm)) {
./attr.R: ddn <- sapply(dn1, length)
./attr.R- if( all((dm == ddn)[ddn > 0]) ) dimnames(obj) <- dn1
./attr.R- }
./attr.R- }
--
./autoload.R:autoload <- function(name, package, reset=FALSE, ...)
./autoload.R-{
./autoload.R: if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
./autoload.R- stop("an object with that name already exists")
./autoload.R- m <- match.call()
./autoload.R- m[[1]] <- as.name("list")
./autoload.R: newcall <- eval(m, parent.frame())
./autoload.R: newcall <- as.call(c(as.name("autoloader"), newcall))
./autoload.R- newcall$reset <- NULL
./autoload.R: if (is.na(match(package, .Autoloaded)))
./autoload.R: assign(".Autoloaded", c(package, .Autoloaded), env =.AutoloadEnv)
./autoload.R: do.call("delayedAssign", list(name, newcall, .GlobalEnv, .AutoloadEnv))
./autoload.R: ## no longer return the result, which is a promise
./autoload.R- invisible()
./autoload.R-}
./autoload.R-
./autoload.R:autoloader <- function (name, package, ...)
./autoload.R-{
./autoload.R: name <- paste(name, "", sep = "")
./autoload.R: rm(list = name, envir = .AutoloadEnv, inherits = FALSE)
./autoload.R- m <- match.call()
./autoload.R- m$name <- NULL
./autoload.R- m[[1]] <- as.name("library")
./autoload.R- ## load the package
./autoload.R: eval(m, .GlobalEnv)
./autoload.R- ## reset the autoloader
./autoload.R: autoload(name, package, reset = TRUE, ...)
./autoload.R- ## reevaluate the object
./autoload.R: where <- match(paste("package", package, sep = ":"), search())
./autoload.R: if (exists(name, where = where, inherits = FALSE))
./autoload.R: eval(as.name(name), as.environment(where))
./autoload.R- else
./autoload.R: stop(gettextf("autoloader did not find '%s' in '%s'", name, package),
./autoload.R- domain = NA)
./autoload.R-}
--
./backquote.R-
./backquote.R-
./backquote.R:bquote<-function(expr, where=parent.frame()){
./backquote.R-
./backquote.R-
./backquote.R- unquote<-function(e){
./backquote.R-
./backquote.R- if (length(e)<=1)
./backquote.R- e
./backquote.R- else if (e[[1]]==as.name("."))
./backquote.R: eval(e[[2]],where)
./backquote.R- else
./backquote.R: as.call(lapply(e,unquote))
./backquote.R-
./backquote.R- }
./backquote.R-
--
./backsolve.R:forwardsolve <- function(l, x, k=ncol(l), upper.tri = FALSE, transpose = FALSE)
./backsolve.R: backsolve(l,x, k=k, upper.tri= upper.tri, transpose= transpose)
./backsolve.R-
./backsolve.R:backsolve <- function(r, x, k=ncol(r), upper.tri = TRUE, transpose = FALSE)
./backsolve.R-{
./backsolve.R- r <- as.matrix(r)# nr x k
./backsolve.R- storage.mode(r) <- "double"
--
./backsolve.R- if(k <= 0 || nrow(x) < k) stop("invalid argument values in 'backsolve'")
./backsolve.R- nb <- ncol(x)
./backsolve.R- upper.tri <- as.logical(upper.tri)
./backsolve.R- transpose <- as.logical(transpose)
./backsolve.R- job <- as.integer((upper.tri) + 10*(transpose))
./backsolve.R: z <- .C("bakslv",
./backsolve.R: t = r, ldt= nrow(r), n = k,
./backsolve.R: b = x, ldb= k, nb = nb,
./backsolve.R: x = matrix(0, k, nb),
./backsolve.R: job = job,
./backsolve.R: info = integer(1),
./backsolve.R: DUP = FALSE, PACKAGE = "base")[c("x","info")]
./backsolve.R- if(z$info != 0)
./backsolve.R: stop(gettextf("singular matrix in 'backsolve'. First zero in diagonal [%d]", z$info), domain = NA)
./backsolve.R- if(x.mat) z$x else drop(z$x)
./backsolve.R-}
--
./bindenv.R:lockEnvironment <- function(env, bindings = FALSE)
./bindenv.R: .Internal(lockEnvironment(env, bindings))
./bindenv.R-
./bindenv.R-environmentIsLocked <- function(env)
./bindenv.R- .Internal(environmentIsLocked(env))
./bindenv.R-
./bindenv.R:lockBinding <- function(sym, env) {
./bindenv.R- if (is.character(sym)) sym <- as.name(sym)
./bindenv.R: .Internal(lockBinding(sym, env))
./bindenv.R-}
./bindenv.R-
./bindenv.R:bindingIsLocked <- function(sym, env) {
./bindenv.R- if (is.character(sym)) sym <- as.name(sym)
./bindenv.R: .Internal(bindingIsLocked(sym, env))
./bindenv.R-}
./bindenv.R-
./bindenv.R:makeActiveBinding <- function(sym, fun, env) {
./bindenv.R- if (is.character(sym)) sym <- as.name(sym)
./bindenv.R: .Internal(makeActiveBinding(sym, fun, env))
./bindenv.R-}
./bindenv.R-
./bindenv.R:bindingIsActive <- function(sym, env) {
./bindenv.R- if (is.character(sym)) sym <- as.name(sym)
./bindenv.R: .Internal(bindingIsActive(sym, env))
./bindenv.R-}
./bindenv.R-
./bindenv.R:unlockBinding <- function(sym, env) {
./bindenv.R- if (is.character(sym)) sym <- as.name(sym)
./bindenv.R: .Internal(unlockBinding(sym, env))
./bindenv.R-}
--
./by.R:by <- function(data, INDICES, FUN, ...) UseMethod("by")
./by.R-
./by.R:by.default <- function(data, INDICES, FUN, ...)
./by.R: by(as.data.frame(data), INDICES, FUN, ...)
./by.R-
./by.R:by.data.frame <- function(data, INDICES, FUN, ...)
./by.R-{
./by.R- if(!is.list(INDICES)) { # record the names for print.by
./by.R: IND <- vector("list", 1)
./by.R- IND[[1]] <- INDICES
./by.R- names(IND) <- deparse(substitute(INDICES))
./by.R- } else IND <- INDICES
./by.R: FUNx <- function(x) FUN(data[x,], ...)
./by.R- nd <- nrow(data)
./by.R: ans <- eval(substitute(tapply(1:nd, IND, FUNx)), data)
./by.R: attr(ans, "call") <- match.call()
./by.R- class(ans) <- "by"
./by.R- ans
./by.R-}
./by.R-
./by.R:print.by <- function(x, ..., vsep)
./by.R-{
./by.R- d <- dim(x)
./by.R- dn <- dimnames(x)
./by.R- dnn <- names(dn)
./by.R- if(missing(vsep))
./by.R: vsep <- paste(rep("-", 0.75*getOption("width")), collapse = "")
./by.R: lapply(seq(along = x), function(i, x, vsep, ...) {
./by.R: if(i != 1 && !is.null(vsep)) cat(vsep, "\n")
./by.R- ii <- i - 1
./by.R- for(j in seq(along = dn)) {
./by.R- iii <- ii %% d[j] + 1; ii <- ii %/% d[j]
./by.R: cat(dnn[j], ": ", dn[[j]][iii], "\n", sep = "")
./by.R- }
./by.R: print(x[[i]], ...)
./by.R: } , x, vsep, ...)
./by.R- invisible(x)
./by.R-}
--
./cat.R:cat <- function(..., file = "", sep = " ", fill = FALSE,
./cat.R: labels = NULL, append = FALSE)
./cat.R-{
./cat.R- if(is.character(file))
./cat.R- if(file == "") file <- stdout()
./cat.R: else if(substring(file, 1, 1) == "|") {
./cat.R: file <- pipe(substring(file, 2), "w")
./cat.R- on.exit(close(file))
./cat.R- } else {
./cat.R: file <- file(file, ifelse(append, "a", "w"))
./cat.R- on.exit(close(file))
./cat.R- }
./cat.R: .Internal(cat(list(...), file, sep, fill, labels, append))
./cat.R-}
--
./character.R:strsplit <- function(x, split, extended = TRUE, fixed = FALSE, perl = FALSE)
./character.R: .Internal(strsplit(x, as.character(split), as.logical(extended),
./character.R: as.logical(fixed), as.logical(perl)))
./character.R-
./character.R:substr <- function(x, start, stop)
./character.R: .Internal(substr(x, as.integer(start), as.integer(stop)))
./character.R-
./character.R:substring <- function(text,first,last=1000000)
./character.R-{
./character.R- storage.mode(text) <- "character"
./character.R: n <- max(lt <- length(text), length(first), length(last))
./character.R: if(lt && lt < n) text <- rep(text, length.out = n)
./character.R: substr(text, first, last)
./character.R-}
./character.R-
./character.R:"substr<-" <- function(x, start, stop, value)
./character.R: .Internal(substrgets(x, as.integer(start), as.integer(stop), value))
./character.R-
./character.R:"substring<-" <- function(text, first, last=1000000, value)
./character.R-{
./character.R: "substr<-"(text, first, last, value)
./character.R-}
./character.R-
./character.R-abbreviate <-
./character.R: function(names.arg, minlength = 4, use.classes = TRUE, dot = FALSE)
./character.R-{
./character.R- ## we just ignore use.classes
./character.R- if(minlength <= 0)
./character.R: return(rep.int("", length(names.arg)))
./character.R- ## need to remove leading/trailing spaces before we check for dups
./character.R- ## This is inefficient but easier than modifying do_abbrev (=> FIXME !)
./character.R: names.arg <- sub("^ +", "", sub(" +$", "", as.character(names.arg)))
./character.R- dups <- duplicated(names.arg)
./character.R- old <- names.arg
./character.R- if(any(dups))
./character.R- names.arg <- names.arg[!dups]
./character.R: dup2 <- rep.int(TRUE, length(names.arg))
./character.R- x <- these <- names.arg
./character.R- repeat {
./character.R: ans <- .Internal(abbreviate(these,minlength,use.classes))
./character.R- x[dup2] <- ans
./character.R- dup2 <- duplicated(x)
./character.R- if(!any(dup2))
./character.R- break
./character.R- minlength <- minlength+1
./character.R: dup2 <- dup2 | match(x, x[dup2], 0)
./character.R- these <- names.arg[dup2]
./character.R- }
./character.R- if(any(dups))
./character.R: x <- x[match(old,names.arg)]
./character.R- if(dot) { # add "." where we did abbreviate:
./character.R- chgd <- x != old
./character.R: x[chgd] <- paste(x[chgd],".",sep = "")
./character.R- }
./character.R- names(x) <- old
./character.R- x
./character.R-}
./character.R-
./character.R:make.names <- function(names, unique = FALSE, allow_ = TRUE)
./character.R-{
./character.R: names <- .Internal(make.names(as.character(names), allow_))
./character.R- if(unique) names <- make.unique(names)
./character.R- names
./character.R-}
./character.R-
./character.R:make.unique <- function (names, sep = ".") .Internal(make.unique(names, sep))
./character.R-
./character.R:chartr <- function(old, new, x) .Internal(chartr(old, new, x))
./character.R-tolower <- function(x) .Internal(tolower(x))
./character.R-toupper <- function(x) .Internal(toupper(x))
./character.R-
./character.R:casefold <- function(x, upper = FALSE)
./character.R- if(upper) toupper(x) else tolower(x)
./character.R-
./character.R-sQuote <- function(x) {
./character.R- if(length(x) == 0) return(character())
./character.R- if(l10n_info()$"UTF-8")
./character.R: paste("\xe2\x80\x98", x, "\xe2\x80\x99", sep = "")
./character.R- else
./character.R: paste("'", x, "'", sep = "")
./character.R-}
./character.R-dQuote <- function(x) {
./character.R- if(length(x) == 0) return(character())
./character.R- if(l10n_info()$"UTF-8")
./character.R: paste("\xe2\x80\x9c", x, "\xe2\x80\x9d", sep = "")
./character.R- else
./character.R: paste("\"", x, "\"", sep = "")
./character.R-}
--
./chol.R:chol <- function(x, pivot = FALSE, LINPACK = pivot)
./chol.R-{
./chol.R- if (is.complex(x))
./chol.R- stop("complex matrices not permitted at present")
--
./chol.R- else {
./chol.R- if(length(x) != 1)
./chol.R- stop("non-matrix argument to 'chol'")
./chol.R- n <- as.integer(1)
./chol.R- }
./chol.R: if(!pivot && !LINPACK) return(.Call("La_chol", as.matrix(x), PACKAGE = "base"))
./chol.R-
./chol.R- if(!is.double(x)) storage.mode(x) <- "double"
./chol.R-
./chol.R- if(pivot) {
./chol.R- xx <- x
./chol.R- xx[lower.tri(xx)] <- 0
./chol.R: z <- .Fortran("dchdc",
./chol.R: x = xx,
./chol.R: n,
./chol.R: n,
./chol.R: double(n),
./chol.R: piv = as.integer(rep.int(0, n)),
./chol.R: as.integer(pivot),
./chol.R: rank = integer(1),
./chol.R: DUP = FALSE, PACKAGE = "base")
./chol.R- if (!pivot && z$rank < n)
./chol.R- stop("matrix not positive definite")
./chol.R- robj <- z$x
./chol.R- if (pivot) {
./chol.R: attr(robj, "pivot") <- z$piv
./chol.R: attr(robj, "rank") <- z$rank
./chol.R- }
./chol.R- robj
./chol.R- } else {
./chol.R: z <- .Fortran("chol",
./chol.R: x = x,
./chol.R: n,
./chol.R: n,
./chol.R: v = matrix(0, nr=n, nc=n),
./chol.R: info = integer(1),
./chol.R: DUP = FALSE, PACKAGE = "base")
./chol.R- if(z$info)
./chol.R- stop("non-positive definite matrix in 'chol'")
./chol.R- z$v
./chol.R- }
./chol.R-}
./chol.R-
./chol.R:chol2inv <- function(x, size=NCOL(x), LINPACK=FALSE)
./chol.R-{
./chol.R- if(!is.numeric(x))
./chol.R- stop("non-numeric argument to 'chol2inv'")
./chol.R: if(!LINPACK) return(La.chol2inv(x, size))
./chol.R-
./chol.R- if(is.matrix(x)) {
./chol.R- nr <- nrow(x)
--
./chol.R- }
./chol.R- size <- as.integer(size)
./chol.R- if(size <= 0 || size > nr || size > nc)
./chol.R- stop("invalid 'size' argument in 'chol2inv'")
./chol.R- if(!is.double(x)) storage.mode(x) <- "double"
./chol.R: z <- .Fortran("ch2inv",
./chol.R: x=x,
./chol.R: nr,
./chol.R: size,
./chol.R: v=matrix(0, nr=size, nc=size),
./chol.R: info=integer(1),
./chol.R: DUP=FALSE, PACKAGE="base")
./chol.R- if(z$info)
./chol.R- stop("singular matrix in 'chol2inv'")
./chol.R- z$v
--
./colSums.R:colSums <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
--
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- n <- prod(dn[1:dims])
./colSums.R- dn <- dn[-(1:dims)]
./colSums.R- z <- if(is.complex(x))
./colSums.R: .Internal(colSums(Re(x), n, prod(dn), na.rm)) +
./colSums.R: 1i * .Internal(colSums(Im(x), n, prod(dn), na.rm))
./colSums.R: else .Internal(colSums(x, n, prod(dn), na.rm))
./colSums.R- if(length(dn) > 1) {
./colSums.R- dim(z) <- dn
./colSums.R- dimnames(z) <- dimnames(x)[-(1:dims)]
./colSums.R- } else names(z) <- dimnames(x)[[dims+1]]
./colSums.R- z
./colSums.R-}
./colSums.R-
./colSums.R:colMeans <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
--
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- n <- prod(dn[1:dims])
./colSums.R- dn <- dn[-(1:dims)]
./colSums.R- z <- if(is.complex(x))
./colSums.R: .Internal(colMeans(Re(x), n, prod(dn), na.rm)) +
./colSums.R: 1i * .Internal(colMeans(Im(x), n, prod(dn), na.rm))
./colSums.R: else .Internal(colMeans(x, n, prod(dn), na.rm))
./colSums.R- if(length(dn) > 1) {
./colSums.R- dim(z) <- dn
./colSums.R- dimnames(z) <- dimnames(x)[-(1:dims)]
./colSums.R- } else names(z) <- dimnames(x)[[dims+1]]
./colSums.R- z
./colSums.R-}
./colSums.R-
./colSums.R:rowSums <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
--
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- p <- prod(dn[-(1:dims)])
./colSums.R- dn <- dn[1:dims]
./colSums.R- z <- if(is.complex(x))
./colSums.R: .Internal(rowSums(Re(x), prod(dn), p, na.rm)) +
./colSums.R: 1i * .Internal(rowSums(Im(x), prod(dn), p, na.rm))
./colSums.R: else .Internal(rowSums(x, prod(dn), p, na.rm))
./colSums.R- if(length(dn) > 1) {
./colSums.R- dim(z) <- dn
./colSums.R- dimnames(z) <- dimnames(x)[1:dims]
./colSums.R- } else names(z) <- dimnames(x)[[1]]
./colSums.R- z
./colSums.R-}
./colSums.R-
./colSums.R:rowMeans <- function(x, na.rm = FALSE, dims = 1)
./colSums.R-{
./colSums.R- if(is.data.frame(x)) x <- as.matrix(x)
./colSums.R- if(!is.array(x) || length(dn <- dim(x)) < 2)
--
./colSums.R- if(dims < 1 || dims > length(dn) - 1)
./colSums.R- stop("invalid 'dims'")
./colSums.R- p <- prod(dn[-(1:dims)])
./colSums.R- dn <- dn[1:dims]
./colSums.R- z <- if(is.complex(x))
./colSums.R: .Internal(rowMeans(Re(x), prod(dn), p, na.rm)) +
./colSums.R: 1i * .Internal(rowMeans(Im(x), prod(dn), p, na.rm))
./colSums.R: else .Internal(rowMeans(x, prod(dn), p, na.rm))
./colSums.R- if(length(dn) > 1) {
./colSums.R- dim(z) <- dn
./colSums.R- dimnames(z) <- dimnames(x)[1:dims]
--
./conditions.R-##
./conditions.R-## Handling Conditions
./conditions.R-##
./conditions.R-
./conditions.R:tryCatch <- function(expr, ..., finally) {
./conditions.R: tryCatchList <- function(expr, names, parentenv, handlers) {
./conditions.R- nh <- length(names)
./conditions.R- if (nh > 1)
./conditions.R: tryCatchOne(tryCatchList(expr, names[-nh], parentenv,
./conditions.R: handlers[-nh]),
./conditions.R: names[nh], parentenv, handlers[[nh]])
./conditions.R- else if (nh == 1)
./conditions.R: tryCatchOne(expr, names, parentenv, handlers[[1]])
./conditions.R- else expr
./conditions.R- }
./conditions.R: tryCatchOne <- function(expr, name, parentenv, handler) {
./conditions.R: doTryCatch <- function(expr, name, parentenv, handler) {
./conditions.R: .Internal(.addCondHands(name, list(handler), parentenv,
./conditions.R: environment(), FALSE))
./conditions.R- expr
./conditions.R- }
./conditions.R: value <- doTryCatch(return(expr), name, parentenv, handler)
./conditions.R- # The return in the call above will exit withOneRestart unless
./conditions.R- # the handler is invoked; we only get to this point if the handler
./conditions.R- # is invoked. If we get here then the handler will have been
--
./conditions.R- # a simple error; message is stored internally
./conditions.R- # and call is in result; this defers all allocs until
./conditions.R- # after the jump
./conditions.R- msg <- .Internal(geterrmessage())
./conditions.R- call <- value[[2]]
./conditions.R: cond <- simpleError(msg, call)
./conditions.R- }
./conditions.R- else cond <- value[[1]]
./conditions.R- value[[3]](cond)
--
./conditions.R- handlers <- list(...)
./conditions.R- classes <- names(handlers)
./conditions.R- parentenv <- parent.frame()
./conditions.R- if (length(classes) != length(handlers))
./conditions.R- stop("bad handler specification")
./conditions.R: tryCatchList(expr, classes, parentenv, handlers)
./conditions.R-}
./conditions.R-
./conditions.R:withCallingHandlers <- function(expr, ...) {
./conditions.R- handlers <- list(...)
./conditions.R- classes <- names(handlers)
./conditions.R- parentenv <- parent.frame()
./conditions.R- if (length(classes) != length(handlers))
./conditions.R- stop("bad handler specification")
./conditions.R: .Internal(.addCondHands(classes, handlers, parentenv, NULL, TRUE))
./conditions.R- expr
./conditions.R-}
./conditions.R-
./conditions.R-suppressWarnings <- function(expr) {
./conditions.R: withCallingHandlers(expr,
./conditions.R- warning=function(w)
./conditions.R- invokeRestart("muffleWarning"))
./conditions.R-}
--
./conditions.R-
./conditions.R-##
./conditions.R-## Conditions and Condition Signaling
./conditions.R-##
./conditions.R-
./conditions.R:simpleCondition <- function(message, call = NULL) {
./conditions.R: class <- c("simpleCondition", "condition")
./conditions.R: structure(list(message=as.character(message), call = call), class=class)
./conditions.R-}
./conditions.R-
./conditions.R:simpleError <- function(message, call = NULL) {
./conditions.R: class <- c("simpleError", "error", "condition")
./conditions.R: structure(list(message=as.character(message), call = call), class=class)
./conditions.R-}
./conditions.R-
./conditions.R:simpleWarning <- function(message, call = NULL) {
./conditions.R: class <- c("simpleWarning", "warning", "condition")
./conditions.R: structure(list(message=as.character(message), call = call), class=class)
./conditions.R-}
./conditions.R-
./conditions.R-conditionMessage <- function(c) UseMethod("conditionMessage")
./conditions.R-conditionCall <- function(c) UseMethod("conditionCall")
./conditions.R-
./conditions.R-conditionMessage.condition <- function(c) c$message
./conditions.R-conditionCall.condition <- function(c) c$call
./conditions.R-
./conditions.R:print.condition <- function(x, ...) {
./conditions.R- msg <- conditionMessage(x)
./conditions.R- call <- conditionCall(x)
./conditions.R- cl <- class(x)[1]
./conditions.R- if (! is.null(call))
./conditions.R: cat("<", cl, " in ", deparse(call), ": ", msg, ">\n", sep="")
./conditions.R- else
./conditions.R: cat("<", cl, ": ", msg, ">\n", sep="")
./conditions.R-}
./conditions.R-
./conditions.R:as.character.condition <- function(x, ...) {
./conditions.R- msg <- conditionMessage(x)
./conditions.R- call <- conditionCall(x)
./conditions.R- cl <- class(x)[1]
./conditions.R- if (! is.null(call))
./conditions.R: paste(cl, " in ", deparse(call)[1], ": ", msg, "\n", sep="")
./conditions.R- else
./conditions.R: paste(cl, ": ", msg, "\n", sep="")
./conditions.R-}
./conditions.R-
./conditions.R:as.character.error <- function(x, ...) {
./conditions.R- msg <- conditionMessage(x)
./conditions.R- call <- conditionCall(x)
./conditions.R- if (! is.null(call))
./conditions.R: paste("Error in ", deparse(call)[1], ": ", msg, "\n", sep="")
./conditions.R- else
./conditions.R: paste("Error: ", msg, "\n", sep="")
./conditions.R-}
./conditions.R-
./conditions.R-signalCondition <- function(cond) {
./conditions.R: if (! inherits(cond, "condition"))
./conditions.R- cond <- simpleCondition(cond)
./conditions.R- msg <- conditionMessage(cond)
./conditions.R- call <- conditionCall(cond)
./conditions.R: .Internal(.signalCondition(cond, msg, call))
./conditions.R-}
./conditions.R-
./conditions.R-
--
./conditions.R-##
./conditions.R-
./conditions.R-restartDescription <- function(r) r$description
./conditions.R-restartFormals <- function(r) formals(r$handler)
./conditions.R-
./conditions.R:print.restart <- function(x, ...)
./conditions.R: cat(paste("\n"))
./conditions.R-
./conditions.R:isRestart <- function(x) inherits(x, "restart")
./conditions.R-
./conditions.R:findRestart <- function(name, cond = NULL) {
./conditions.R- i <- 1
./conditions.R- repeat {
./conditions.R- r <- .Internal(.getRestart(i))
--
./conditions.R- repeat {
./conditions.R- r <- .Internal(.getRestart(i))
./conditions.R- if (is.null(r))
./conditions.R- return(val)
./conditions.R- else if (is.null(cond) || is.null(r$test) || r$test(cond))
./conditions.R: val <- c(val, list(r))
./conditions.R- i <- i + 1
./conditions.R- }
./conditions.R-}
./conditions.R-
./conditions.R:invokeRestart <- function(r, ...) {
./conditions.R- if (! isRestart(r)) {
./conditions.R- res <- findRestart(r)
./conditions.R- if (is.null(res))
./conditions.R: stop(gettextf("no 'restart' '%s' found", as.character(r)),
./conditions.R- domain = NA)
./conditions.R- r <- res
./conditions.R- }
./conditions.R: .Internal(.invokeRestart(r, list(...)))
./conditions.R-}
./conditions.R-
./conditions.R-invokeRestartInteractively <- function(r) {
./conditions.R- if (! interactive())
./conditions.R- stop("not an interactive session")
./conditions.R- if (! isRestart(r)) {
./conditions.R- res <- findRestart(r)
./conditions.R- if (is.null(res))
./conditions.R: stop(gettextf("no 'restart' '%s' found", as.character(r)),
./conditions.R- domain = NA)
./conditions.R- r <- res
./conditions.R- }
--
./conditions.R- if (length(pars) > 0) {
./conditions.R- cat("Enter values for restart arguments:\n\n")
./conditions.R- for (p in pars) {
./conditions.R- if (p == "...") {
./conditions.R- prompt <- "... (a list): "
./conditions.R: args <- c(args, eval(parse(prompt = prompt)))
./conditions.R- }
./conditions.R- else {
./conditions.R: prompt <- paste(p, ": ", sep="")
./conditions.R: args <- c(args, list(eval(parse(prompt = prompt))))
./conditions.R- }
./conditions.R- }
./conditions.R- }
./conditions.R- }
./conditions.R- else args <- r$interactive()
./conditions.R: .Internal(.invokeRestart(r, args))
./conditions.R-}
./conditions.R-
./conditions.R:withRestarts <- function(expr, ...) {
./conditions.R: docall <- function(fun, args) {
./conditions.R: enquote <- function(x) as.call(list(as.name("quote"), x))
./conditions.R- if ((is.character(fun) && length(fun) == 1) || is.name(fun))
./conditions.R: fun <- get(as.character(fun), env = parent.frame(),
./conditions.R- mode = "function")
./conditions.R: do.call("fun", lapply(args, enquote))
./conditions.R- }
./conditions.R: makeRestart <- function(name = "",
./conditions.R: handler = function(...) NULL,
./conditions.R: description = "",
./conditions.R: test = function(c) TRUE,
./conditions.R- interactive = NULL) {
./conditions.R: structure(list(name = name, exit = NULL, handler = handler,
./conditions.R: description = description, test = test,
./conditions.R: interactive = interactive),
./conditions.R- class = "restart")
./conditions.R- }
./conditions.R- makeRestartList <- function(...) {
./conditions.R- specs <- list(...)
./conditions.R- names <- names(specs)
./conditions.R: restarts <- vector("list", length(specs))
./conditions.R- for (i in seq(along = specs)) {
./conditions.R- spec <- specs[[i]]
./conditions.R- name <- names[i]
./conditions.R- if (is.function(spec))
./conditions.R- restarts[[i]] <- makeRestart(handler = spec)
./conditions.R- else if (is.character(spec))
./conditions.R- restarts[[i]] <- makeRestart(description = spec)
./conditions.R- else if (is.list(spec))
./conditions.R: restarts[[i]] <- docall("makeRestart", spec)
./conditions.R- else
./conditions.R- stop("not a valid restart specification")
./conditions.R- restarts[[i]]$name <- name
./conditions.R- }
./conditions.R- restarts
./conditions.R- }
./conditions.R: withOneRestart <- function(expr, restart) {
./conditions.R: doWithOneRestart <- function(expr, restart) {
./conditions.R- restart$exit <- environment()
./conditions.R- .Internal(.addRestart(restart))
./conditions.R- expr
./conditions.R- }
./conditions.R: restartArgs <- doWithOneRestart(return(expr), restart)
./conditions.R- # The return in the call above will exit withOneRestart unless
./conditions.R- # the restart is invoked; we only get to this point if the restart
./conditions.R- # is invoked. If we get here then the restart will have been
./conditions.R- # popped off the internal restart stack.
./conditions.R: docall(restart$handler, restartArgs)
./conditions.R- }
./conditions.R: withRestartList <- function(expr, restarts) {
./conditions.R- nr <- length(restarts)
./conditions.R- if (nr > 1)
./conditions.R: withOneRestart(withRestartList(expr, restarts[-nr]),
./conditions.R- restarts[[nr]])
./conditions.R- else if (nr == 1)
./conditions.R: withOneRestart(expr, restarts[[1]])
./conditions.R- else expr
./conditions.R- }
./conditions.R- restarts <- makeRestartList(...)
./conditions.R- if (length(restarts) == 0)
./conditions.R- expr
./conditions.R- else if (length(restarts) == 1)
./conditions.R: withOneRestart(expr, restarts[[1]])
./conditions.R: else withRestartList(expr, restarts)
./conditions.R-}
./conditions.R-
./conditions.R-
./conditions.R-##
./conditions.R-## Callbacks
./conditions.R-##
./conditions.R-
./conditions.R:.signalSimpleWarning <- function(msg, call)
./conditions.R- withRestarts({
./conditions.R: .Internal(.signalCondition(simpleWarning(msg, call), msg, call))
./conditions.R: .Internal(.dfltWarn(msg, call))
./conditions.R: }, muffleWarning = function() NULL)
./conditions.R-
./conditions.R:.handleSimpleError <- function(h, msg, call)
./conditions.R: h(simpleError(msg, call))
--
./conflicts.R:conflicts <- function(where=search(), detail = FALSE)
./conflicts.R-{
./conflicts.R- if(length(where) < 1) stop("argument where of length 0")
./conflicts.R: z <- vector(length(where), mode="list")
./conflicts.R- names(z) <- where
./conflicts.R- for(i in seq(along=where))
./conflicts.R- z[[i]] <- objects(pos=i)
./conflicts.R: all <- unlist(z, use.names=FALSE)
./conflicts.R- dups <- duplicated(all)
./conflicts.R- dups <- all[dups]
./conflicts.R- if(detail) {
./conflicts.R- for(i in where)
./conflicts.R: z[[i]] <- z[[i]][match(dups, z[[i]], 0)]
./conflicts.R: z[sapply(z, function(x) length(x)==0)] <- NULL
./conflicts.R- z
./conflicts.R- } else dups
./conflicts.R-}
--
./connections.R-stdin <- function() .Internal(stdin())
./connections.R-stdout <- function() .Internal(stdout())
./connections.R-stderr <- function() .Internal(stderr())
./connections.R-
./connections.R:readLines <- function(con = stdin(), n = -1, ok = TRUE)
./connections.R-{
./connections.R- if(is.character(con)) {
./connections.R: con <- file(con, "r")
./connections.R- on.exit(close(con))
./connections.R- }
./connections.R: .Internal(readLines(con, n, ok))
./connections.R-}
./connections.R-
./connections.R-
./connections.R:writeLines <- function(text, con = stdout(), sep = "\n")
./connections.R-{
./connections.R- if(is.character(con)) {
./connections.R: con <- file(con, "w")
./connections.R- on.exit(close(con))
./connections.R- }
./connections.R: invisible(.Internal(writeLines(text, con, sep)))
./connections.R-}
./connections.R-
./connections.R:open <- function(con, ...)
./connections.R- UseMethod("open")
./connections.R-
./connections.R:open.connection <- function(con, open = "r", blocking = TRUE, ...)
./connections.R-{
./connections.R: invisible(.Internal(open(con, open, blocking)))
./connections.R-}
./connections.R-
./connections.R:isOpen <- function(con, rw = "")
./connections.R-{
./connections.R: rw <- pmatch(rw, c("read", "write"), 0)
./connections.R: .Internal(isOpen(con, rw))
./connections.R-}
./connections.R-
./connections.R-isIncomplete <- function(con)
./connections.R- .Internal(isIncomplete(con))
./connections.R-
./connections.R-isSeekable <- function(con)
./connections.R- .Internal(isSeekable(con))
./connections.R-
./connections.R:close <- function(con, ...)
./connections.R- UseMethod("close")
./connections.R-
./connections.R:close.connection <- function (con, type = "rw", ...)
./connections.R: invisible(.Internal(close(con, type)))
./connections.R-
./connections.R-flush <- function(con) UseMethod("flush")
./connections.R-
./connections.R-flush.connection <- function (con)
./connections.R- invisible(.Internal(flush(con)))
./connections.R-
./connections.R:file <- function(description = "", open = "", blocking = TRUE,
./connections.R- encoding = getOption("encoding"))
./connections.R: .Internal(file(description, open, blocking, encoding))
./connections.R-
./connections.R:pipe <- function(description, open = "", encoding = getOption("encoding"))
./connections.R: .Internal(pipe(description, open, encoding))
./connections.R-
./connections.R:fifo <- function(description = "", open = "", blocking = FALSE,
./connections.R- encoding = getOption("encoding"))
./connections.R: .Internal(fifo(description, open, blocking, encoding))
./connections.R-
./connections.R:url <- function(description, open = "", blocking = TRUE,
./connections.R- encoding = getOption("encoding"))
./connections.R: .Internal(url(description, open, blocking, encoding))
./connections.R-
./connections.R:gzfile <- function(description, open = "",
./connections.R: encoding = getOption("encoding"), compression = 6)
./connections.R: .Internal(gzfile(description, open, encoding, compression))
./connections.R-
./connections.R:unz <- function(description, filename, open = "",
./connections.R- encoding = getOption("encoding"))
./connections.R: .Internal(unz(paste(description, filename, sep=":"), open, encoding))
./connections.R-
./connections.R:bzfile <- function(description, open = "", encoding = getOption("encoding"))
./connections.R: .Internal(bzfile(description, open, encoding))
./connections.R-
./connections.R:socketConnection <- function(host= "localhost", port, server = FALSE,
./connections.R: blocking = FALSE, open = "a+",
./connections.R- encoding = getOption("encoding"))
./connections.R: .Internal(socketConnection(host, port, server, blocking, open, encoding))
./connections.R-
./connections.R:textConnection <- function(object, open = "r", local = FALSE) {
./connections.R- if (local) env <- parent.frame()
./connections.R- else env <- .GlobalEnv
./connections.R: .Internal(textConnection(deparse(substitute(object)), object, open, env))
./connections.R-}
./connections.R-
./connections.R:seek <- function(con, ...)
./connections.R- UseMethod("seek")
./connections.R-
./connections.R:seek.connection <- function(con, where = NA, origin = "start", rw = "", ...)
./connections.R-{
./connections.R: origin <- pmatch(origin, c("start", "current", "end"))
./connections.R: rw <- pmatch(rw, c("read", "write"), 0)
./connections.R- if(is.na(origin))
./connections.R: stop("'origin' must be one of 'start', 'current' or 'end'")
./connections.R: .Internal(seek(con, as.double(where), origin, rw))
./connections.R-}
./connections.R-
./connections.R:truncate <- function(con, ...)
./connections.R- UseMethod("truncate")
./connections.R-
./connections.R:truncate.connection <- function(con, ...)
./connections.R-{
./connections.R- if(!isOpen(con)) stop("can only truncate an open connection")
./connections.R- .Internal(truncate(con))
./connections.R-}
./connections.R-
./connections.R:pushBack <- function(data, connection, newLine = TRUE)
./connections.R: invisible(.Internal(pushBack(data, connection, newLine)))
./connections.R-
./connections.R-pushBackLength <- function(connection)
./connections.R- .Internal(pushBackLength(connection))
./connections.R-
./connections.R:print.connection <- function(x, ...)
./connections.R-{
./connections.R- print(unlist(summary(x)))
./connections.R- invisible(x)
./connections.R-}
./connections.R-
./connections.R:summary.connection <- function(object, ...)
./connections.R- .Internal(summary.connection(object))
./connections.R-
./connections.R-showConnections <- function(all = FALSE)
./connections.R-{
./connections.R- set <- getAllConnections()
./connections.R- if(!all) set <- set[set > 2]
./connections.R: ans <- matrix("", length(set), 7)
./connections.R: for(i in seq(along=set)) ans[i, ] <- unlist(summary.connection(set[i]))
./connections.R- rownames(ans) <- set
./connections.R: colnames(ans) <- c("description", "class", "mode", "text", "isopen",
./connections.R: "can read", "can write")
./connections.R: if(!all) ans[ans[, 5] == "opened", , drop = FALSE]
./connections.R: else ans[, , drop = FALSE]
./connections.R-}
./connections.R-
./connections.R-getAllConnections <- function()
./connections.R- .Internal(getAllConnections())
./connections.R-
./connections.R-getConnection <- function(what)
./connections.R-{
./connections.R- set <- getAllConnections()
./connections.R: if(what %in% set) structure(what, class="connection")
./connections.R- else NULL
./connections.R-}
./connections.R-
./connections.R-closeAllConnections <- function()
./connections.R-{
./connections.R- # first re-divert any diversion of stderr.
./connections.R- i <- sink.number(type = "message")
./connections.R: if(i > 0) sink(stderr(), type = "message")
./connections.R- # now unwind the sink diversion stack.
./connections.R- n <- sink.number()
./connections.R- if(n > 0) for(i in 1:n) sink()
--
./connections.R- # and close all user connections.
./connections.R- for(i in seq(along=set)) close(getConnection(set[i]))
./connections.R- invisible()
./connections.R-}
./connections.R-
./connections.R:readBin <- function(con, what, n = 1, size = NA, signed = TRUE,
./connections.R- endian = .Platform$endian)
./connections.R-{
./connections.R- if(is.character(con)) {
./connections.R: con <- file(con, "rb")
./connections.R- on.exit(close(con))
./connections.R- }
./connections.R- swap <- endian != .Platform$endian
./connections.R- if(!is.character(what) || length(what) != 1
./connections.R: || !(what %in% c("numeric", "double", "integer", "int", "logical",
./connections.R: "complex", "character", "raw")))
./connections.R- what <- typeof(what)
./connections.R: .Internal(readBin(con, what, n, size, signed, swap))
./connections.R-}
./connections.R-
./connections.R:writeBin <- function(object, con, size = NA, endian = .Platform$endian)
./connections.R-{
./connections.R- swap <- endian != .Platform$endian
./connections.R- if(!is.vector(object) || mode(object) == "list")
./connections.R- stop("can only write vector objects")
./connections.R- if(is.character(con)) {
./connections.R: con <- file(con, "wb")
./connections.R- on.exit(close(con))
./connections.R- }
./connections.R: invisible(.Internal(writeBin(object, con, size, swap)))
./connections.R-}
./connections.R-
./connections.R:readChar <- function(con, nchars)
./connections.R-{
./connections.R- if(is.character(con)) {
./connections.R: con <- file(con, "rb")
./connections.R- on.exit(close(con))
./connections.R- }
./connections.R: .Internal(readChar(con, as.integer(nchars)))
./connections.R-}
./connections.R-
./connections.R:writeChar <- function(object, con, nchars = nchar(object, type="chars"),
./connections.R- eos = "")
./connections.R-{
./connections.R- if(!is.character(object))
./connections.R- stop("can only write character objects")
./connections.R- if(is.character(con)) {
./connections.R: con <- file(con, "wb")
./connections.R- on.exit(close(con))
./connections.R- }
./connections.R: invisible(.Internal(writeChar(object, con, as.integer(nchars), eos)))
./connections.R-}
./connections.R-
./connections.R:gzcon <- function(con, level = 6, allowNonCompressed = TRUE)
./connections.R: .Internal(gzcon(con, level, allowNonCompressed))
./connections.R-
./connections.R:socketSelect <- function(socklist, write = FALSE, timeout = NULL) {
./connections.R- if (is.null(timeout))
./connections.R- timeout <- -1
./connections.R- else if (timeout < 0)
./connections.R- stop("supplied timeout must be NULL or a non-negative number")
./connections.R- if (length(write) < length(socklist))
./connections.R: write <- rep(write, length.out = length(socklist))
./connections.R: .Internal(sockSelect(socklist, write, timeout))
./connections.R-}
--
./constants.R-pi <- 4*atan(1)
./constants.R-
./constants.R:letters <- c("a","b","c","d","e","f","g","h","i","j","k","l", "m",
./constants.R: "n","o","p","q","r","s","t","u","v","w","x","y","z")
./constants.R-
./constants.R:LETTERS <- c("A","B","C","D","E","F","G","H","I","J","K","L", "M",
./constants.R: "N","O","P","Q","R","S","T","U","V","W","X","Y","Z")
./constants.R-
./constants.R-month.name <-
./constants.R: c("January", "February", "March", "April", "May", "June",
./constants.R: "July", "August", "September", "October", "November", "December")
./constants.R-
./constants.R:month.abb <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun",
./constants.R: "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
--
./contributors.R-contributors <- function()
./contributors.R-{
./contributors.R- outFile <- tempfile()
./contributors.R: outConn <- file(outFile, open = "w")
./contributors.R: writeLines(paste("R is a project which is attempting to provide a ",
./contributors.R: "modern piece of\nstatistical software for the ",
./contributors.R: "GNU suite of software.\n\n",
./contributors.R: "The current R is the result of a collaborative ",
./contributors.R: "effort with\ncontributions from all over the ",
./contributors.R: "world.\n\n",
./contributors.R: sep = ""), outConn)
./contributors.R: writeLines(readLines(file.path(R.home(), "AUTHORS")), outConn)
./contributors.R: writeLines("", outConn)
./contributors.R: writeLines(readLines(file.path(R.home(), "THANKS")), outConn)
./contributors.R- close(outConn)
./contributors.R: file.show(outFile, delete.file = TRUE)
./contributors.R-}
--
./converters.R- v
./converters.R-}
./converters.R-
./converters.R-
./converters.R-setCConverterStatus <-
./converters.R:function(id, status)
./converters.R-{
./converters.R: .Internal(setToCConverterActiveStatus(id, as.logical(status)))
./converters.R-}
./converters.R-
./converters.R-removeCConverter <-
--
./cut.R:cut <- function(x, ...) UseMethod("cut")
./cut.R-
./cut.R:cut.default <- function (x, breaks, labels=NULL, include.lowest = FALSE,
./cut.R: right=TRUE, dig.lab=3, ...)
./cut.R-{
./cut.R- if (!is.numeric(x)) stop("'x' must be numeric")
./cut.R- if (length(breaks) == 1) {
./cut.R- if (is.na(breaks) | breaks < 2)
./cut.R- stop("invalid number of intervals")
./cut.R- nb <- as.integer(breaks + 1)# one more than #{intervals}
./cut.R: dx <- diff(rx <- range(x,na.rm=TRUE))
./cut.R- if(dx==0) dx <- rx[1]
./cut.R: breaks <- seq(rx[1] - dx/1000,
./cut.R: rx[2] + dx/1000, len=nb)
./cut.R- } else nb <- length(breaks <- sort(breaks))
./cut.R- if (any(duplicated(breaks))) stop("'breaks' are not unique")
./cut.R- codes.only <- FALSE
./cut.R- if (is.null(labels)) {#- try to construct nice ones ..
./cut.R: for(dig in dig.lab:max(12, dig.lab)) {
./cut.R: ch.br <- formatC(breaks, digits=dig, wid=1)
./cut.R- if(ok <- all(ch.br[-1] != ch.br[-nb])) break
./cut.R- }
./cut.R- labels <-
./cut.R: if(ok) paste(if(right)"(" else "[",
./cut.R: ch.br[-nb], ",", ch.br[-1],
./cut.R: if(right)"]" else ")", sep='')
./cut.R: else paste("Range", 1:(nb - 1),sep="_")
./cut.R- if (ok && include.lowest) {
./cut.R- if (right)
./cut.R: substr(labels[1], 1, 1) <- "[" # was "("
./cut.R- else
./cut.R: substring(labels[nb-1],
./cut.R: nchar(labels[nb-1], type="char")) <- "]" # was ")"
./cut.R- }
./cut.R- } else if (is.logical(labels) && !labels)
./cut.R- codes.only <- TRUE
./cut.R- else if (length(labels) != nb-1)
./cut.R- stop("labels/breaks length conflict")
./cut.R: code <- .C("bincode",
./cut.R: x = as.double(x),
./cut.R: n = as.integer(length(x)),
./cut.R: breaks = as.double(breaks),
./cut.R: as.integer(nb),
./cut.R: code= integer(length(x)),
./cut.R: right= as.logical(right),
./cut.R: include= as.logical(include.lowest), naok = TRUE,
./cut.R: NAOK= TRUE, DUP = FALSE, PACKAGE = "base") $code
./cut.R- ## NB this relies on passing NAOK in that position!
./cut.R- if(codes.only) code
./cut.R: else factor(code, seq(labels), labels)
./cut.R-}
--
./data.matrix.R-{
./data.matrix.R- if(!is.data.frame(frame))
./data.matrix.R- return(as.matrix(frame))
./data.matrix.R- d <- dim(frame)
./data.matrix.R- if(all(d > 0)) {
./data.matrix.R: log <- unlist(lapply(frame, is.logical))
./data.matrix.R: num <- unlist(lapply(frame, is.numeric))
./data.matrix.R: fac <- unlist(lapply(frame, is.factor))
./data.matrix.R-
./data.matrix.R- if(!all(log|fac|num))
./data.matrix.R- stop("non-numeric data type in frame")
./data.matrix.R: cl <- sapply(frame[log|num], function(x) {
./data.matrix.R- cl <- class(x)
./data.matrix.R: length(cl) > 1 || ! (cl %in% c("numeric", "integer", "logical"))
./data.matrix.R- })
./data.matrix.R- if(length(cl) && any(cl))
./data.matrix.R- warning("class information lost from one or more columns")
./data.matrix.R- }
./data.matrix.R: x <- matrix(nr=d[1], nc=d[2], dimnames=dimnames(frame))
./data.matrix.R- for(i in seq(len=d[2])) {
./data.matrix.R- xi <- frame[[i]]
./data.matrix.R: x[,i] <-
./data.matrix.R- if(is.logical(xi) || is.factor(xi)) as.numeric(xi) else xi
./data.matrix.R- }
./data.matrix.R- x
--
./dataframe.R-row.names <- function(x) UseMethod("row.names")
./dataframe.R:row.names.data.frame <- function(x) attr(x, "row.names")
./dataframe.R-row.names.default <- function(x) if(!is.null(dim(x))) rownames(x)# else NULL
./dataframe.R-
./dataframe.R:"row.names<-" <- function(x, value) UseMethod("row.names<-")
./dataframe.R:"row.names<-.data.frame" <- function(x, value) {
./dataframe.R- if (!is.data.frame(x))
./dataframe.R- x <- as.data.frame(x)
./dataframe.R: old <- attr(x, "row.names")
./dataframe.R- if (!is.null(old) && length(value) != length(old))
./dataframe.R- stop("invalid 'row.names' length")
./dataframe.R- value <- as.character(value)
./dataframe.R- if (any(duplicated(value)))
./dataframe.R- stop("duplicate 'row.names' are not allowed")
./dataframe.R- if (any(is.na(value)))
./dataframe.R- stop("missing 'row.names' are not allowed")
./dataframe.R: attr(x, "row.names") <- value
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R:"row.names<-.default" <- function(x, value) "rownames<-"(x, value)
./dataframe.R-
./dataframe.R-is.na.data.frame <- function (x)
./dataframe.R-{
./dataframe.R: y <- do.call("cbind", lapply(x, "is.na"))
./dataframe.R- rownames(y) <- row.names(x)
./dataframe.R- y
./dataframe.R-}
./dataframe.R-
./dataframe.R:is.data.frame <- function(x) inherits(x, "data.frame")
./dataframe.R-
./dataframe.R:I <- function(x) { structure(x, class = unique(c("AsIs", oldClass(x)))) }
./dataframe.R-
./dataframe.R:print.AsIs <- function (x, ...)
./dataframe.R-{
./dataframe.R- cl <- oldClass(x)
./dataframe.R- oldClass(x) <- cl[cl != "AsIs"]
--
./dataframe.R-t.data.frame <- function(x) {
./dataframe.R- x <- as.matrix(x)
./dataframe.R- NextMethod("t")
./dataframe.R-}
./dataframe.R-
./dataframe.R:dim.data.frame <- function(x) c(length(attr(x,"row.names")), length(x))
./dataframe.R-
./dataframe.R:dimnames.data.frame <- function(x) list(attr(x,"row.names"), names(x))
./dataframe.R-
./dataframe.R:"dimnames<-.data.frame" <- function(x, value) {
./dataframe.R- d <- dim(x)
./dataframe.R- if(!is.list(value) || length(value) != 2
./dataframe.R- || d[[1]] != length(value[[1]])
--
./dataframe.R- row.names(x) <- as.character(value[[1]]) # checks validity
./dataframe.R- names(x) <- as.character(value[[2]])
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R:as.data.frame <- function(x, row.names = NULL, optional = FALSE) {
./dataframe.R- if(is.null(x)) # can't assign class to NULL
./dataframe.R- return(as.data.frame(list()))
./dataframe.R- UseMethod("as.data.frame")
./dataframe.R-}
./dataframe.R:as.data.frame.default <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R: stop(gettextf("cannot coerce class \"%s\" into a data.frame", class(x)),
./dataframe.R- domain = NA)
./dataframe.R-
./dataframe.R-
./dataframe.R-### Here are methods ensuring that the arguments to "data.frame"
./dataframe.R-### are in a form suitable for combining into a data frame.
./dataframe.R-
./dataframe.R:as.data.frame.data.frame <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- cl <- oldClass(x)
./dataframe.R: i <- match("data.frame", cl)
./dataframe.R- if(i > 1)
./dataframe.R- class(x) <- cl[ - (1:(i-1))]
./dataframe.R- if(is.character(row.names)){
./dataframe.R: if(length(row.names) == length(attr(x, "row.names")))
./dataframe.R: attr(x, "row.names") <- row.names
./dataframe.R: else stop(gettextf("invalid 'row.names', length %d for a data frame with %d rows",
./dataframe.R: length(row.names), length(attr(x, "row.names"))),
./dataframe.R- domain = NA)
./dataframe.R- }
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R-## prior to 1.8.0 this coerced names - PR#3280
./dataframe.R:as.data.frame.list <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- ## need to protect names in x.
./dataframe.R- cn <- names(x)
./dataframe.R: m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
./dataframe.R- if(any(m > 0)) {
./dataframe.R: cn[m] <- paste("..adfl.", cn[m], sep="")
./dataframe.R- names(x) <- cn
./dataframe.R- }
./dataframe.R: x <- eval(as.call(c(expression(data.frame), x, check.names = !optional)))
./dataframe.R: if(any(m > 0)) names(x) <- sub("^\\.\\.adfl\\.", "", names(x))
./dataframe.R- if(!is.null(row.names)) {
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(length(row.names) != dim(x)[[1]])
./dataframe.R: stop(gettextf("supplied %d row names for %d rows",
./dataframe.R: length(row.names), dim(x)[[1]]), domain = NA)
./dataframe.R: attr(x, "row.names") <- row.names
./dataframe.R- }
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R:as.data.frame.vector <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- nrows <- length(x)
./dataframe.R- nm <- deparse(substitute(x))
--
./dataframe.R- else row.names <- as.character(1:nrows)
./dataframe.R- }
./dataframe.R- names(x) <- NULL # remove names as from 2.0.0
./dataframe.R- value <- list(x)
./dataframe.R- if(!optional) names(value) <- nm
./dataframe.R: attr(value, "row.names") <- row.names
./dataframe.R- class(value) <- "data.frame"
./dataframe.R- value
./dataframe.R-}
./dataframe.R-
./dataframe.R:as.data.frame.ts <- function(x, row.names=NULL, optional=FALSE)
./dataframe.R-{
./dataframe.R- if(is.matrix(x))
./dataframe.R: as.data.frame.matrix(x, row.names, optional)
./dataframe.R- else
./dataframe.R: as.data.frame.vector(x, row.names, optional)
./dataframe.R-}
./dataframe.R-
./dataframe.R-as.data.frame.raw <- as.data.frame.vector
--
./dataframe.R-as.data.frame.ordered <- as.data.frame.vector
./dataframe.R-as.data.frame.integer <- as.data.frame.vector
./dataframe.R-as.data.frame.numeric <- as.data.frame.vector
./dataframe.R-as.data.frame.complex <- as.data.frame.vector
./dataframe.R-
./dataframe.R:as.data.frame.character <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R: as.data.frame.vector(factor(x), row.names, optional)
./dataframe.R-
./dataframe.R-as.data.frame.logical <- as.data.frame.vector
./dataframe.R-
./dataframe.R:as.data.frame.matrix <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- d <- dim(x)
./dataframe.R- nrows <- d[1]; ir <- seq(length = nrows)
--
./dataframe.R- ## surely it cannot be right to override the supplied row.names?
./dataframe.R- ## changed in 1.8.0
./dataframe.R- if(missing(row.names)) row.names <- dn[[1]]
./dataframe.R- collabs <- dn[[2]]
./dataframe.R- if(any(empty <- nchar(collabs)==0))
./dataframe.R: collabs[empty] <- paste("V", ic, sep = "")[empty]
./dataframe.R: value <- vector("list", ncols)
./dataframe.R- if(mode(x) == "character") {
./dataframe.R- for(i in ic)
./dataframe.R: value[[i]] <- as.factor(x[,i])
./dataframe.R- } else {
./dataframe.R- for(i in ic)
./dataframe.R: value[[i]] <- as.vector(x[,i])
./dataframe.R- }
./dataframe.R- if(length(row.names) != nrows)
./dataframe.R- row.names <- if(optional) character(nrows) else as.character(ir)
./dataframe.R- if(length(collabs) == ncols)
./dataframe.R- names(value) <- collabs
./dataframe.R- else if(!optional)
./dataframe.R: names(value) <- paste("V", ic, sep="")
./dataframe.R: attr(value, "row.names") <- row.names
./dataframe.R- class(value) <- "data.frame"
./dataframe.R- value
./dataframe.R-}
./dataframe.R-
./dataframe.R:as.data.frame.model.matrix <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- d <- dim(x)
./dataframe.R- nrows <- d[1]
--
./dataframe.R- row.names <- dn[[1]]
./dataframe.R- value <- list(x)
./dataframe.R- if(!is.null(row.names)) {
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(length(row.names) != nrows)
./dataframe.R: stop(gettextf("supplied %d row names for %d rows",
./dataframe.R: length(row.names), nrows), domain = NA)
./dataframe.R- }
./dataframe.R- else if(optional) row.names <- character(nrows)
./dataframe.R- else row.names <- as.character(1:nrows)
./dataframe.R- if(!optional) names(value) <- deparse(substitute(x))[[1]]
./dataframe.R: attr(value, "row.names") <- row.names
./dataframe.R- class(value) <- "data.frame"
./dataframe.R- value
./dataframe.R-}
./dataframe.R-
./dataframe.R:as.data.frame.array <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- d <- dim(x)
./dataframe.R: if(length(d) == 1) { ## same as as.data.frame.vector, but deparsed here
./dataframe.R: value <- as.data.frame.vector(drop(x), row.names, optional)
./dataframe.R- if(!optional) names(value) <- deparse(substitute(x))[[1]]
./dataframe.R- value
./dataframe.R- } else if (length(d) == 2) {
./dataframe.R: as.data.frame.matrix(x, row.names, optional)
./dataframe.R- } else {
./dataframe.R- dn <- dimnames(x)
./dataframe.R: dim(x) <- c(d[1], prod(d[-1]))
./dataframe.R- if(!is.null(dn)) {
./dataframe.R- if(length(dn[[1]])) rownames(x) <- dn[[1]]
./dataframe.R- for(i in 2:length(d))
./dataframe.R- if(is.null(dn[[i]])) dn[[i]] <- seq(len=d[i])
./dataframe.R- colnames(x) <- interaction(expand.grid(dn[-1]))
./dataframe.R- }
./dataframe.R: as.data.frame.matrix(x, row.names, optional)
./dataframe.R- }
./dataframe.R-}
./dataframe.R-
./dataframe.R-## will always have a class here
./dataframe.R:"[.AsIs" <- function(x, i, ...) structure(NextMethod("["), class = class(x))
./dataframe.R-
./dataframe.R:as.data.frame.AsIs <- function(x, row.names = NULL, optional = FALSE)
./dataframe.R-{
./dataframe.R- ## why not remove class and NextMethod here?
./dataframe.R- if(length(dim(x))==2)
./dataframe.R: as.data.frame.model.matrix(x, row.names, optional)
./dataframe.R- else { # as.data.frame.vector without removing names
./dataframe.R- nrows <- length(x)
./dataframe.R- nm <- deparse(substitute(x))
--
./dataframe.R- else if(optional) row.names <- character(nrows)
./dataframe.R- else row.names <- as.character(1:nrows)
./dataframe.R- }
./dataframe.R- value <- list(x)
./dataframe.R- if(!optional) names(value) <- nm
./dataframe.R: attr(value, "row.names") <- row.names
./dataframe.R- class(value) <- "data.frame"
./dataframe.R- value
./dataframe.R- }
--
./dataframe.R-
./dataframe.R-### This is the real "data.frame".
./dataframe.R-### It does everything by calling the methods presented above.
./dataframe.R-
./dataframe.R-data.frame <-
./dataframe.R: function(..., row.names = NULL, check.rows = FALSE, check.names = TRUE)
./dataframe.R-{
./dataframe.R- data.row.names <-
./dataframe.R- if(check.rows && missing(row.names))
./dataframe.R: function(current, new, i) {
./dataframe.R- new <- as.character(new)
./dataframe.R- if(any(duplicated(new)))
./dataframe.R- return(current)
./dataframe.R- if(is.null(current))
./dataframe.R- return(new)
./dataframe.R- if(all(current == new) || all(current == ""))
./dataframe.R- return(new)
./dataframe.R: stop(gettextf("mismatch of row names in arguments of 'data.frame\', item %d", i), domain = NA)
./dataframe.R- }
./dataframe.R: else function(current, new, i) {
./dataframe.R- if(is.null(current)) {
./dataframe.R- if(any(dup <- duplicated(new <- as.character(new)))) {
./dataframe.R: warning("some row.names duplicated: ",
./dataframe.R: paste(which(dup), collapse=","),
./dataframe.R- " --> row.names NOT used")
./dataframe.R- current
./dataframe.R- } else new
--
./dataframe.R- object <- as.list(substitute(list(...)))[-1]
./dataframe.R- mrn <- missing(row.names)
./dataframe.R- x <- list(...)
./dataframe.R- n <- length(x)
./dataframe.R- if(n < 1)
./dataframe.R: return(structure(list(), row.names = character(0),
./dataframe.R- class = "data.frame"))
./dataframe.R- vnames <- names(x)
./dataframe.R- if(length(vnames) != n)
./dataframe.R- vnames <- character(n)
./dataframe.R- no.vn <- nchar(vnames) == 0
./dataframe.R- vlist <- vnames <- as.list(vnames)
./dataframe.R- nrows <- ncols <- integer(n)
./dataframe.R- for(i in 1:n) {
./dataframe.R: xi <- as.data.frame(x[[i]], optional=TRUE)
./dataframe.R: rowsi <- attr(xi, "row.names")
./dataframe.R- ncols[i] <- length(xi)
./dataframe.R- namesi <- names(xi)
./dataframe.R- if(ncols[i] > 1) {
./dataframe.R- if(length(namesi) == 0) namesi <- 1:ncols[i]
./dataframe.R- if(no.vn[i]) vnames[[i]] <- namesi
./dataframe.R: else vnames[[i]] <- paste(vnames[[i]], namesi, sep=".")
./dataframe.R- }
./dataframe.R- else {
./dataframe.R- if(length(namesi) > 0) vnames[[i]] <- namesi
./dataframe.R- else if (no.vn[[i]]) {
./dataframe.R- tmpname <- deparse(object[[i]])[1]
./dataframe.R: if( substr(tmpname,1,2) == "I(" ) {
./dataframe.R- ntmpn <- nchar(tmpname)
./dataframe.R: if(substr(tmpname, ntmpn, ntmpn) == ")")
./dataframe.R: tmpname <- substr(tmpname,3,ntmpn-1)
./dataframe.R- }
./dataframe.R- vnames[[i]] <- tmpname
./dataframe.R- }
./dataframe.R- } # end of ncols[i] <= 1
./dataframe.R- nrows[i] <- length(rowsi)
./dataframe.R- if(missing(row.names) && (nrows[i] > 0) && !(rowsi[[1]] %in% ""))
./dataframe.R: row.names <- data.row.names(row.names, rowsi, i)
./dataframe.R- vlist[[i]] <- xi
./dataframe.R- }
./dataframe.R- nr <- max(nrows)
./dataframe.R- for(i in (1:n)[nrows < nr]) {
./dataframe.R- xi <- vlist[[i]]
./dataframe.R- if(length(xi)==1 && nrows[i] > 0 && nr%%nrows[i]==0) {
./dataframe.R- xi1 <- xi[[1]]
./dataframe.R- if(is.vector(xi1) || is.factor(xi1)) {
./dataframe.R: vlist[[i]] <- list(rep(xi1, length.out = nr))
./dataframe.R- next
./dataframe.R- }
./dataframe.R- if(is.character(xi1) && class(xi1) == "AsIs") {
./dataframe.R- ## simple char vectors only
./dataframe.R- cl <- class(xi1) # `methods' adds a class -- Eh?
./dataframe.R: vlist[[i]] <- list(structure(rep(xi1, length.out = nr), class=cl))
./dataframe.R- next
./dataframe.R- }
./dataframe.R- }
./dataframe.R: stop("arguments imply differing number of rows: ",
./dataframe.R: paste(unique(nrows), collapse = ", "))
./dataframe.R- }
./dataframe.R: value <- unlist(vlist, recursive=FALSE, use.names=FALSE)
./dataframe.R- ## unlist() drops i-th component if it has 0 columns
./dataframe.R- vnames <- unlist(vnames[ncols > 0])
./dataframe.R- noname <- nchar(vnames) == 0
./dataframe.R- if(any(noname))
./dataframe.R: vnames[noname] <- paste("Var", 1:length(vnames), sep = ".")[noname]
./dataframe.R- if(check.names)
./dataframe.R: vnames <- make.names(vnames, unique=TRUE)
./dataframe.R- names(value) <- vnames
./dataframe.R- if(!mrn) { # row.names arg was supplied
./dataframe.R- if(length(row.names) == 1 && nr != 1) { # one of the variables
./dataframe.R- if(is.character(row.names))
./dataframe.R: row.names <- match(row.names, vnames, 0)
./dataframe.R- if(length(row.names)!=1 ||
./dataframe.R- row.names < 1 || row.names > length(vnames))
./dataframe.R- stop("row.names should specify one of the variables")
--
./dataframe.R- if(any(dup <- duplicated(new <- as.character(new)))) {
./dataframe.R- warning("some row.names duplicated: ",
./dataframe.R- paste(which(dup), collapse=","),
./dataframe.R: " --> row.names NOT used")
./dataframe.R- current
./dataframe.R- } else new
./dataframe.R- } else current
--
./dataframe.R- if(length(row.names) == 0) row.names <- seq(length = nr)
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(any(is.na(row.names)))
./dataframe.R- stop("row names contain missing values")
./dataframe.R- if(any(duplicated(row.names)))
./dataframe.R: stop("duplicate row.names: ",
./dataframe.R: paste(unique(row.names[duplicated(row.names)]), collapse = ", "))
./dataframe.R: attr(value, "row.names") <- row.names
./dataframe.R: attr(value, "class") <- "data.frame"
./dataframe.R- value
./dataframe.R-}
./dataframe.R-
./dataframe.R-
./dataframe.R-### Subsetting and mutation methods
./dataframe.R-### These are a little less general than S
./dataframe.R-
./dataframe.R-"[.data.frame" <-
./dataframe.R: function(x, i, j, drop = if(missing(i)) TRUE else length(cols) == 1)
./dataframe.R-{
./dataframe.R- mdrop <- missing(drop)
./dataframe.R: Narg <- nargs() - !mdrop # number of arg from x,i,j that were specified
./dataframe.R-
./dataframe.R- if(Narg < 3) { # list-like indexing or matrix indexing
./dataframe.R- if(!mdrop) warning("drop argument will be ignored")
--
./dataframe.R- y <- NextMethod("[")
./dataframe.R- nm <- names(y)
./dataframe.R- if(any(is.na(nm))) stop("undefined columns selected")
./dataframe.R- ## added in 1.8.0
./dataframe.R- if(any(duplicated(nm))) names(y) <- make.unique(nm)
./dataframe.R: return(structure(y, class = oldClass(x), row.names = row.names(x)))
./dataframe.R- }
./dataframe.R-
./dataframe.R- ## preserve the attributes for later use ...
./dataframe.R-
./dataframe.R: rows <- attr(x, "row.names")
./dataframe.R- cols <- names(x)
./dataframe.R- cl <- oldClass(x) # doesn't really matter unless called directly
./dataframe.R: class(x) <- attr(x, "row.names") <- NULL
./dataframe.R-
./dataframe.R-
./dataframe.R: if(missing(i)) { # df[, j] or df[ , ]
./dataframe.R- ## handle the column only subsetting ...
./dataframe.R- if(!missing(j)) x <- x[j]
./dataframe.R- cols <- names(x)
./dataframe.R- if(any(is.na(cols))) stop("undefined columns selected")
./dataframe.R- }
./dataframe.R: else { # df[i, j] or df[i , ]
./dataframe.R- if(is.character(i))
./dataframe.R: i <- pmatch(i, rows, duplicates.ok = TRUE)
./dataframe.R- rows <- rows[i]
./dataframe.R: if(!missing(j)) { # df[i, j]
./dataframe.R- x <- x[j]
./dataframe.R- cols <- names(x)
./dataframe.R- if(any(is.na(cols))) stop("undefined columns selected")
./dataframe.R- }
./dataframe.R- for(j in seq(along = x)) {
./dataframe.R- xj <- x[[j]]
./dataframe.R- ## had drop = drop prior to 1.8.0
./dataframe.R: x[[j]] <- if(length(dim(xj)) != 2) xj[i] else xj[i, , drop = FALSE]
./dataframe.R- }
./dataframe.R- }
./dataframe.R- if(drop) {
--
./dataframe.R- ## for consistency with S: don't drop (to a list)
./dataframe.R- ## if only one row unless explicitly asked for
./dataframe.R- if(!mdrop && nrow == 1) {
./dataframe.R- drop <- TRUE
./dataframe.R- names(x) <- cols
./dataframe.R: attr(x, "row.names") <- NULL
./dataframe.R- }
./dataframe.R- }
./dataframe.R- }
--
./dataframe.R- rows[is.na(rows)] <- "NA"
./dataframe.R- rows <- make.unique(rows)
./dataframe.R- }
./dataframe.R- ## new in 1.8.0 -- might have duplicate columns
./dataframe.R- if(any(duplicated(nm <- names(x)))) names(x) <- make.unique(nm)
./dataframe.R: attr(x, "row.names") <- rows
./dataframe.R- class(x) <- cl
./dataframe.R- }
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R:"[[.data.frame" <- function(x, ...)
./dataframe.R-{
./dataframe.R- ## use in-line functions to refer to the 1st and 2nd ... arguments
./dataframe.R- ## explicitly. Also will check for wrong number or empty args
./dataframe.R- if(nargs() < 3)
./dataframe.R: (function(x, i)
./dataframe.R- if(is.matrix(i))
./dataframe.R- as.matrix(x)[[i]]
./dataframe.R: else .subset2(x,i))(x, ...)
./dataframe.R- else
./dataframe.R: .subset2(.subset2(x, ..2), ..1)
./dataframe.R-}
./dataframe.R-
./dataframe.R:"[<-.data.frame" <- function(x, i, j, value)
./dataframe.R-{
./dataframe.R: nA <- nargs() # value is never missing, so 3 or 4.
./dataframe.R: if(nA == 4) { ## df[,] or df[i,] or df[, j] or df[i,j]
./dataframe.R- has.i <- !missing(i)
./dataframe.R- has.j <- !missing(j)
./dataframe.R- }
--
./dataframe.R- i <- j <- NULL
./dataframe.R- has.i <- has.j <- FALSE
./dataframe.R- ## added in 1.8.0
./dataframe.R- if(is.null(value)) return(x[logical(0)])
./dataframe.R- } else { # case df[ind]
./dataframe.R: ## really ambiguous, but follow common use as if list
./dataframe.R- ## except for a full-sized logical matrix
./dataframe.R- if(is.logical(i) && is.matrix(i) && all(dim(i) == dim(x))) {
./dataframe.R: nreplace <- sum(i, na.rm=TRUE)
./dataframe.R- if(!nreplace) return(x) # nothing to replace
./dataframe.R- ## allow replication of length(value) > 1 in 1.8.0
./dataframe.R- N <- length(value)
./dataframe.R- if(N > 0 && N < nreplace && (nreplace %% N) == 0)
./dataframe.R: value <- rep(value, length.out = nreplace)
./dataframe.R- if(length(value) != nreplace)
./dataframe.R- stop("rhs is the wrong length for indexing by a logical matrix")
./dataframe.R- n <- 0
./dataframe.R- nv <- nrow(x)
./dataframe.R- for(v in seq(len = dim(i)[2])) {
./dataframe.R: thisvar <- i[, v, drop = TRUE]
./dataframe.R: nv <- sum(thisvar, na.rm = TRUE)
./dataframe.R- if(nv) {
./dataframe.R- if(is.matrix(x[[v]]))
./dataframe.R: x[[v]][thisvar, ] <- value[n+(1:nv)]
./dataframe.R- else
./dataframe.R- x[[v]][thisvar] <- value[n+(1:nv)]
./dataframe.R- }
--
./dataframe.R- has.i <- FALSE
./dataframe.R- has.j <- TRUE
./dataframe.R- }
./dataframe.R- }
./dataframe.R- else {
./dataframe.R: stop("need 0, 1, or 2 subscripts")
./dataframe.R- }
./dataframe.R- ## no columns specified
./dataframe.R- if(has.j && length(j) ==0) return(x)
./dataframe.R-
./dataframe.R- cl <- oldClass(x)
./dataframe.R- ## delete class: Version 3 idiom
./dataframe.R: ## to avoid any special methods for [[, etc
./dataframe.R- class(x) <- NULL
./dataframe.R: rows <- attr(x, "row.names")
./dataframe.R- new.cols <- NULL
./dataframe.R- nvars <- length(x)
./dataframe.R- nrows <- length(rows)
./dataframe.R: if(has.i) { # df[i, ] or df[i, j]
./dataframe.R- if(any(is.na(i)))
./dataframe.R- stop("missing values are not allowed in subscripted assignments of data frames")
./dataframe.R- if(char.i <- is.character(i)) {
./dataframe.R: ii <- match(i, rows)
./dataframe.R- nextra <- sum(new.rows <- is.na(ii))
./dataframe.R- if(nextra > 0) {
./dataframe.R: ii[new.rows] <- seq(from = nrows + 1, length = nextra)
./dataframe.R- new.rows <- i[new.rows]
./dataframe.R- }
./dataframe.R- i <- ii
./dataframe.R- }
./dataframe.R- if(all(i >= 0) && (nn <- max(i)) > nrows) {
./dataframe.R- ## expand
./dataframe.R- if(!char.i) {
./dataframe.R- nrr <- as.character((nrows + 1):nn)
./dataframe.R: if(inherits(value, "data.frame") &&
./dataframe.R- (dim(value)[1]) >= length(nrr)) {
./dataframe.R: new.rows <- attr(value, "row.names")[1:length(nrr)]
./dataframe.R: repl <- duplicated(new.rows) | match(new.rows, rows, 0)
./dataframe.R- if(any(repl))
./dataframe.R- new.rows[repl] <- nrr[repl]
./dataframe.R- }
./dataframe.R- else new.rows <- nrr
./dataframe.R- }
./dataframe.R: x <- xpdrows.data.frame(x, rows, new.rows)
./dataframe.R: rows <- attr(x, "row.names")
./dataframe.R- nrows <- length(rows)
./dataframe.R- }
./dataframe.R- iseq <- seq(along = rows)[i]
--
./dataframe.R- else iseq <- NULL
./dataframe.R- if(has.j) {
./dataframe.R- if(any(is.na(j)))
./dataframe.R- stop("missing values are not allowed in subscripted assignments of data frames")
./dataframe.R- if(is.character(j)) {
./dataframe.R: jj <- match(j, names(x))
./dataframe.R- nnew <- sum(is.na(jj))
./dataframe.R- if(nnew > 0) {
./dataframe.R- n <- is.na(jj)
--
./dataframe.R- else if(is.logical(j) || min(j) < 0)
./dataframe.R- jseq <- seq(along = x)[j]
./dataframe.R- else {
./dataframe.R- jseq <- j
./dataframe.R- if(max(jseq) > nvars) {
./dataframe.R: new.cols <- paste("V", seq(from = nvars + 1, to = max(jseq)),
./dataframe.R- sep = "")
./dataframe.R- if(length(new.cols) != sum(jseq > nvars))
./dataframe.R- stop("new columns would leave holes after existing columns")
./dataframe.R- ## try to use the names of a list `value'
./dataframe.R- if(is.list(value) && !is.null(vnm <- names(value))) {
./dataframe.R- p <- length(jseq)
./dataframe.R: if(length(vnm) < p) vnm <- rep(vnm, length.out = p)
./dataframe.R- new.cols <- vnm[jseq > nvars]
./dataframe.R- }
./dataframe.R- }
--
./dataframe.R- m <- length(value)
./dataframe.R- if(!is.list(value)) {
./dataframe.R- if(p == 1) {
./dataframe.R- N <- NROW(value)
./dataframe.R- if(N > n)
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, n),
./dataframe.R- domain = NA)
./dataframe.R- if(N < n && N > 0)
./dataframe.R- if(n %% N == 0 && length(dim(value)) <= 1)
./dataframe.R: value <- rep(value, length.out = n)
./dataframe.R- else
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, n),
./dataframe.R- domain = NA)
./dataframe.R- names(value) <- NULL
./dataframe.R- value <- list(value)
./dataframe.R- } else {
./dataframe.R- if(m < n*p && (n*p) %% m)
./dataframe.R: stop(gettextf("replacement has %d items, need %d", m, n*p),
./dataframe.R- domain = NA)
./dataframe.R: value <- matrix(value, n, p) ## will recycle
./dataframe.R: value <- split(value, col(value))
./dataframe.R- }
./dataframe.R: dimv <- c(n, p)
./dataframe.R- } else { # a list
./dataframe.R: ## careful, as.data.frame turns things into factors.
./dataframe.R- ## value <- as.data.frame(value)
./dataframe.R- value <- unclass(value) # to avoid data frame indexing
./dataframe.R: lens <- sapply(value, NROW)
./dataframe.R- for(k in seq(along=lens)) {
./dataframe.R- N <- lens[k]
./dataframe.R- if(n != N && length(dim(value[[k]])) == 2)
./dataframe.R: stop(gettextf("replacement element %d is a matrix/data frame of %d rows, need %d", k, N, n),
./dataframe.R- domain = NA)
./dataframe.R- if(N > 0 && N < n && n %% N)
./dataframe.R: stop(gettextf("replacement element %d has %d rows, need %d",
./dataframe.R: k, N, n), domain = NA)
./dataframe.R- ## these fixing-ups will not work for matrices
./dataframe.R: if(N > 0 && N < n) value[[k]] <- rep(value[[k]], length.out = n)
./dataframe.R- if(N > n) {
./dataframe.R: warning(gettextf("replacement element %d has %d rows to replace %d rows",
./dataframe.R: k, N, n), domain = NA)
./dataframe.R- value[[k]] <- value[[k]][1:n]
./dataframe.R- }
./dataframe.R- }
./dataframe.R: dimv <- c(n, length(value))
./dataframe.R- }
./dataframe.R- nrowv <- dimv[1]
./dataframe.R- if(nrowv < n && nrowv > 0) {
./dataframe.R- if(n %% nrowv == 0)
./dataframe.R: value <- value[rep(1:nrowv, length.out = n),,drop = FALSE]
./dataframe.R: else stop(gettextf("%d rows in value to replace %d rows", nrowv, n),
./dataframe.R- domain = NA)
./dataframe.R- }
./dataframe.R- else if(nrowv > n)
./dataframe.R: warning(gettextf("replacement data has %d rows to replace %d rows",
./dataframe.R: nrowv, n), domain = NA)
./dataframe.R- ncolv <- dimv[2]
./dataframe.R- jvseq <- seq(len=p)
./dataframe.R: if(ncolv < p) jvseq <- rep(1:ncolv, length.out = p)
./dataframe.R- else if(ncolv > p)
./dataframe.R: warning(gettextf("provided %d variables to replace %d variables",
./dataframe.R: ncolv, p), domain = NA)
./dataframe.R- if(length(new.cols)) {
./dataframe.R: ## extend and name now, as assignment of NULL may delete cols later.
./dataframe.R- nm <- names(x)
./dataframe.R: rows <- attr(x, "row.names")
./dataframe.R: x <- c(x, vector("list", length(new.cols)))
./dataframe.R: names(x) <- c(nm, new.cols)
./dataframe.R: attr(x, "row.names") <- rows
./dataframe.R- }
./dataframe.R- if(has.i)
./dataframe.R- for(jjj in seq(len=p)) {
./dataframe.R- jj <- jseq[jjj]
./dataframe.R- vjj <- value[[ jvseq[[jjj]] ]]
./dataframe.R- if(jj <= nvars) {
./dataframe.R: ## if a column exists, preserve its attributes
./dataframe.R- if(length(dim(x[jj])) != 2) x[[jj]][iseq] <- vjj
./dataframe.R: else x[[jj]][iseq, ] <- vjj
./dataframe.R- } else {
./dataframe.R- ## try to make a new column match in length: may be an error
./dataframe.R- length(vjj) <- nrows
--
./dataframe.R- }
./dataframe.R- class(x) <- cl
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R:"[[<-.data.frame"<- function(x, i, j, value)
./dataframe.R-{
./dataframe.R- cl <- oldClass(x)
./dataframe.R- ## delete class: Version 3 idiom
./dataframe.R- ## to avoid any special methods for [[<-
./dataframe.R- class(x) <- NULL
./dataframe.R: rows <- attr(x, "row.names")
./dataframe.R- nrows <- length(rows)
./dataframe.R- if(is.atomic(value)) names(value) <- NULL
./dataframe.R- if(nargs() < 4) {
./dataframe.R: ## really ambiguous, but follow common use as if list
./dataframe.R- nc <- length(x)
./dataframe.R- if(!is.null(value)) {
./dataframe.R- N <- NROW(value)
./dataframe.R- if(N > nrows)
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, nrows),
./dataframe.R- domain = NA)
./dataframe.R- if(N < nrows && N > 0)
./dataframe.R- if(nrows %% N == 0 && length(dim(value)) <= 1)
./dataframe.R: value <- rep(value, length.out = nrows)
./dataframe.R- else
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d",
./dataframe.R: N, nrows), domain = NA)
./dataframe.R- }
./dataframe.R- x[[i]] <- value
./dataframe.R- ## added in 1.8.0 -- make sure there is a name
./dataframe.R- if(length(x) > nc) {
./dataframe.R- nc <- length(x)
./dataframe.R: if(names(x)[nc] == "") names(x)[nc] <- paste("V", nc, sep="")
./dataframe.R- names(x) <- make.unique(names(x))
./dataframe.R- }
./dataframe.R- class(x) <- cl
./dataframe.R- return(x)
./dataframe.R- }
./dataframe.R- if(missing(i) || missing(j))
./dataframe.R: stop("only valid calls are x[[j]] <- value or x[[i,j]] <- value")
./dataframe.R- nvars <- length(x)
./dataframe.R- if(n <- is.character(i)) {
./dataframe.R: ii <- match(i, rows)
./dataframe.R- n <- sum(new.rows <- is.na(ii))
./dataframe.R- if(n > 0) {
./dataframe.R: ii[new.rows] <- seq(from = nrows + 1, length = n)
./dataframe.R- new.rows <- i[new.rows]
./dataframe.R- }
./dataframe.R- i <- ii
./dataframe.R- }
./dataframe.R- if(all(i >= 0) && (nn <- max(i)) > nrows) {
./dataframe.R- ## expand
./dataframe.R- if(n == 0) {
./dataframe.R- nrr <- as.character((nrows + 1):nn)
./dataframe.R: if(inherits(value, "data.frame") &&
./dataframe.R- (dim(value)[1]) >= length(nrr)) {
./dataframe.R: new.rows <- attr(value, "row.names")[1:length(nrr)]
./dataframe.R: repl <- duplicated(new.rows) | match(new.rows, rows, 0)
./dataframe.R- if(any(repl))
./dataframe.R- new.rows[repl] <- nrr[repl]
./dataframe.R- }
./dataframe.R- else new.rows <- nrr
./dataframe.R- }
./dataframe.R: x <- xpdrows.data.frame(x, rows, new.rows)
./dataframe.R: rows <- attr(x, "row.names")
./dataframe.R- nrows <- length(rows)
./dataframe.R- }
./dataframe.R- iseq <- seq(along = rows)[i]
./dataframe.R- if(any(is.na(iseq)))
./dataframe.R- stop("non-existent rows not allowed")
./dataframe.R- if(is.character(j)) {
./dataframe.R: jseq <- match(j, names(x))
./dataframe.R- if(any(is.na(jseq)))
./dataframe.R: stop("replacing element in non-existent column: ", j[is.na(jseq)])
./dataframe.R- }
./dataframe.R- else if(is.logical(j) || min(j) < 0)
./dataframe.R- jseq <- seq(along = x)[j]
./dataframe.R- else {
./dataframe.R- jseq <- j
./dataframe.R- if(max(jseq) > nvars)
./dataframe.R: stop("replacing element in non-existent column: ", jseq[jseq>nvars])
./dataframe.R- }
./dataframe.R- if(length(iseq) > 1 || length(jseq) > 1)
./dataframe.R- stop("only a single element should be replaced")
--
./dataframe.R- class(x) <- cl
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R-## added in 1.8.0
./dataframe.R:"$<-.data.frame"<- function(x, i, value)
./dataframe.R-{
./dataframe.R- cl <- oldClass(x)
./dataframe.R- ## delete class: Version 3 idiom
./dataframe.R- ## to avoid any special methods for [[<-
./dataframe.R- class(x) <- NULL
./dataframe.R: nrows <- length(attr(x, "row.names"))
./dataframe.R- if(!is.null(value)) {
./dataframe.R- N <- NROW(value)
./dataframe.R- if(N > nrows)
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, nrows),
./dataframe.R- domain = NA)
./dataframe.R- if(N < nrows && N > 0)
./dataframe.R- if(nrows %% N == 0 && length(dim(value)) <= 1)
./dataframe.R: value <- rep(value, length.out = nrows)
./dataframe.R- else
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, nrows),
./dataframe.R- domain = NA)
./dataframe.R- if(is.atomic(value)) names(value) <- NULL
./dataframe.R- }
./dataframe.R- x[[i]] <- value
./dataframe.R- class(x) <- cl
./dataframe.R- return(x)
./dataframe.R-}
./dataframe.R-
./dataframe.R:xpdrows.data.frame <- function(x, old.rows, new.rows)
./dataframe.R-{
./dataframe.R- nc <- length(x)
./dataframe.R- nro <- length(old.rows)
--
./dataframe.R- cy <- oldClass(y)
./dataframe.R- class(y) <- NULL
./dataframe.R- if (length(dy) == 2) {
./dataframe.R- dny <- dimnames(y)
./dataframe.R- if (length(dny[[1]]) > 0)
./dataframe.R: dny[[1]] <- c(dny[[1]], new.rows)
./dataframe.R: z <- array(y[1], dim = c(nr, nc), dimnames = dny)
./dataframe.R: z[1 : nro, ] <- y
./dataframe.R- class(z) <- cy
./dataframe.R- x[[i]] <- z
./dataframe.R- }
./dataframe.R- else {
./dataframe.R- ay <- attributes(y)
./dataframe.R- if (length(names(y)) > 0)
./dataframe.R: ay$names <- c(ay$names, new.rows)
./dataframe.R- length(y) <- nr
./dataframe.R- attributes(y) <- ay
./dataframe.R- class(y) <- cy
./dataframe.R- x[[i]] <- y
./dataframe.R- }
./dataframe.R- }
./dataframe.R: attr(x, "row.names") <- as.character(c(old.rows, new.rows))
./dataframe.R- x
./dataframe.R-}
./dataframe.R-
./dataframe.R-
./dataframe.R-### Here are the methods for rbind and cbind.
./dataframe.R-
./dataframe.R:cbind.data.frame <- function(..., deparse.level = 1)
./dataframe.R: data.frame(..., check.names = FALSE)
./dataframe.R-
./dataframe.R:rbind.data.frame <- function(..., deparse.level = 1)
./dataframe.R-{
./dataframe.R: match.names <- function(clabs, nmi)
./dataframe.R- {
./dataframe.R- if(all(clabs == nmi))
./dataframe.R- NULL
./dataframe.R: else if(all(nii <- match(nmi, clabs, 0)))
./dataframe.R- nii
./dataframe.R: else stop("names don't match previous names:\n\t",
./dataframe.R: paste(nmi[nii == 0], collapse = ", "))
./dataframe.R- }
./dataframe.R: Make.row.names <- function(nmi, ri, ni, nrow)
./dataframe.R- {
./dataframe.R- if(nchar(nmi) > 0) {
./dataframe.R- if(ni > 1)
./dataframe.R: paste(nmi, ri, sep = ".")
./dataframe.R- else nmi
./dataframe.R- }
./dataframe.R: else if(nrow > 0 && identical(ri, 1:ni))
./dataframe.R: seq(from = nrow + 1, length = ni)
./dataframe.R- else ri
./dataframe.R- }
./dataframe.R- allargs <- list(...)
./dataframe.R: allargs <- allargs[sapply(allargs, length) > 0]
./dataframe.R- n <- length(allargs)
./dataframe.R- if(n == 0)
./dataframe.R: return(structure(list(),
./dataframe.R: class = "data.frame",
./dataframe.R- row.names = character()))
./dataframe.R- nms <- names(allargs)
./dataframe.R- if(is.null(nms))
./dataframe.R- nms <- character(length(allargs))
./dataframe.R- cl <- NULL
./dataframe.R: perm <- rows <- rlabs <- vector("list", n)
./dataframe.R- nrow <- 0
./dataframe.R- value <- clabs <- NULL
./dataframe.R- all.levs <- list()
./dataframe.R- for(i in 1:n) {
./dataframe.R: ## check the arguments, develop row and column labels
./dataframe.R- xi <- allargs[[i]]
./dataframe.R- nmi <- nms[i]
./dataframe.R- ## coerce matrix to data frame
./dataframe.R- if(is.matrix(xi)) allargs[[i]] <- xi <- as.data.frame(xi)
./dataframe.R: if(inherits(xi, "data.frame")) {
./dataframe.R- if(is.null(cl))
./dataframe.R- cl <- oldClass(xi)
./dataframe.R- ri <- row.names(xi)
./dataframe.R- ni <- length(ri)
./dataframe.R- if(is.null(clabs))
./dataframe.R- clabs <- names(xi)
./dataframe.R- else {
./dataframe.R: pi <- match.names(clabs, names(xi))
./dataframe.R- if( !is.null(pi) )
./dataframe.R- perm[[i]] <- pi
./dataframe.R- }
./dataframe.R: rows[[i]] <- seq(from = nrow + 1, length = ni)
./dataframe.R: rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
./dataframe.R- nrow <- nrow + ni
./dataframe.R- if(is.null(value)) {
./dataframe.R- value <- unclass(xi)
./dataframe.R- nvar <- length(value)
./dataframe.R: all.levs <- vector("list", nvar)
./dataframe.R- has.dim <- logical(nvar)
./dataframe.R- facCol <- logical(nvar)
./dataframe.R- ordCol <- logical(nvar)
--
./dataframe.R- else for(j in 1:nvar)
./dataframe.R- if(facCol[j]) {
./dataframe.R- xij <- xi[[j]]
./dataframe.R- if(is.null(pi) || is.na(jj <- pi[[j]])) jj <- j
./dataframe.R- if(length(lij <- levels(xij)) > 0) {
./dataframe.R: all.levs[[jj]] <- unique(c(all.levs[[jj]], lij))
./dataframe.R- ordCol[j] <- ordCol[j] & is.ordered(xij)
./dataframe.R- } else if(is.character(xij))
./dataframe.R: all.levs[[jj]] <- unique(c(all.levs[[jj]], xij))
./dataframe.R- }
./dataframe.R- }
./dataframe.R- else if(is.list(xi)) {
./dataframe.R: ni <- range(sapply(xi, length))
./dataframe.R- if(ni[1] == ni[2])
./dataframe.R- ni <- ni[1]
./dataframe.R- else stop("invalid list argument: all variables should have the same length")
./dataframe.R: rows[[i]] <- ri <- seq(from = nrow + 1, length = ni)
./dataframe.R- nrow <- nrow + ni
./dataframe.R: rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
./dataframe.R- if(length(nmi <- names(xi)) > 0) {
./dataframe.R- if(is.null(clabs))
./dataframe.R- clabs <- nmi
./dataframe.R- else {
./dataframe.R: tmp<-match.names(clabs, nmi)
./dataframe.R- if( !is.null(tmp) )
./dataframe.R- perm[[i]] <- tmp
./dataframe.R- }
--
./dataframe.R- rlabs[[i]] <- if(nchar(nmi) > 0) nmi else nrow
./dataframe.R- }
./dataframe.R- }
./dataframe.R- nvar <- length(clabs)
./dataframe.R- if(nvar == 0)
./dataframe.R: nvar <- max(sapply(allargs, length)) # only vector args
./dataframe.R- if(nvar == 0)
./dataframe.R: return(structure(list(), class = "data.frame",
./dataframe.R- row.names = character()))
./dataframe.R- pseq <- 1:nvar
./dataframe.R- if(is.null(value)) {
--
./dataframe.R- }
./dataframe.R- names(value) <- clabs
./dataframe.R- for(j in 1:nvar)
./dataframe.R- if(length(lij <- all.levs[[j]]) > 0)
./dataframe.R- value[[j]] <-
./dataframe.R: factor(as.vector(value[[j]]), lij, ordered = ordCol[j])
./dataframe.R- if(any(has.dim)) {
./dataframe.R- rmax <- max(unlist(rows))
./dataframe.R- for(i in (1:nvar)[has.dim])
./dataframe.R: if(!inherits(xi <- value[[i]], "data.frame")) {
./dataframe.R- dn <- dimnames(xi)
./dataframe.R- rn <- dn[[1]]
./dataframe.R- if(length(rn) > 0) length(rn) <- rmax
./dataframe.R- pi <- dim(xi)[2]
./dataframe.R- length(xi) <- rmax * pi
./dataframe.R: value[[i]] <- array(xi, c(rmax, pi), list(rn, dn[[2]]))
./dataframe.R- }
./dataframe.R- }
./dataframe.R- for(i in 1:n) {
./dataframe.R- xi <- unclass(allargs[[i]])
./dataframe.R- if(!is.list(xi))
./dataframe.R- if(length(xi) != nvar)
./dataframe.R: xi <- rep(xi, length.out = nvar)
./dataframe.R- ri <- rows[[i]]
./dataframe.R- pi <- perm[[i]]
./dataframe.R- if(is.null(pi))
./dataframe.R- pi <- pseq
./dataframe.R- for(j in 1:nvar) {
./dataframe.R- jj <- pi[j]
./dataframe.R- xij <- xi[[j]]
./dataframe.R- if(has.dim[jj]) {
./dataframe.R: value[[jj]][ri, ] <- xij
./dataframe.R- ## copy rownames
./dataframe.R- rownames(value[[jj]])[ri] <- rownames(xij)
./dataframe.R- } else {
./dataframe.R: ## coerce factors to vectors, in case lhs is character or
./dataframe.R- ## level set has changed
./dataframe.R- value[[jj]][ri] <- if(is.factor(xij)) as.vector(xij) else xij
./dataframe.R- ## copy names if any
./dataframe.R- if(!is.null(nm <- names(xij))) names(value[[jj]])[ri] <- nm
./dataframe.R- }
./dataframe.R- }
./dataframe.R- }
./dataframe.R: rlabs <- make.unique(as.character(unlist(rlabs)), sep = "")
./dataframe.R- if(is.null(cl)) {
./dataframe.R: as.data.frame(value, row.names = rlabs)
./dataframe.R- } else {
./dataframe.R- class(value) <- cl
./dataframe.R: attr(value, "row.names") <- rlabs
./dataframe.R- value
./dataframe.R- }
./dataframe.R-}
./dataframe.R-
./dataframe.R-
./dataframe.R-### coercion and print methods
./dataframe.R-
./dataframe.R-print.data.frame <-
./dataframe.R: function(x, ..., digits = NULL, quote = FALSE, right = TRUE)
./dataframe.R-{
./dataframe.R- if(length(x) == 0) {
./dataframe.R: cat("NULL data frame with", length(row.names(x)), "rows\n")
./dataframe.R- } else if(length(row.names(x)) == 0) {
./dataframe.R: print.default(names(x), quote = FALSE)
./dataframe.R- cat("<0 rows> (or 0-length row.names)\n")
./dataframe.R- } else {
./dataframe.R- ## avoiding picking up e.g. format.AsIs
./dataframe.R: print(as.matrix(format.data.frame(x, digits=digits)), ...,
./dataframe.R: quote = quote, right = right)
./dataframe.R- }
./dataframe.R- invisible(x)
./dataframe.R-}
--
./dataframe.R-as.matrix.data.frame <- function (x)
./dataframe.R-{
./dataframe.R- dm <- dim(x)
./dataframe.R- dn <- dimnames(x)
./dataframe.R- if(any(dm == 0))
./dataframe.R: return(array(NA, dim = dm, dimnames = dn))
./dataframe.R- p <- dm[2]
./dataframe.R- n <- dm[1]
./dataframe.R- collabs <- as.list(dn[[2]])
--
./dataframe.R- non.numeric <- non.atomic <- FALSE
./dataframe.R- all.logical <- TRUE
./dataframe.R- for (j in 1:p) {
./dataframe.R- xj <- X[[j]]
./dataframe.R- if(length(dj <- dim(xj)) == 2 && dj[2] > 1) {
./dataframe.R: if(inherits(xj, "data.frame"))
./dataframe.R- xj <- X[[j]] <- as.matrix(X[[j]])
./dataframe.R- dnj <- dimnames(xj)[[2]]
./dataframe.R: collabs[[j]] <- paste(collabs[[j]],
./dataframe.R: if(length(dnj) > 0) dnj else 1:dj[2],
./dataframe.R- sep = ".")
./dataframe.R- }
./dataframe.R- if(!is.logical(xj)) all.logical <- FALSE
./dataframe.R- if(length(levels(xj)) > 0 || !(is.numeric(xj) || is.complex(xj))
./dataframe.R: || (!is.null(cl <- attr(xj, "class")) && # numeric classed objects to format:
./dataframe.R: any(cl %in% c("Date", "POSIXct", "POSIXlt"))))
./dataframe.R- non.numeric <- TRUE
./dataframe.R- if(!is.atomic(xj))
./dataframe.R- non.atomic <- TRUE
--
./dataframe.R- xj <- if(length(levels(xj))) as.vector(xj) else format(xj)
./dataframe.R- is.na(xj)<-miss
./dataframe.R- X[[j]]<-xj
./dataframe.R- }
./dataframe.R- }
./dataframe.R: X <- unlist(X, recursive = FALSE, use.names = FALSE)
./dataframe.R: dim(X) <- c(n, length(X)/n)
./dataframe.R: dimnames(X) <- list(dn[[1]], unlist(collabs, use.names = FALSE))
./dataframe.R- ##NO! don't copy buggy S-plus! either all matrices have class or none!!
./dataframe.R- ##NO class(X) <- "matrix"
./dataframe.R- X
./dataframe.R-}
./dataframe.R-
./dataframe.R:Math.data.frame <- function (x, ...)
./dataframe.R-{
./dataframe.R: f <- get(.Generic, mode = "function")
./dataframe.R- if (is.null(formals(f)))
./dataframe.R: f <- function(x, ...) {
./dataframe.R- }
./dataframe.R: call <- match.call(f, sys.call())
./dataframe.R- call[[1]] <- as.name(.Generic)
./dataframe.R- arg <- names(formals(f))[1]
./dataframe.R- call[[arg]] <- as.name("xx")
./dataframe.R- encl <- parent.frame()
./dataframe.R: var.f <- function(x) eval(call, list(xx = x), encl)
./dataframe.R: mode.ok <- sapply(x, is.numeric) & !sapply(x, is.factor) |
./dataframe.R: sapply(x, is.complex)
./dataframe.R- if (all(mode.ok)) {
./dataframe.R: r <- lapply(x, var.f)
./dataframe.R- class(r) <- oldClass(x)
./dataframe.R- row.names(r) <- row.names(x)
./dataframe.R- return(r)
./dataframe.R- }
./dataframe.R- else {
./dataframe.R- vnames <- names(x)
./dataframe.R- if (is.null(vnames)) vnames <- seq(along=x)
./dataframe.R: stop("non-numeric variable in data frame: ", vnames[!mode.ok])
./dataframe.R- }
./dataframe.R-}
./dataframe.R-
./dataframe.R:Ops.data.frame <- function(e1, e2 = NULL)
./dataframe.R-{
./dataframe.R- isList <- function(x) !is.null(x) && is.list(x)
./dataframe.R- unary <- nargs() == 1
./dataframe.R- lclass <- nchar(.Method[1]) > 0
./dataframe.R- rclass <- !unary && (nchar(.Method[2]) > 0)
./dataframe.R- value <- list()
./dataframe.R: ## set up call as op(left, right)
./dataframe.R: FUN <- get(.Generic, envir = parent.frame(), mode="function")
./dataframe.R- f <- if (unary)
./dataframe.R- quote(FUN(left))
./dataframe.R: else quote(FUN(left, right))
./dataframe.R- lscalar <- rscalar <- FALSE
./dataframe.R- if(lclass && rclass) {
./dataframe.R- rn <- row.names(e1)
./dataframe.R- cn <- names(e1)
./dataframe.R- if(any(dim(e2) != dim(e1)))
./dataframe.R: stop(.Generic, " only defined for equally-sized data frames")
./dataframe.R- } else if(lclass) {
./dataframe.R: ## e2 is not a data frame, but e1 is.
./dataframe.R- rn <- row.names(e1)
./dataframe.R- cn <- names(e1)
./dataframe.R- rscalar <- length(e2) <= 1 # e2 might be null
./dataframe.R- if(isList(e2)) {
./dataframe.R- if(rscalar) e2 <- e2[[1]]
./dataframe.R- else if(length(e2) != ncol(e1))
./dataframe.R: stop(gettextf("list of length %d not meaningful", length(e2)),
./dataframe.R- domain = NA)
./dataframe.R- } else {
./dataframe.R- if(!rscalar)
./dataframe.R: e2 <- split(rep(as.vector(e2), length.out = prod(dim(e1))),
./dataframe.R: rep.int(1:ncol(e1), rep.int(nrow(e1), ncol(e1))))
./dataframe.R- }
./dataframe.R- } else {
./dataframe.R: ## e1 is not a data frame, but e2 is.
./dataframe.R- rn <- row.names(e2)
./dataframe.R- cn <- names(e2)
./dataframe.R- lscalar <- length(e1) <= 1
./dataframe.R- if(isList(e1)) {
./dataframe.R- if(lscalar) e1 <- e1[[1]]
./dataframe.R- else if(length(e1) != ncol(e2))
./dataframe.R: stop(gettextf("list of length %d not meaningful", length(e1)),
./dataframe.R- domain = NA)
./dataframe.R- } else {
./dataframe.R- if(!lscalar)
./dataframe.R: e1 <- split(rep(as.vector(e1), length.out = prod(dim(e2))),
./dataframe.R: rep.int(1:ncol(e2), rep.int(nrow(e2), ncol(e2))))
./dataframe.R- }
./dataframe.R- }
./dataframe.R- for(j in seq(along=cn)) {
./dataframe.R- left <- if(!lscalar) e1[[j]] else e1
./dataframe.R- right <-if(!rscalar) e2[[j]] else e2
./dataframe.R- value[[j]] <- eval(f)
./dataframe.R- }
./dataframe.R: if(any(.Generic == c("+","-","*","/","%%","%/%"))) {
./dataframe.R- names(value) <- cn
./dataframe.R: data.frame(value, row.names=rn)
./dataframe.R- }
./dataframe.R: else matrix(unlist(value,recursive = FALSE, use.names=FALSE),
./dataframe.R: nrow=length(rn), dimnames=list(rn,cn))
./dataframe.R-}
./dataframe.R-
./dataframe.R:Summary.data.frame <- function(x, ...)
./dataframe.R-{
./dataframe.R- x <- as.matrix(x)
./dataframe.R- if(!is.numeric(x) && !is.complex(x))
--
./dataframe.R- rn <- row.names(e1)
./dataframe.R- cn <- names(e1)
./dataframe.R- if(any(dim(e2) != dim(e1)))
./dataframe.R: stop(.Generic, " only defined for equally-sized data frames")
./dataframe.R- } else if(lclass) {
./dataframe.R- ## e2 is not a data frame, but e1 is.
./dataframe.R- rn <- row.names(e1)
--
./dates.R-## The difftime class already covers time differences in days.
./dates.R-
./dates.R-## Need to take timezone into account here
./dates.R-Sys.Date <- function() .Internal(POSIXlt2Date(as.POSIXlt(Sys.time())))
./dates.R-
./dates.R:as.Date <- function(x, ...) UseMethod("as.Date")
./dates.R-
./dates.R:as.Date.POSIXct <- function(x, ...) {
./dates.R- z <- trunc(unclass(x)/86400)
./dates.R: attr(z, "tzone") <- NULL
./dates.R: structure(z, class="Date")
./dates.R-}
./dates.R-
./dates.R:as.Date.POSIXlt <- function(x, ...) .Internal(POSIXlt2Date(x))
./dates.R-
./dates.R:as.Date.factor <- function(x, ...) as.Date(as.character(x))
./dates.R-
./dates.R-
./dates.R:as.Date.character <- function(x, format="", ...)
./dates.R-{
./dates.R- fromchar <- function(x) {
./dates.R- xx <- x[1]
--
./dates.R- j <- 1
./dates.R- while(is.na(xx) && (j <- j+1) <= length(x)) xx <- x[j]
./dates.R- if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
./dates.R- }
./dates.R- if(is.na(xx) ||
./dates.R: !is.na(strptime(xx, f <- "%Y-%m-%d")) ||
./dates.R: !is.na(strptime(xx, f <- "%Y/%m/%d"))
./dates.R: ) return(strptime(x, f))
./dates.R- stop("character string is not in a standard unambiguous format")
./dates.R- }
./dates.R: res <- if(missing(format)) fromchar(x) else strptime(x, format)
./dates.R- .Internal(POSIXlt2Date(res))
./dates.R-}
./dates.R-
./dates.R:as.Date.default <- function(x, ...)
./dates.R-{
./dates.R: if(inherits(x, "Date")) return(x)
./dates.R- if(is.logical(x) && all(is.na(x)))
./dates.R: return(structure(as.numeric(x), class = "Date"))
./dates.R: stop(gettextf("do not know how to convert '%s' to class \"Date\"",
./dates.R- deparse(substitute(x))))
./dates.R-}
./dates.R-
./dates.R-## convert from package date
./dates.R:as.Date.date <- function(x, ...)
./dates.R-{
./dates.R: if(inherits(x, "date")) {
./dates.R- x <- (x - 3653) # origin 1960-01-01
./dates.R: return(structure(x, class = "Date"))
./dates.R: } else stop(gettextf("'%s' is not a \"date\" object",
./dates.R- deparse(substitute(x)) ))
./dates.R-}
./dates.R-
./dates.R-## convert from package chron
./dates.R:as.Date.dates <- function(x, ...)
./dates.R-{
./dates.R: if(inherits(x, "dates")) {
./dates.R: z <- attr(x, "origin")
./dates.R- x <- trunc(as.numeric(x))
./dates.R- if(length(z) == 3 && is.numeric(z))
./dates.R: x <- x + as.numeric(as.Date(paste(z[3], z[1], z[2], sep="/")))
./dates.R: return(structure(x, class = "Date"))
./dates.R: } else stop(gettextf("'%s' is not a \"dates\" object",
./dates.R- deparse(substitute(x)) ))
./dates.R-}
./dates.R-
./dates.R:format.Date <- function(x, ...)
./dates.R-{
./dates.R: xx <- format(as.POSIXlt(x), ...)
./dates.R- names(xx) <- names(x)
./dates.R- xx
./dates.R-}
./dates.R-
./dates.R:print.Date <- function(x, ...)
./dates.R-{
./dates.R: print(format(x), ...)
./dates.R- invisible(x)
./dates.R-}
./dates.R-
./dates.R:summary.Date <- function(object, digits = 12, ...)
./dates.R-{
./dates.R: x <- summary.default(unclass(object), digits = digits, ...)[1:6]# not NA's
./dates.R- class(x) <- oldClass(object)
./dates.R- x
./dates.R-}
./dates.R-
./dates.R:"+.Date" <- function(e1, e2)
./dates.R-{
./dates.R- coerceTimeUnit <- function(x)
./dates.R- {
./dates.R: round(switch(attr(x,"units"),
./dates.R: secs = x/86400, mins = x/1440, hours = x/24,
./dates.R: days = x, weeks = 7*x))
./dates.R- }
./dates.R-
./dates.R- if (nargs() == 1) return(e1)
./dates.R- # only valid if one of e1 and e2 is a scalar.
./dates.R: if(inherits(e1, "Date") && inherits(e2, "Date"))
./dates.R- stop("binary + is not defined for Date objects")
./dates.R: if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
./dates.R: if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
./dates.R: structure(unclass(e1) + unclass(e2), class = "Date")
./dates.R-}
./dates.R-
./dates.R:"-.Date" <- function(e1, e2)
./dates.R-{
./dates.R- coerceTimeUnit <- function(x)
./dates.R- {
./dates.R: round(switch(attr(x,"units"),
./dates.R: secs = x/86400, mins = x/1440, hours = x/24,
./dates.R: days = x, weeks = 7*x))
./dates.R- }
./dates.R: if(!inherits(e1, "Date"))
./dates.R- stop("Can only subtract from Date objects")
./dates.R- if (nargs() == 1) stop("unary - is not defined for Date objects")
./dates.R: if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
./dates.R: if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./dates.R: if(!is.null(attr(e2, "class")))
./dates.R- stop("can only subtract numbers from Date objects")
./dates.R: structure(unclass(as.Date(e1)) - e2, class = "Date")
./dates.R-}
./dates.R-
./dates.R:Ops.Date <- function(e1, e2)
./dates.R-{
./dates.R- if (nargs() == 1)
./dates.R: stop("unary ", .Generic, " not defined for Date objects")
./dates.R: boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./dates.R: "!=" = , "<=" = , ">=" = TRUE, FALSE)
./dates.R: if (!boolean) stop(.Generic, " not defined for Date objects")
./dates.R- NextMethod(.Generic)
./dates.R-}
./dates.R-
./dates.R:Math.Date <- function (x, ...)
./dates.R: stop(.Generic, " not defined for Date objects")
./dates.R-
./dates.R:Summary.Date <- function (x, ...)
./dates.R-{
./dates.R: ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
./dates.R: if (!ok) stop(.Generic, " not defined for Date objects")
./dates.R- val <- NextMethod(.Generic)
./dates.R- class(val) <- oldClass(x)
./dates.R- val
./dates.R-}
./dates.R-
./dates.R:"[.Date" <- function(x, ..., drop = TRUE)
./dates.R-{
./dates.R- cl <- oldClass(x)
./dates.R- class(x) <- NULL
./dates.R- val <- NextMethod("[")
./dates.R- class(val) <- cl
./dates.R- val
./dates.R-}
./dates.R-
./dates.R:"[[.Date" <- function(x, ..., drop = TRUE)
./dates.R-{
./dates.R- cl <- oldClass(x)
./dates.R- class(x) <- NULL
./dates.R- val <- NextMethod("[[")
./dates.R- class(val) <- cl
./dates.R- val
./dates.R-}
./dates.R-
./dates.R:"[<-.Date" <- function(x, ..., value)
./dates.R-{
./dates.R- if(!as.logical(length(value))) return(x)
./dates.R- value <- as.Date(value)
--
./dates.R- x <- NextMethod(.Generic)
./dates.R- class(x) <- cl
./dates.R- x
./dates.R-}
./dates.R-
./dates.R:as.character.Date <- function(x, ...) format(x, ...)
./dates.R-
./dates.R-as.data.frame.Date <- as.data.frame.vector
./dates.R-
./dates.R:c.Date <- function(..., recursive=FALSE)
./dates.R: structure(c(unlist(lapply(list(...), unclass))), class="Date")
./dates.R-
./dates.R:mean.Date <- function (x, ...)
./dates.R: structure(mean(unclass(x), ...), class = "Date")
./dates.R-
./dates.R:seq.Date <- function(from, to, by, length.out=NULL, along.with=NULL, ...)
./dates.R-{
./dates.R- if (missing(from)) stop("'from' must be specified")
./dates.R: if (!inherits(from, "Date")) stop("'from' must be a Date object")
./dates.R- if(length(as.Date(from)) != 1) stop("'from' must be of length 1")
./dates.R- if (!missing(to)) {
./dates.R: if (!inherits(to, "Date")) stop("'to' must be a Date object")
./dates.R- if (length(as.Date(to)) != 1) stop("'to' must be of length 1")
./dates.R- }
./dates.R- if (!missing(along.with)) {
./dates.R- length.out <- length(along.with)
./dates.R- } else if (!missing(length.out)) {
./dates.R- if (length(length.out) != 1) stop("'length.out' must be of length 1")
./dates.R- length.out <- ceiling(length.out)
./dates.R- }
./dates.R: status <- c(!missing(to), !missing(by), !is.null(length.out))
./dates.R- if(sum(status) != 2)
./dates.R: stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
./dates.R- if (missing(by)) {
./dates.R- from <- unclass(as.Date(from))
./dates.R- to <- unclass(as.Date(to))
./dates.R: res <- seq.default(from, to, length.out = length.out)
./dates.R: return(structure(res, class = "Date"))
./dates.R- }
./dates.R-
./dates.R- if (length(by) != 1) stop("'by' must be of length 1")
./dates.R- valid <- 0
./dates.R: if (inherits(by, "difftime")) {
./dates.R: by <- switch(attr(by,"units"), secs = 1/86400, mins = 1/1440,
./dates.R: hours = 1/24, days = 1, weeks = 7) * unclass(by)
./dates.R- } else if(is.character(by)) {
./dates.R: by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
./dates.R- if(length(by2) > 2 || length(by2) < 1)
./dates.R- stop("invalid 'by' string")
./dates.R: valid <- pmatch(by2[length(by2)],
./dates.R: c("days", "weeks", "months", "years"))
./dates.R- if(is.na(valid)) stop("invalid string for 'by'")
./dates.R- if(valid <= 2) {
./dates.R: by <- c(1, 7)[valid]
./dates.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./dates.R- } else
./dates.R- by <- if(length(by2) == 2) as.integer(by2[1]) else 1
--
./dates.R- if(is.na(by)) stop("'by' is NA")
./dates.R-
./dates.R- if(valid <= 2) {
./dates.R- from <- unclass(as.Date(from))
./dates.R- if(!is.null(length.out))
./dates.R: res <- seq.default(from, by=by, length.out=length.out)
./dates.R- else {
./dates.R- to <- unclass(as.Date(to))
./dates.R- ## defeat test in seq.default
./dates.R: res <- seq.default(0, to - from, by) + from
./dates.R- }
./dates.R: return(structure(res, class="Date"))
./dates.R- } else { # months or years or DSTdays
./dates.R- r1 <- as.POSIXlt(from)
./dates.R- if(valid == 4) {
./dates.R- if(missing(to)) { # years
./dates.R: yr <- seq(r1$year, by = by, length = length.out)
./dates.R- } else {
./dates.R- to <- as.POSIXlt(to)
./dates.R: yr <- seq(r1$year, to$year, by)
./dates.R- }
./dates.R- r1$year <- yr
./dates.R- res <- .Internal(POSIXlt2Date(r1))
./dates.R- } else if(valid == 3) { # months
./dates.R- if(missing(to)) {
./dates.R: mon <- seq(r1$mon, by = by, length = length.out)
./dates.R- } else {
./dates.R- to <- as.POSIXlt(to)
./dates.R: mon <- seq(r1$mon, 12*(to$year - r1$year) + to$mon, by)
./dates.R- }
./dates.R- r1$mon <- mon
./dates.R- res <- .Internal(POSIXlt2Date(r1))
--
./dates.R- return(res)
./dates.R- }
./dates.R-}
./dates.R-
./dates.R-cut.Date <-
./dates.R: function (x, breaks, labels = NULL, start.on.monday = TRUE,
./dates.R: right = FALSE, ...)
./dates.R-{
./dates.R: if(!inherits(x, "Date")) stop("'x' must be a date-time object")
./dates.R- x <- as.Date(x)
./dates.R-
./dates.R: if (inherits(breaks, "Date")) {
./dates.R- breaks <- as.Date(breaks)
./dates.R- } else if(is.numeric(breaks) && length(breaks) == 1) {
./dates.R- ## specified number of breaks
./dates.R- } else if(is.character(breaks) && length(breaks) == 1) {
./dates.R: by2 <- strsplit(breaks, " ", fixed=TRUE)[[1]]
./dates.R- if(length(by2) > 2 || length(by2) < 1)
./dates.R- stop("invalid specification of 'breaks'")
./dates.R- valid <-
./dates.R: pmatch(by2[length(by2)], c("days", "weeks", "months", "years"))
./dates.R- if(is.na(valid)) stop("invalid specification of 'breaks'")
./dates.R: start <- as.POSIXlt(min(x, na.rm=TRUE))
./dates.R- if(valid == 1) incr <- 1
./dates.R- if(valid == 2) {
./dates.R- start$mday <- start$mday - start$wday
./dates.R- if(start.on.monday)
./dates.R: start$mday <- start$mday + ifelse(start$wday > 0, 1, -6)
./dates.R- incr <- 7
./dates.R- }
./dates.R- if(valid == 3) { start$mday <- 1; incr <- 31 }
./dates.R- if(valid == 4) { start$mon <- 0; incr <- 366 }
./dates.R- start <- .Internal(POSIXlt2Date(start))
./dates.R- if (length(by2) == 2) incr <- incr * as.integer(by2[1])
./dates.R: maxx <- max(x, na.rm = TRUE)
./dates.R: breaks <- seq(start, maxx + incr, breaks)
./dates.R- breaks <- breaks[1:(1+max(which(breaks < maxx)))]
./dates.R- } else stop("invalid specification of 'breaks'")
./dates.R: res <- cut(unclass(x), unclass(breaks), labels = labels,
./dates.R: right = right, ...)
./dates.R- if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
./dates.R- res
./dates.R-}
./dates.R-
./dates.R:julian.Date <- function(x, origin = as.Date("1970-01-01"), ...)
./dates.R-{
./dates.R- if(length(origin) != 1) stop("'origin' must be of length one")
./dates.R: structure(unclass(x) - unclass(origin), "origin" = origin)
./dates.R-}
./dates.R-
./dates.R:weekdays.Date <- function(x, abbreviate = FALSE)
./dates.R: format(x, ifelse(abbreviate, "%a", "%A"))
./dates.R-
./dates.R:months.Date <- function(x, abbreviate = FALSE)
./dates.R: format(x, ifelse(abbreviate, "%b", "%B"))
./dates.R-
./dates.R:quarters.Date <- function(x, ...)
./dates.R-{
./dates.R- x <- (as.POSIXlt(x)$mon) %/% 3
./dates.R: paste("Q", x+1, sep = "")
./dates.R-}
./dates.R-
./dates.R:## These only make sense for negative digits, but still ...
./dates.R:round.Date <- function(x, ...)
./dates.R-{
./dates.R- cl <- oldClass(x)
./dates.R- class(x) <- NULL
--
./dates.R-}
./dates.R-
./dates.R-## must avoid truncating dates prior to 1970-01-01 forwards.
./dates.R-trunc.Date <- function(x) round(x - 0.4999999)
./dates.R-
./dates.R:rep.Date <- function(x, times, ...)
./dates.R-{
./dates.R- y <- NextMethod()
./dates.R: structure(y, class="Date")
./dates.R-}
./dates.R-
./dates.R:diff.Date <- function (x, lag = 1, differences = 1, ...)
./dates.R-{
./dates.R- ismat <- is.matrix(x)
./dates.R- xlen <- if (ismat) dim(x)[1] else length(x)
./dates.R- if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
./dates.R- stop("'lag' and 'differences' must be integers >= 1")
./dates.R- if (lag * differences >= xlen)
./dates.R: return(structure(numeric(0), class="difftime", units="days"))
./dates.R- r <- x
./dates.R- i1 <- -1:-lag
./dates.R: if (ismat) for (i in 1:differences) r <- r[i1, , drop = FALSE] -
./dates.R: r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
./dates.R- else for (i in 1:differences)
./dates.R- r <- r[i1] - r[-length(r):-(length(r) - lag + 1)]
./dates.R- r
--
./datetime.R-Sys.time <- function()
./datetime.R: structure(.Internal(Sys.time()), class = c("POSIXt", "POSIXct"))
./datetime.R-
./datetime.R-Sys.timezone <- function() as.vector(Sys.getenv("TZ"))
./datetime.R-
./datetime.R:as.POSIXlt <- function(x, tz = "")
./datetime.R-{
./datetime.R- fromchar <- function(x) {
./datetime.R- xx <- x[1]
--
./datetime.R- while(is.na(xx) && (j <- j+1) <= length(x))
./datetime.R- xx <- x[j]
./datetime.R- if(is.na(xx)) f <- "%Y-%m-%d" # all NAs
./datetime.R- }
./datetime.R- if(is.na(xx) ||
./datetime.R: !is.na(strptime(xx, f <- "%Y-%m-%d %H:%M:%S")) ||
./datetime.R: !is.na(strptime(xx, f <- "%Y/%m/%d %H:%M:%S")) ||
./datetime.R: !is.na(strptime(xx, f <- "%Y-%m-%d %H:%M")) ||
./datetime.R: !is.na(strptime(xx, f <- "%Y/%m/%d %H:%M")) ||
./datetime.R: !is.na(strptime(xx, f <- "%Y-%m-%d")) ||
./datetime.R: !is.na(strptime(xx, f <- "%Y/%m/%d")))
./datetime.R- {
./datetime.R: res <- strptime(x, f)
./datetime.R: if(nchar(tz)) attr(res, "tzone") <- tz
./datetime.R- return(res)
./datetime.R- }
./datetime.R- stop("character string is not in a standard unambiguous format")
./datetime.R- }
./datetime.R-
./datetime.R: if(inherits(x, "POSIXlt")) return(x)
./datetime.R: if(inherits(x, "Date")) return(.Internal(Date2POSIXlt(x)))
./datetime.R: tzone <- attr(x, "tzone")
./datetime.R: if(inherits(x, "date") || inherits(x, "dates")) x <- as.POSIXct(x)
./datetime.R- if(is.character(x)) return(fromchar(x))
./datetime.R- if(is.factor(x)) return(fromchar(as.character(x)))
./datetime.R- if(is.logical(x) && all(is.na(x))) x <- as.POSIXct.default(x)
./datetime.R: if(!inherits(x, "POSIXct"))
./datetime.R: stop(gettextf("do not know how to convert '%s' to class \"POSIXlt\"",
./datetime.R- deparse(substitute(x))))
./datetime.R- if(missing(tz) && !is.null(tzone)) tz <- tzone[1]
./datetime.R: .Internal(as.POSIXlt(x, tz))
./datetime.R-}
./datetime.R-
./datetime.R:as.POSIXct <- function(x, tz = "") UseMethod("as.POSIXct")
./datetime.R-
./datetime.R:as.POSIXct.Date <- function(x, ...)
./datetime.R: structure(unclass(x)*86400, class=c("POSIXt", "POSIXct"))
./datetime.R-
./datetime.R-
./datetime.R-## convert from package date
./datetime.R:as.POSIXct.date <- function(x, ...)
./datetime.R-{
./datetime.R: if(inherits(x, "date")) {
./datetime.R- x <- (x - 3653) * 86400 # origin 1960-01-01
./datetime.R: return(structure(x, class = c("POSIXt", "POSIXct")))
./datetime.R: } else stop(gettextf("'%s' is not a \"date\" object",
./datetime.R- deparse(substitute(x)) ))
./datetime.R-}
./datetime.R-
./datetime.R-## convert from package chron
./datetime.R:as.POSIXct.dates <- function(x, ...)
./datetime.R-{
./datetime.R: if(inherits(x, "dates")) {
./datetime.R: z <- attr(x, "origin")
./datetime.R- x <- as.numeric(x) * 86400
./datetime.R- if(length(z) == 3 && is.numeric(z))
./datetime.R: x <- x + as.numeric(ISOdate(z[3], z[1], z[2], 0))
./datetime.R: return(structure(x, class = c("POSIXt", "POSIXct")))
./datetime.R: } else stop(gettextf("'%s' is not a \"dates\" object",
./datetime.R- deparse(substitute(x)) ))
./datetime.R-}
./datetime.R-
./datetime.R:as.POSIXct.POSIXlt <- function(x, tz = "")
./datetime.R-{
./datetime.R: tzone <- attr(x, "tzone")
./datetime.R- if(missing(tz) && !is.null(tzone)) tz <- tzone[1]
./datetime.R: structure(.Internal(as.POSIXct(x, tz)), class = c("POSIXt", "POSIXct"),
./datetime.R- tzone = tz)
./datetime.R-}
./datetime.R-
./datetime.R:as.POSIXct.default <- function(x, tz = "")
./datetime.R-{
./datetime.R: if(inherits(x, "POSIXct")) return(x)
./datetime.R- if(is.character(x) || is.factor(x))
./datetime.R: return(as.POSIXct(as.POSIXlt(x), tz))
./datetime.R- if(is.logical(x) && all(is.na(x)))
./datetime.R: return(structure(as.numeric(x), class = c("POSIXt", "POSIXct")))
./datetime.R: stop(gettextf("do not know how to convert '%s' to class \"POSIXlt\"",
./datetime.R- deparse(substitute(x))))
./datetime.R-}
./datetime.R-
./datetime.R:format.POSIXlt <- function(x, format = "", usetz = FALSE, ...)
./datetime.R-{
./datetime.R: if(!inherits(x, "POSIXlt")) stop("wrong class")
./datetime.R- if(format == "") {
./datetime.R- ## need list [ method here.
./datetime.R- times <- unlist(unclass(x)[1:3])
./datetime.R- format <- if(all(times[!is.na(times)] == 0)) "%Y-%m-%d"
./datetime.R- else "%Y-%m-%d %H:%M:%S"
./datetime.R- }
./datetime.R: .Internal(format.POSIXlt(x, format, usetz))
./datetime.R-}
./datetime.R-
./datetime.R-strftime <- format.POSIXlt
./datetime.R-
./datetime.R:strptime <- function(x, format)
./datetime.R: .Internal(strptime(as.character(x), format))
./datetime.R-
./datetime.R-
./datetime.R:format.POSIXct <- function(x, format = "", tz = "", usetz = FALSE, ...)
./datetime.R-{
./datetime.R: if(!inherits(x, "POSIXct")) stop("wrong class")
./datetime.R: if(missing(tz) && !is.null(tzone <- attr(x, "tzone"))) tz <- tzone
./datetime.R: structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, ...),
./datetime.R- names=names(x))
./datetime.R-}
./datetime.R-
./datetime.R:print.POSIXct <- function(x, ...)
./datetime.R-{
./datetime.R: print(format(x, usetz=TRUE, ...), ...)
./datetime.R- invisible(x)
./datetime.R-}
./datetime.R-
./datetime.R:print.POSIXlt <- function(x, ...)
./datetime.R-{
./datetime.R: print(format(x, usetz=TRUE), ...)
./datetime.R- invisible(x)
./datetime.R-}
./datetime.R-
./datetime.R:summary.POSIXct <- function(object, digits=15, ...)
./datetime.R-{
./datetime.R: x <- summary.default(unclass(object), digits=digits, ...)[1:6]# no NA's
./datetime.R- class(x) <- oldClass(object)
./datetime.R: attr(x, "tzone") <- attr(object, "tzone")
./datetime.R- x
./datetime.R-}
./datetime.R-
./datetime.R:summary.POSIXlt <- function(object, digits = 15, ...)
./datetime.R: summary(as.POSIXct(object), digits = digits, ...)
./datetime.R-
./datetime.R-
./datetime.R:"+.POSIXt" <- function(e1, e2)
./datetime.R-{
./datetime.R- coerceTimeUnit <- function(x)
./datetime.R- {
./datetime.R: switch(attr(x,"units"),
./datetime.R: secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R: days = 60*60*24*x, weeks = 60*60*24*7*x)
./datetime.R- }
./datetime.R-
./datetime.R- if (nargs() == 1) return(e1)
./datetime.R- # only valid if one of e1 and e2 is a scalar.
./datetime.R: if(inherits(e1, "POSIXt") && inherits(e2, "POSIXt"))
./datetime.R- stop("binary + is not defined for \"POSIXt\" objects")
./datetime.R: if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
./datetime.R: if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
./datetime.R: if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
./datetime.R: if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
./datetime.R: structure(unclass(e1) + unclass(e2), class = c("POSIXt", "POSIXct"))
./datetime.R-}
./datetime.R-
./datetime.R:"-.POSIXt" <- function(e1, e2)
./datetime.R-{
./datetime.R- coerceTimeUnit <- function(x)
./datetime.R- {
./datetime.R: switch(attr(x,"units"),
./datetime.R: secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R: days = 60*60*24*x, weeks = 60*60*24*7*x)
./datetime.R- }
./datetime.R: if(!inherits(e1, "POSIXt"))
./datetime.R- stop("Can only subtract from POSIXt objects")
./datetime.R- if (nargs() == 1) stop("unary - is not defined for \"POSIXt\" objects")
./datetime.R: if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
./datetime.R: if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./datetime.R: if(!is.null(attr(e2, "class")))
./datetime.R- stop("can only subtract numbers from POSIXt objects")
./datetime.R: structure(unclass(as.POSIXct(e1)) - e2, class = c("POSIXt", "POSIXct"))
./datetime.R-}
./datetime.R-
./datetime.R:Ops.POSIXt <- function(e1, e2)
./datetime.R-{
./datetime.R- if (nargs() == 1)
./datetime.R: stop("unary", .Generic, " not defined for \"POSIXt\" objects")
./datetime.R: boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./datetime.R: "!=" = , "<=" = , ">=" = TRUE, FALSE)
./datetime.R: if (!boolean) stop(.Generic, " not defined for \"POSIXt\" objects")
./datetime.R: if(inherits(e1, "POSIXlt")) e1 <- as.POSIXct(e1)
./datetime.R: if(inherits(e2, "POSIXlt")) e2 <- as.POSIXct(e2)
./datetime.R- NextMethod(.Generic)
./datetime.R-}
./datetime.R-
./datetime.R:Math.POSIXt <- function (x, ...)
./datetime.R-{
./datetime.R: stop(.Generic, " not defined for POSIXt objects")
./datetime.R-}
./datetime.R-
./datetime.R:Summary.POSIXct <- function (x, ...)
./datetime.R-{
./datetime.R: ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
./datetime.R: if (!ok) stop(.Generic, " not defined for \"POSIXct\" objects")
./datetime.R- val <- NextMethod(.Generic)
./datetime.R- class(val) <- oldClass(x)
./datetime.R- val
./datetime.R-}
./datetime.R-
./datetime.R:Summary.POSIXlt <- function (x, ...)
./datetime.R-{
./datetime.R: ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
./datetime.R: if (!ok) stop(.Generic, " not defined for \"POSIXlt\" objects")
./datetime.R- x <- as.POSIXct(x)
./datetime.R- val <- NextMethod(.Generic)
./datetime.R: as.POSIXlt(structure(val, class = c("POSIXt", "POSIXct")))
./datetime.R-}
./datetime.R-
./datetime.R-"[.POSIXct" <-
./datetime.R:function(x, ..., drop = TRUE)
./datetime.R-{
./datetime.R- cl <- oldClass(x)
./datetime.R- class(x) <- NULL
--
./datetime.R- class(val) <- cl
./datetime.R- val
./datetime.R-}
./datetime.R-
./datetime.R-"[[.POSIXct" <-
./datetime.R:function(x, ..., drop = TRUE)
./datetime.R-{
./datetime.R- cl <- oldClass(x)
./datetime.R- class(x) <- NULL
--
./datetime.R- class(val) <- cl
./datetime.R- val
./datetime.R-}
./datetime.R-
./datetime.R-"[<-.POSIXct" <-
./datetime.R:function(x, ..., value) {
./datetime.R- if(!as.logical(length(value))) return(x)
./datetime.R- value <- as.POSIXct(value)
./datetime.R- cl <- oldClass(x)
--
./datetime.R- x <- NextMethod(.Generic)
./datetime.R- class(x) <- cl
./datetime.R- x
./datetime.R-}
./datetime.R-
./datetime.R:as.character.POSIXt <- function(x, ...) format(x, ...)
./datetime.R-
./datetime.R:str.POSIXt <- function(object, ...) {
./datetime.R- cl <- oldClass(object)
./datetime.R: cat("'", cl[min(2, length(cl))],"', format:", sep = "")
./datetime.R: str(format(object), ...)
./datetime.R-}
./datetime.R-
./datetime.R-as.data.frame.POSIXct <- as.data.frame.vector
./datetime.R-
./datetime.R-is.na.POSIXlt <- function(x) is.na(as.POSIXct(x))
./datetime.R-
./datetime.R:c.POSIXct <- function(..., recursive=FALSE)
./datetime.R: structure(c(unlist(lapply(list(...), unclass))),
./datetime.R: class=c("POSIXt","POSIXct"))
./datetime.R-
./datetime.R-## we need conversion to POSIXct as POSIXlt objects can be in different tz.
./datetime.R:c.POSIXlt <- function(..., recursive=FALSE)
./datetime.R: as.POSIXlt(do.call("c", lapply(list(...), as.POSIXct)))
./datetime.R-
./datetime.R-## force absolute comparisons
./datetime.R:all.equal.POSIXct <- function(target, current, ..., scale=1)
./datetime.R- NextMethod("all.equal")
./datetime.R-
./datetime.R-
./datetime.R-
./datetime.R:ISOdatetime <- function(year, month, day, hour, min, sec, tz="")
./datetime.R-{
./datetime.R: x <- paste(year, month, day, hour, min, sec, sep="-")
./datetime.R: as.POSIXct(strptime(x, "%Y-%m-%d-%H-%M-%S"), tz=tz)
./datetime.R-}
./datetime.R-
./datetime.R:ISOdate <- function(year, month, day, hour=12, min=0, sec=0, tz="GMT")
./datetime.R: ISOdatetime(year, month, day, hour, min, sec, tz)
./datetime.R-
./datetime.R-as.matrix.POSIXlt <- function(x)
./datetime.R-{
./datetime.R- as.matrix(as.data.frame(unclass(x)))
./datetime.R-}
./datetime.R-
./datetime.R:mean.POSIXct <- function (x, ...)
./datetime.R: structure(mean(unclass(x), ...), class = c("POSIXt", "POSIXct"),
./datetime.R: tzone=attr(x, "tzone"))
./datetime.R-
./datetime.R:mean.POSIXlt <- function (x, ...)
./datetime.R: as.POSIXlt(mean(as.POSIXct(x), ...))
./datetime.R-
./datetime.R-## ----- difftime -----
./datetime.R-
./datetime.R-difftime <-
./datetime.R: function(time1, time2, tz = "",
./datetime.R: units = c("auto", "secs", "mins", "hours", "days", "weeks"))
./datetime.R-{
./datetime.R: time1 <- as.POSIXct(time1, tz = tz)
./datetime.R: time2 <- as.POSIXct(time2, tz = tz)
./datetime.R- z <- unclass(time1) - unclass(time2)
./datetime.R- units <- match.arg(units)
./datetime.R- if(units == "auto") {
./datetime.R- if(all(is.na(z))) units <- "secs"
./datetime.R- else {
./datetime.R: zz <- min(abs(z),na.rm=TRUE)
./datetime.R- if(is.na(zz) || zz < 60) units <- "secs"
./datetime.R- else if(zz < 3600) units <- "mins"
./datetime.R- else if(zz < 86400) units <- "hours"
./datetime.R- else units <- "days"
./datetime.R- }
./datetime.R- }
./datetime.R: switch(units,
./datetime.R: "secs" = structure(z, units="secs", class="difftime"),
./datetime.R: "mins" = structure(z/60, units="mins", class="difftime"),
./datetime.R: "hours"= structure(z/3600, units="hours", class="difftime"),
./datetime.R: "days" = structure(z/86400, units="days", class="difftime"),
./datetime.R: "weeks" = structure(z/(7*86400), units="weeks", class="difftime")
./datetime.R- )
./datetime.R-}
./datetime.R-
./datetime.R-## "difftime" constructor
./datetime.R:## Martin Maechler, Date: 16 Sep 2002
./datetime.R:as.difftime <- function(tim, format="%X")
./datetime.R-{
./datetime.R: difftime(strptime(tim, format=format),
./datetime.R: strptime("0:0:0", format="%X"))
./datetime.R-}
./datetime.R-
./datetime.R:print.difftime <- function(x, digits = getOption("digits"), ...)
./datetime.R-{
./datetime.R- if(is.array(x)) {
./datetime.R: cat("Time differences in ", attr(x, "units"), "\n", sep="")
./datetime.R: y <- unclass(x); attr(y, "units") <- NULL
./datetime.R- print(y)
./datetime.R- } else if(length(x) > 1)
./datetime.R: cat("Time differences of ",
./datetime.R: paste(format(unclass(x), digits=digits), collapse = ", "), " ",
./datetime.R: attr(x, "units"), "\n", sep="")
./datetime.R- else
./datetime.R: cat("Time difference of ", format(unclass(x), digits=digits), " ",
./datetime.R: attr(x, "units"), "\n", sep="")
./datetime.R-
./datetime.R- invisible(x)
./datetime.R-}
./datetime.R-
./datetime.R:round.difftime <- function (x, digits = 0)
./datetime.R-{
./datetime.R: units <- attr(x, "units")
./datetime.R: structure(NextMethod(), units=units, class="difftime")
./datetime.R-}
./datetime.R-
./datetime.R:"[.difftime" <- function(x, ..., drop = TRUE)
./datetime.R-{
./datetime.R- cl <- oldClass(x)
./datetime.R- class(x) <- NULL
./datetime.R- val <- NextMethod("[")
./datetime.R- class(val) <- cl
./datetime.R: attr(val, "units") <- attr(x, "units")
./datetime.R- val
./datetime.R-}
./datetime.R-
./datetime.R:Ops.difftime <- function(e1, e2)
./datetime.R-{
./datetime.R- coerceTimeUnit <- function(x)
./datetime.R- {
./datetime.R: switch(attr(x,"units"),
./datetime.R: secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R: days = 60*60*24*x, weeks = 60*60*24*7*x)
./datetime.R- }
./datetime.R- if (nargs() == 1)
./datetime.R: stop("unary", .Generic, " not defined for \"difftime\" objects")
./datetime.R: boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./datetime.R: "!=" = , "<=" = , ">=" = TRUE, FALSE)
./datetime.R- if (boolean) {
./datetime.R- ## assume user knows what he/she is doing if not both difftime
./datetime.R: if(inherits(e1, "difftime") && inherits(e2, "difftime")) {
./datetime.R- e1 <- coerceTimeUnit(e1)
./datetime.R- e2 <- coerceTimeUnit(e2)
./datetime.R- }
./datetime.R- NextMethod(.Generic)
./datetime.R- } else if(.Generic == "+" || .Generic == "-") {
./datetime.R: if(inherits(e1, "difftime") && !inherits(e2, "difftime"))
./datetime.R: return(structure(NextMethod(.Generic),
./datetime.R: units = attr(e1, "units"), class = "difftime"))
./datetime.R: if(!inherits(e1, "difftime") && inherits(e2, "difftime"))
./datetime.R: return(structure(NextMethod(.Generic),
./datetime.R: units = attr(e2, "units"), class = "difftime"))
./datetime.R: u1 <- attr(e1, "units")
./datetime.R: if(attr(e2, "units") == u1) {
./datetime.R: structure(NextMethod(.Generic), units=u1, class="difftime")
./datetime.R- } else {
./datetime.R- e1 <- coerceTimeUnit(e1)
./datetime.R- e2 <- coerceTimeUnit(e2)
./datetime.R: structure(NextMethod(.Generic), units="secs", class="difftime")
./datetime.R- }
./datetime.R- } else {
./datetime.R- ## '*' is covered by a specific method
./datetime.R: stop(.Generic, "not defined for \"difftime\" objects")
./datetime.R- }
./datetime.R-}
./datetime.R-
./datetime.R:"*.difftime" <- function (e1, e2)
./datetime.R-{
./datetime.R: ## need one scalar, one difftime.
./datetime.R: if(inherits(e1, "difftime") && inherits(e2, "difftime"))
./datetime.R- stop("both arguments of * cannot be \"difftime\" objects")
./datetime.R: if(inherits(e2, "difftime")) {tmp <- e1; e1 <- e2; e2 <- tmp}
./datetime.R: structure(e2 * unclass(e1), units = attr(e1, "units"),
./datetime.R- class = "difftime")
./datetime.R-}
./datetime.R-
./datetime.R:"/.difftime" <- function (e1, e2)
./datetime.R-{
./datetime.R: ## need one scalar, one difftime.
./datetime.R: if(inherits(e2, "difftime"))
./datetime.R- stop("second argument of / cannot be a \"difftime\" object")
./datetime.R: structure(unclass(e1) / e2, units = attr(e1, "units"),
./datetime.R- class = "difftime")
./datetime.R-}
./datetime.R-
./datetime.R:Math.difftime <- function (x, ...)
./datetime.R-{
./datetime.R: stop(.Generic, "not defined for \"difftime\" objects")
./datetime.R-}
./datetime.R-
./datetime.R:mean.difftime <- function (x, ..., na.rm = FALSE)
./datetime.R-{
./datetime.R- coerceTimeUnit <- function(x)
./datetime.R- {
./datetime.R: as.vector(switch(attr(x,"units"),
./datetime.R: secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R: days = 60*60*24*x, weeks = 60*60*24*7*x))
./datetime.R- }
./datetime.R- if(length(list(...))) {
./datetime.R: args <- c(lapply(list(x, ...), coerceTimeUnit), na.rm = na.rm)
./datetime.R: structure(do.call("mean", args), units="secs", class="difftime")
./datetime.R- } else {
./datetime.R: structure(mean(as.vector(x), na.rm = na.rm),
./datetime.R: units=attr(x, "units"), class="difftime")
./datetime.R- }
./datetime.R-}
./datetime.R-
./datetime.R:Summary.difftime <- function (x, ..., na.rm = FALSE)
./datetime.R-{
./datetime.R- coerceTimeUnit <- function(x)
./datetime.R- {
./datetime.R: as.vector(switch(attr(x,"units"),
./datetime.R: secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R: days = 60*60*24*x, weeks = 60*60*24*7*x))
./datetime.R- }
./datetime.R: ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
./datetime.R: if (!ok) stop(.Generic, " not defined for \"difftime\" objects")
./datetime.R: args <- c(lapply(list(x, ...), coerceTimeUnit), na.rm = na.rm)
./datetime.R: structure(do.call(.Generic, args), units="secs", class="difftime")
./datetime.R-}
./datetime.R-
./datetime.R-
./datetime.R-## ----- convenience functions -----
./datetime.R-
./datetime.R-seq.POSIXt <-
./datetime.R: function(from, to, by, length.out = NULL, along.with = NULL, ...)
./datetime.R-{
./datetime.R- if (missing(from)) stop("'from' must be specified")
./datetime.R: if (!inherits(from, "POSIXt")) stop("'from' must be a POSIXt object")
./datetime.R- if(length(as.POSIXct(from)) != 1) stop("'from' must be of length 1")
./datetime.R- if (!missing(to)) {
./datetime.R: if (!inherits(to, "POSIXt")) stop("'to' must be a POSIXt object")
./datetime.R- if (length(as.POSIXct(to)) != 1) stop("'to' must be of length 1")
./datetime.R- }
./datetime.R- if (!missing(along.with)) {
./datetime.R- length.out <- length(along.with)
./datetime.R- } else if (!missing(length.out)) {
./datetime.R- if (length(length.out) != 1) stop("'length.out' must be of length 1")
./datetime.R- length.out <- ceiling(length.out)
./datetime.R- }
./datetime.R: status <- c(!missing(to), !missing(by), !is.null(length.out))
./datetime.R- if(sum(status) != 2)
./datetime.R: stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
./datetime.R- if (missing(by)) {
./datetime.R- from <- unclass(as.POSIXct(from))
./datetime.R- to <- unclass(as.POSIXct(to))
./datetime.R- ## Till (and incl.) 1.6.0 :
./datetime.R- ##- incr <- (to - from)/length.out
./datetime.R: ##- res <- seq.default(from, to, incr)
./datetime.R: res <- seq.default(from, to, length.out = length.out)
./datetime.R: return(structure(res, class = c("POSIXt", "POSIXct")))
./datetime.R- }
./datetime.R-
./datetime.R- if (length(by) != 1) stop("'by' must be of length 1")
./datetime.R- valid <- 0
./datetime.R: if (inherits(by, "difftime")) {
./datetime.R: by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600,
./datetime.R: days = 86400, weeks = 7*86400) * unclass(by)
./datetime.R- } else if(is.character(by)) {
./datetime.R: by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
./datetime.R- if(length(by2) > 2 || length(by2) < 1)
./datetime.R- stop("invalid 'by' string")
./datetime.R: valid <- pmatch(by2[length(by2)],
./datetime.R: c("secs", "mins", "hours", "days", "weeks",
./datetime.R: "months", "years", "DSTdays"))
./datetime.R- if(is.na(valid)) stop("invalid string for 'by'")
./datetime.R- if(valid <= 5) {
./datetime.R: by <- c(1, 60, 3600, 86400, 7*86400)[valid]
./datetime.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./datetime.R- } else
./datetime.R- by <- if(length(by2) == 2) as.integer(by2[1]) else 1
--
./datetime.R- if(is.na(by)) stop("'by' is NA")
./datetime.R-
./datetime.R- if(valid <= 5) {
./datetime.R- from <- unclass(as.POSIXct(from))
./datetime.R- if(!is.null(length.out))
./datetime.R: res <- seq.default(from, by=by, length.out=length.out)
./datetime.R- else {
./datetime.R- to <- unclass(as.POSIXct(to))
./datetime.R- ## defeat test in seq.default
./datetime.R: res <- seq.default(0, to - from, by) + from
./datetime.R- }
./datetime.R: return(structure(res, class=c("POSIXt", "POSIXct")))
./datetime.R- } else { # months or years or DSTdays
./datetime.R- r1 <- as.POSIXlt(from)
./datetime.R- if(valid == 7) {
./datetime.R- if(missing(to)) { # years
./datetime.R: yr <- seq(r1$year, by = by, length = length.out)
./datetime.R- } else {
./datetime.R- to <- as.POSIXlt(to)
./datetime.R: yr <- seq(r1$year, to$year, by)
./datetime.R- }
./datetime.R- r1$year <- yr
./datetime.R- r1$isdst <- -1
./datetime.R- res <- as.POSIXct(r1)
./datetime.R- } else if(valid == 6) { # months
./datetime.R- if(missing(to)) {
./datetime.R: mon <- seq(r1$mon, by = by, length = length.out)
./datetime.R- } else {
./datetime.R- to <- as.POSIXlt(to)
./datetime.R: mon <- seq(r1$mon, 12*(to$year - r1$year) + to$mon, by)
./datetime.R- }
./datetime.R- r1$mon <- mon
./datetime.R- r1$isdst <- -1
./datetime.R- res <- as.POSIXct(r1)
./datetime.R- } else if(valid == 8) { # DSTdays
./datetime.R- if(!missing(to)) {
./datetime.R: ## We might have a short day, so need to over-estimate.
./datetime.R- length.out <- 2 + floor((unclass(as.POSIXct(to)) -
./datetime.R- unclass(as.POSIXct(from)))/86400)
./datetime.R- }
./datetime.R: r1$mday <- seq(r1$mday, by = by, length = length.out)
./datetime.R- r1$isdst <- -1
./datetime.R- res <- as.POSIXct(r1)
./datetime.R- ## now correct if necessary.
--
./datetime.R- return(res)
./datetime.R- }
./datetime.R-}
./datetime.R-
./datetime.R-cut.POSIXt <-
./datetime.R: function (x, breaks, labels = NULL, start.on.monday = TRUE,
./datetime.R: right = FALSE, ...)
./datetime.R-{
./datetime.R: if(!inherits(x, "POSIXt")) stop("'x' must be a date-time object")
./datetime.R- x <- as.POSIXct(x)
./datetime.R-
./datetime.R: if (inherits(breaks, "POSIXt")) {
./datetime.R- breaks <- as.POSIXct(breaks)
./datetime.R- } else if(is.numeric(breaks) && length(breaks) == 1) {
./datetime.R- ## specified number of breaks
./datetime.R- } else if(is.character(breaks) && length(breaks) == 1) {
./datetime.R: by2 <- strsplit(breaks, " ", fixed=TRUE)[[1]]
./datetime.R- if(length(by2) > 2 || length(by2) < 1)
./datetime.R- stop("invalid specification of 'breaks'")
./datetime.R- valid <-
./datetime.R: pmatch(by2[length(by2)],
./datetime.R: c("secs", "mins", "hours", "days", "weeks",
./datetime.R: "months", "years", "DSTdays"))
./datetime.R- if(is.na(valid)) stop("invalid specification of 'breaks'")
./datetime.R: start <- as.POSIXlt(min(x, na.rm=TRUE))
./datetime.R- incr <- 1
./datetime.R- if(valid > 1) { start$sec <- 0; incr <- 59.99 }
./datetime.R- if(valid > 2) { start$min <- 0; incr <- 3600 - 1 }
./datetime.R- if(valid > 3) { start$hour <- 0; incr <- 86400 - 1 }
./datetime.R- if(valid == 5) {
./datetime.R- start$mday <- start$mday - start$wday
./datetime.R- if(start.on.monday)
./datetime.R: start$mday <- start$mday + ifelse(start$wday > 0, 1, -6)
./datetime.R- incr <- 7*86400
./datetime.R- }
./datetime.R- if(valid == 6) { start$mday <- 1; incr <- 31*86400 }
./datetime.R- if(valid == 7) { start$mon <- 0; incr <- 366*86400 }
./datetime.R- if(valid == 8) incr <- 25*3600
./datetime.R- if (length(by2) == 2) incr <- incr * as.integer(by2[1])
./datetime.R: maxx <- max(x, na.rm = TRUE)
./datetime.R: breaks <- seq(start, maxx + incr, breaks)
./datetime.R- breaks <- breaks[1:(1+max(which(breaks < maxx)))]
./datetime.R- } else stop("invalid specification of 'breaks'")
./datetime.R: res <- cut(unclass(x), unclass(breaks), labels = labels,
./datetime.R: right = right, ...)
./datetime.R- if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
./datetime.R- res
./datetime.R-}
./datetime.R-
./datetime.R:julian <- function(x, ...) UseMethod("julian")
./datetime.R-
./datetime.R:julian.POSIXt <- function(x, origin = as.POSIXct("1970-01-01", tz="GMT"), ...)
./datetime.R-{
./datetime.R- if(length(origin) != 1) stop("'origin' must be of length one")
./datetime.R: res <- difftime(as.POSIXct(x), origin, units = "days")
./datetime.R: structure(res, "origin" = origin)
./datetime.R-}
./datetime.R-
./datetime.R:weekdays <- function(x, abbreviate) UseMethod("weekdays")
./datetime.R:weekdays.POSIXt <- function(x, abbreviate = FALSE)
./datetime.R-{
./datetime.R: format(x, ifelse(abbreviate, "%a", "%A"))
./datetime.R-}
./datetime.R-
./datetime.R:months <- function(x, abbreviate) UseMethod("months")
./datetime.R:months.POSIXt <- function(x, abbreviate = FALSE)
./datetime.R-{
./datetime.R: format(x, ifelse(abbreviate, "%b", "%B"))
./datetime.R-}
./datetime.R-
./datetime.R:quarters <- function(x, abbreviate) UseMethod("quarters")
./datetime.R:quarters.POSIXt <- function(x, ...)
./datetime.R-{
./datetime.R- x <- (as.POSIXlt(x)$mon)%/%3
./datetime.R: paste("Q", x+1, sep = "")
./datetime.R-}
./datetime.R-
./datetime.R:trunc.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
./datetime.R-{
./datetime.R- units <- match.arg(units)
./datetime.R- x <- as.POSIXlt(x)
./datetime.R- if(length(x$sec) > 0)
./datetime.R: switch(units,
./datetime.R: "secs" = {x$sec <- trunc(x$sec)},
./datetime.R: "mins" = {x$sec <- 0},
./datetime.R: "hours"= {x$sec <- 0; x$min <- 0},
./datetime.R- "days" = {x$sec <- 0; x$min <- 0; x$hour <- 0; x$isdst <- -1}
./datetime.R- )
./datetime.R- x
./datetime.R-}
./datetime.R-
./datetime.R:round.POSIXt <- function(x, units=c("secs", "mins", "hours", "days"))
./datetime.R-{
./datetime.R: ## this gets the default from the generic, as that has two args.
./datetime.R- if(is.numeric(units) && units == 0.0) units <-"secs"
./datetime.R- units <- match.arg(units)
./datetime.R- x <- as.POSIXct(x)
./datetime.R: x <- x + switch(units,
./datetime.R: "secs" = 0.5, "mins" = 30, "hours"= 1800, "days" = 43200)
./datetime.R: trunc.POSIXt(x, units = units)
./datetime.R-}
./datetime.R-
./datetime.R-# ---- additions in 1.5.0 -----
./datetime.R-
./datetime.R:"[.POSIXlt" <- function(x, ..., drop = TRUE)
./datetime.R-{
./datetime.R: val <- lapply(x, "[", ..., drop = drop)
./datetime.R- attributes(val) <- attributes(x) # need to preserve timezones
./datetime.R- val
./datetime.R-}
./datetime.R-
./datetime.R:"[<-.POSIXlt" <- function(x, i, value)
./datetime.R-{
./datetime.R- if(!as.logical(length(value))) return(x)
./datetime.R- value <- as.POSIXlt(value)
--
./datetime.R- for(n in names(x)) x[[n]][i] <- value[[n]]
./datetime.R- class(x) <- cl
./datetime.R- x
./datetime.R-}
./datetime.R-
./datetime.R:as.data.frame.POSIXlt <- function(x, row.names = NULL, optional = FALSE)
./datetime.R-{
./datetime.R: value <- as.data.frame.POSIXct(as.POSIXct(x), row.names, optional)
./datetime.R- if (!optional)
./datetime.R- names(value) <- deparse(substitute(x))[[1]]
./datetime.R- value
./datetime.R-}
./datetime.R-
./datetime.R-# ---- additions in 1.8.0 -----
./datetime.R-
./datetime.R:rep.POSIXct <- function(x, times, ...)
./datetime.R-{
./datetime.R- y <- NextMethod()
./datetime.R: structure(y, class=c("POSIXt", "POSIXct"), tzone = attr(x, "tzone"))
./datetime.R-}
./datetime.R-
./datetime.R:rep.POSIXlt <- function(x, times, ...)
./datetime.R-{
./datetime.R: y <- if(missing(times)) lapply(x, rep, ...)
./datetime.R: else lapply(x, rep, times=times, ...)
./datetime.R- attributes(y) <- attributes(x)
./datetime.R- y
./datetime.R-}
./datetime.R-
./datetime.R:diff.POSIXt <- function (x, lag = 1, differences = 1, ...)
./datetime.R-{
./datetime.R- ismat <- is.matrix(x)
./datetime.R- xlen <- if (ismat) dim(x)[1] else length(x)
./datetime.R- if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
./datetime.R- stop("'lag' and 'differences' must be integers >= 1")
./datetime.R- if (lag * differences >= xlen)
./datetime.R: return(structure(numeric(0), class="difftime", units="secs"))
./datetime.R- r <- x
./datetime.R- i1 <- -1:-lag
./datetime.R: if (ismat) for (i in 1:differences) r <- r[i1, , drop = FALSE] -
./datetime.R: r[-nrow(r):-(nrow(r) - lag + 1), , drop = FALSE]
./datetime.R- else for (i in 1:differences)
./datetime.R- r <- r[i1] - r[-length(r):-(length(r) - lag + 1)]
./datetime.R- r
--
./dcf.R:read.dcf <- function(file, fields = NULL)
./dcf.R-{
./dcf.R- if(is.character(file)){
./dcf.R: file <- file(file, "r")
./dcf.R- on.exit(close(file))
./dcf.R- }
./dcf.R: if(!inherits(file, "connection"))
./dcf.R- stop("'file' must be a character string or connection")
./dcf.R: .Internal(readDCF(file, fields))
./dcf.R-}
./dcf.R-
./dcf.R-write.dcf <-
./dcf.R:function(x, file = "", append = FALSE,
./dcf.R: indent = 0.1 * getOption("width"),
./dcf.R- width = 0.9 * getOption("width"))
./dcf.R-{
./dcf.R- if(!is.data.frame(x))
--
./dcf.R- mode(x) <- "character"
./dcf.R-
./dcf.R- if(file == "")
./dcf.R- file <- stdout()
./dcf.R- else if(is.character(file)) {
./dcf.R: file <- file(file, ifelse(append, "a", "w"))
./dcf.R- on.exit(close(file))
./dcf.R- }
./dcf.R: if(!inherits(file, "connection"))
./dcf.R- stop("'file' must be a character string or connection")
./dcf.R-
./dcf.R- nr <- nrow(x)
./dcf.R- nc <- ncol(x)
./dcf.R-
./dcf.R- eor <- character(nr * nc)
./dcf.R: eor[seq(1, nr - 1) * nc] <- "\n" # newline for end of record
./dcf.R-
./dcf.R: writeLines(paste(formatDL(rep.int(colnames(x), nr), c(t(x)), style =
./dcf.R: "list", width = width, indent = indent),
./dcf.R: eor, sep = ""),
./dcf.R- file)
./dcf.R-}
--
./delay.R:delayedAssign <- function(x, value, eval.env=parent.frame(1), assign.env=parent.frame(1))
./delay.R: .Internal(delayedAssign(x, substitute(value), eval.env, assign.env))
--
./det.R-## no longer used.
./det.R-## S-plus' Matrix pkg has arg. "logarithm = TRUE" and returns list
./det.R-## (which is necessary for keeping the sign when taking log ..)
./det.R-## S-plus v 6.x has incorporated the Matrix pkg det as determinant
./det.R-
./det.R:det = function(x, ...)
./det.R-{
./det.R: z = determinant(x, logarithm = TRUE, ...)
./det.R- c(z$sign * exp(z$modulus))
./det.R-}
./det.R-
./det.R:determinant = function(x, logarithm = TRUE, ...) UseMethod("determinant")
./det.R-
./det.R:determinant.matrix = function(x, logarithm = TRUE, ...)
./det.R-{
./det.R- if ((n <- ncol(x)) != nrow(x))
./det.R- stop("'x' must be a square matrix")
./det.R- if (n < 1)
./det.R: return(list(modulus = double(0), sign = as.integer(1),
./det.R- logarithm = logarithm))
./det.R- if (is.complex(x))
./det.R- stop("determinant not currently defined for complex matrices")
./det.R- storage.mode(x) = "double"
./det.R: .Call("det_ge_real", x, logarithm, PACKAGE = "base")
./det.R-}
--
./diag.R:diag <- function(x = 1, nrow, ncol = n)
./diag.R-{
./diag.R- if (is.matrix(x) && nargs() == 1) {
./diag.R- if((m <- min(dim(x))) == 0)
./diag.R- return(numeric(0))
./diag.R-
./diag.R- y <- c(x)[1 + 0:(m - 1) * (dim(x)[1] + 1)]
./diag.R- nms <- dimnames(x)
./diag.R: if (is.list(nms) && !any(sapply(nms, is.null)) &&
./diag.R- all((nm <- nms[[1]][1:m]) == nms[[2]][1:m]))
./diag.R- names(y) <- nm
./diag.R- return(y)
./diag.R- }
./diag.R- if(is.array(x) && length(dim(x)) != 1)
./diag.R: stop("first argument is array, but not matrix.")
./diag.R-
./diag.R- if(missing(x))
./diag.R- n <- nrow
--
./diag.R- }
./diag.R- else n <- length(x)
./diag.R- if(!missing(nrow))
./diag.R- n <- nrow
./diag.R- p <- ncol
./diag.R: y <- array(0, c(n, p))
./diag.R: if((m <- min(n, p)) > 0) y[1 + 0:(m - 1) * (n + 1)] <- x
./diag.R- y
./diag.R-}
./diag.R-
./diag.R:"diag<-" <- function(x, value)
./diag.R-{
./diag.R- dx <- dim(x)
./diag.R- if(length(dx) != 2 || prod(dx) != length(x))
./diag.R- stop("only matrix diagonals can be replaced")
./diag.R- i <- seq(length=min(dx))
./diag.R- if(length(value) != 1 && length(value) != length(i))
./diag.R- stop("replacement diagonal has wrong length")
./diag.R: if(length(i) > 0) x[cbind(i, i)] <- value
./diag.R- x
./diag.R-}
--
./diff.R:diff <- function(x, ...) UseMethod("diff")
./diff.R-
./diff.R:diff.default <- function(x, lag = 1, differences = 1, ...)
./diff.R-{
./diff.R- ismat <- is.matrix(x)
./diff.R- xlen <- if(ismat) dim(x)[1] else length(x)
--
./diff.R- return(x[0]) # empty of proper mode
./diff.R- r <- unclass(x) # don't want class-specific subset methods
./diff.R- i1 <- -1:-lag
./diff.R- if (ismat)
./diff.R- for (i in 1:differences)
./diff.R: r <- r[i1, , drop = FALSE] -
./diff.R: r[-nrow(r):-(nrow(r)-lag+1), , drop = FALSE]
./diff.R- else
./diff.R- for (i in 1:differences)
./diff.R- r <- r[i1] - r[-length(r):-(length(r)-lag+1)]
--
./dput.R:dput <- function(x, file = "", control = "showAttributes")
./dput.R-{
./dput.R- if(is.character(file))
./dput.R- if(nchar(file) > 0) {
./dput.R: file <- file(file, "wt")
./dput.R- on.exit(close(file))
./dput.R- } else file <- stdout()
./dput.R- opts <- .deparseOpts(control)
./dput.R: .Internal(dput(x, file, opts))
./dput.R-}
./dput.R-
./dput.R-dget <- function(file)
--
./dump.R:dump <- function (list, file = "dumpdata.R", append = FALSE,
./dump.R: control = "all", envir = parent.frame(),
./dump.R- evaluate = TRUE)
./dump.R-{
./dump.R- digits <- options("digits")
./dump.R- on.exit(options(digits))
./dump.R- options(digits = 12)
./dump.R- if(is.character(file))
./dump.R- if(nchar(file) > 0) {
./dump.R: file <- file(file, ifelse(append, "a", "w"))
./dump.R: on.exit(close(file), add = TRUE)
./dump.R- } else file <- stdout()
./dump.R- opts <- .deparseOpts(control)
./dump.R: .Internal(dump(list, file, envir, opts, evaluate))
./dump.R-}
./dump.R-
--
./duplicated.R:duplicated <- function(x, incomparables = FALSE, ...) UseMethod("duplicated")
./duplicated.R-
./duplicated.R:duplicated.default <- function(x, incomparables = FALSE, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- .Internal(duplicated(x))
./duplicated.R-}
./duplicated.R-
./duplicated.R:duplicated.data.frame <- function(x, incomparables = FALSE, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R: duplicated(do.call("paste", c(x, sep="\r")))
./duplicated.R-}
./duplicated.R-
./duplicated.R-duplicated.matrix <- duplicated.array <-
./duplicated.R: function(x, incomparables = FALSE , MARGIN = 1, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- ndim <- length(dim(x))
./duplicated.R- if (length(MARGIN) > ndim || any(MARGIN > ndim))
./duplicated.R: stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
./duplicated.R: temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
./duplicated.R- res <- duplicated(as.vector(temp))
./duplicated.R- dim(res) <- dim(temp)
./duplicated.R- dimnames(res) <- dimnames(temp)
./duplicated.R- res
./duplicated.R-}
./duplicated.R-
./duplicated.R:unique <- function(x, incomparables = FALSE, ...) UseMethod("unique")
./duplicated.R-
./duplicated.R-
./duplicated.R:## NB unique.default is used by factor to avoid unique.matrix,
./duplicated.R-## so it needs to handle some other cases.
./duplicated.R:unique.default <- function(x, incomparables = FALSE, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- z <- .Internal(unique(x))
./duplicated.R- if(is.factor(x))
./duplicated.R: factor(z, levels = seq(len=nlevels(x)), labels = levels(x),
./duplicated.R- ordered = is.ordered(x))
./duplicated.R: else if(inherits(x, "POSIXct") || inherits(x, "Date"))
./duplicated.R: structure(z, class=class(x))
./duplicated.R- else z
./duplicated.R-}
./duplicated.R-
./duplicated.R:unique.data.frame <- function(x, incomparables = FALSE, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R: x[!duplicated(x), , drop = FALSE]
./duplicated.R-}
./duplicated.R-
./duplicated.R-unique.matrix <- unique.array <-
./duplicated.R: function(x, incomparables = FALSE , MARGIN = 1, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- ndim <- length(dim(x))
./duplicated.R- if (length(MARGIN) > 1 || any(MARGIN > ndim))
./duplicated.R: stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
./duplicated.R: temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
./duplicated.R: args <- rep(alist(a=), ndim)
./duplicated.R- names(args) <- NULL
./duplicated.R- args[[MARGIN]] <- !duplicated(as.vector(temp))
./duplicated.R: do.call("[", c(list(x=x), args, list(drop=FALSE)))
./duplicated.R-}
--
./dynload.R:dyn.load <- function(x, local=TRUE, now=TRUE)
./dynload.R: .Internal(dyn.load(x, as.logical(local), as.logical(now)))
./dynload.R-
./dynload.R-dyn.unload <- function(x)
./dynload.R- .Internal(dyn.unload(x))
./dynload.R-
./dynload.R:getNativeSymbolInfo <- function(name, PACKAGE)
./dynload.R-{
./dynload.R- if(missing(PACKAGE)) PACKAGE <- ""
./dynload.R-
./dynload.R- if(is.character(PACKAGE))
./dynload.R- pkgName <- PACKAGE
./dynload.R: else if(inherits(PACKAGE, "DLLInfo")) {
./dynload.R- pkgName <- PACKAGE$path
./dynload.R- PACKAGE <- PACKAGE$info
./dynload.R: } else if(inherits(PACKAGE, "DLLInfoReference")) {
./dynload.R- pkgName <- character()
./dynload.R- } else
./dynload.R: stop("must pass a package name, DLLInfo or DllInfoReference object")
./dynload.R-
./dynload.R: v <- .Call("R_getSymbolInfo", as.character(name), PACKAGE,
./dynload.R- PACKAGE = "base")
./dynload.R- if(is.null(v)) {
./dynload.R: msg <- paste("no such symbol", name)
./dynload.R- if(length(pkgName) && nchar(pkgName))
./dynload.R: msg <- paste(msg, "in package", pkgName)
./dynload.R- stop(msg)
./dynload.R- }
./dynload.R: names(v) <- c("name", "address", "package", "numParameters")[1:length(v)]
./dynload.R- v
./dynload.R-}
./dynload.R-
./dynload.R-getLoadedDLLs <- function()
./dynload.R-{
./dynload.R: els <- .Call("R_getDllTable", PACKAGE = "base")
./dynload.R: names(els) = sapply(els, function(x) x[["name"]])
./dynload.R- els
./dynload.R-}
./dynload.R-
--
./dynload.R-
./dynload.R-
./dynload.R-getDLLRegisteredRoutines.character <- function(dll)
./dynload.R-{
./dynload.R- dlls <- getLoadedDLLs()
./dynload.R: w <- sapply(dlls, function(x) x$name == dll || x$path == dll)
./dynload.R-
./dynload.R- if(!any(w))
./dynload.R: stop("No DLL currently loaded with name or path ", dll)
./dynload.R-
./dynload.R- dll <- which(w)[1]
./dynload.R- if(sum(w) > 1)
./dynload.R: warning(gettextf("multiple DLLs match '%s'. Using '%s'",
./dynload.R: dll, dll$path), domain = NA)
./dynload.R-
./dynload.R- getDLLRegisteredRoutines(dlls[[dll]])
./dynload.R-}
./dynload.R-
./dynload.R-
./dynload.R-getDLLRegisteredRoutines.DLLInfo <- function(dll)
./dynload.R-{
./dynload.R- ## Provide methods for the different types.
./dynload.R: if(!inherits(dll, "DLLInfo"))
./dynload.R- stop("must specify DLL via a DLLInfo object. See getLoadedDLLs()")
./dynload.R-
./dynload.R- info <- dll$info
./dynload.R: els <- .Call("R_getRegisteredRoutines", info, PACKAGE = "base")
./dynload.R- ## Put names on the elements by getting the names from each element.
./dynload.R: els <- lapply(els, function(x) {
./dynload.R- if(length(x))
./dynload.R: names(x) <- sapply(x, function(z) z$name)
./dynload.R- x
./dynload.R- })
./dynload.R- class(els) <- "DLLRegisteredRoutines"
./dynload.R- els
./dynload.R-}
./dynload.R-
./dynload.R-
./dynload.R-print.NativeRoutineList <-
./dynload.R:function(x, ...)
./dynload.R-{
./dynload.R: m <- data.frame(numParameters = sapply(x, function(x) x$numParameters),
./dynload.R: row.names = sapply(x, function(x) x$name))
./dynload.R: print(m, ...)
./dynload.R- invisible(x)
./dynload.R-}
./dynload.R-
--
./dynload.R- # This is arranged as a ragged data frame. It may be confusing
./dynload.R- # if one reads it row-wise as the columns are related in pairs
./dynload.R- # but not across pairs. We might leave it as a list of lists
./dynload.R- # but that spans a great deal of vertical space and involves
./dynload.R- # a lot of scrolling for the user.
./dynload.R:function(x, ...)
./dynload.R-{
./dynload.R- # Create a data frame with as many rows as the maximum number
./dynload.R- # of routines in any category. Then fill the column with ""
./dynload.R- # and then the actual entries.
./dynload.R-
./dynload.R: n <- max(sapply(x, length))
./dynload.R- d <- list()
./dynload.R: sapply(names(x),
./dynload.R- function(id) {
./dynload.R: d[[id]] <<- rep("", n)
./dynload.R: names <- sapply(x[[id]], function(x) x$name)
./dynload.R- if(length(names))
./dynload.R- d[[id]][1:length(names)] <<- names
./dynload.R-
./dynload.R: d[[paste(id, "numParameters")]] <<- rep("", n)
./dynload.R: names <- sapply(x[[id]], function(x) x$numParameters)
./dynload.R- if(length(names))
./dynload.R: d[[paste(id, "numParameters")]][1:length(names)] <<- names
./dynload.R- })
./dynload.R: print(as.data.frame(d), ...)
./dynload.R- invisible(x)
./dynload.R-}
./dynload.R-
./dynload.R-
./dynload.R-getCallingDLL <-
./dynload.R:function(f = sys.function(1), doStop = FALSE)
./dynload.R-{
./dynload.R- e <- environment(f)
./dynload.R-
./dynload.R- if(!isNamespace(e)) {
./dynload.R- if(doStop)
./dynload.R: stop("function is not in a namespace, so cannot locate associated DLL")
./dynload.R- else
./dynload.R- return(NULL)
./dynload.R- }
./dynload.R-
./dynload.R- # Please feel free to replace with a more encapsulated way to do this.
./dynload.R: if(exists("DLLs", envir = e$".__NAMESPACE__.") && length(e$".__NAMESPACE__."$DLLs))
./dynload.R- return(e$".__NAMESPACE__."$DLLs[[1]])
./dynload.R- else {
./dynload.R- if(doStop)
./dynload.R: stop("looking for DLL for native routine call, but no DLLs in namespace of call")
./dynload.R- else
./dynload.R- NULL
./dynload.R- }
./dynload.R- NULL
./dynload.R-}
./dynload.R-
./dynload.R:print.DLLInfo <- function(x, ...)
./dynload.R-{
./dynload.R: tmp <- as.data.frame.list(x[c("name", "path", "dynamicLookup")])
./dynload.R: names(tmp) <- c("DLL name", "Filename", "Dynamic lookup")
./dynload.R: write.dcf(tmp, ...)
./dynload.R- invisible(x)
./dynload.R-}
./dynload.R-
./dynload.R:print.DLLInfoList <- function(x, ...)
./dynload.R-{
./dynload.R- if(length(x)) {
./dynload.R: m <- data.frame(Filename = sapply(x, function(x) x[["path"]]),
./dynload.R- "Dynamic Lookup" =
./dynload.R: sapply(x, function(x) x[["dynamicLookup"]]))
./dynload.R: print(m, ...)
./dynload.R- }
./dynload.R- invisible(x)
./dynload.R-}
--
./eapply.R:eapply <- function (env, FUN, ..., all.names = FALSE)
./eapply.R-{
./eapply.R- FUN <- match.fun(FUN)
./eapply.R: .Internal(eapply(env, FUN, all.names))
./eapply.R-}
--
./eigen.R:eigen <- function(x, symmetric, only.values = FALSE, EISPACK = FALSE)
./eigen.R-{
./eigen.R- x <- as.matrix(x)
./eigen.R: dimnames(x) <- list(NULL, NULL) # or they appear on eigenvectors
./eigen.R- n <- nrow(x)
./eigen.R- if (!n) stop("0 x 0 matrix")
./eigen.R- if (n != ncol(x)) stop("non-square matrix in 'eigen'")
--
./eigen.R-
./eigen.R- if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./eigen.R-
./eigen.R- if(complex.x) {
./eigen.R- if(missing(symmetric)) {
./eigen.R: test <- all.equal.numeric(x, Conj(t(x)), 100*.Machine$double.eps)
./eigen.R- symmetric <- is.logical(test) && test
./eigen.R- }
./eigen.R- }
./eigen.R- else if(is.numeric(x)) {
./eigen.R- storage.mode(x) <- "double"
./eigen.R- if(missing(symmetric)) {
./eigen.R: test <- all.equal.numeric(x, t(x), 100*.Machine$double.eps)
./eigen.R- symmetric <- is.logical(test) && test
./eigen.R- }
./eigen.R- }
./eigen.R- else stop("numeric or complex values required in 'eigen'")
./eigen.R- if (!EISPACK) {
./eigen.R- if (symmetric) {
./eigen.R- z <- if(!complex.x)
./eigen.R: .Call("La_rs", x, only.values, "dsyevr", PACKAGE = "base")
./eigen.R- else
./eigen.R: .Call("La_rs_cmplx", x, only.values, PACKAGE = "base")
./eigen.R- ord <- rev(seq(along = z$values))
./eigen.R- } else {
./eigen.R- z <- if(!complex.x)
./eigen.R: .Call("La_rg", x, only.values, PACKAGE = "base")
./eigen.R- else
./eigen.R: .Call("La_rg_cmplx", x, only.values, PACKAGE = "base")
./eigen.R: ord <- sort.list(Mod(z$values), decreasing = TRUE)
./eigen.R- }
./eigen.R: return(list(values = z$values[ord],
./eigen.R: vectors = if (!only.values) z$vectors[, ord, drop = FALSE]))
./eigen.R- }
./eigen.R-
./eigen.R- dbl.n <- double(n)
./eigen.R- if(symmetric) {##--> real values
./eigen.R- if(complex.x) {
./eigen.R- xr <- Re(x)
./eigen.R- xi <- Im(x)
./eigen.R: z <- .Fortran("ch",
./eigen.R: n,
./eigen.R: n,
./eigen.R: xr,
./eigen.R: xi,
./eigen.R: values = dbl.n,
./eigen.R: !only.values,
./eigen.R: vectors = xr,
./eigen.R: ivectors = xi,
./eigen.R: dbl.n,
./eigen.R: dbl.n,
./eigen.R: double(2*n),
./eigen.R: ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'ch' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- if(!only.values)
./eigen.R: z$vectors <- matrix(complex(re=z$vectors,
./eigen.R: im=z$ivectors), nc=n)
./eigen.R- }
./eigen.R- else {
./eigen.R: z <- .Fortran("rs",
./eigen.R: n,
./eigen.R: n,
./eigen.R: x,
./eigen.R: values = dbl.n,
./eigen.R: !only.values,
./eigen.R: vectors = x,
./eigen.R: dbl.n,
./eigen.R: dbl.n,
./eigen.R: ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'rs' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- }
./eigen.R: ord <- sort.list(z$values, decreasing = TRUE)
./eigen.R- }
./eigen.R- else {##- Asymmetric :
./eigen.R- if(complex.x) {
./eigen.R- xr <- Re(x)
./eigen.R- xi <- Im(x)
./eigen.R: z <- .Fortran("cg",
./eigen.R: n,
./eigen.R: n,
./eigen.R: xr,
./eigen.R: xi,
./eigen.R: values = dbl.n,
./eigen.R: ivalues = dbl.n,
./eigen.R: !only.values,
./eigen.R: vectors = xr,
./eigen.R: ivectors = xi,
./eigen.R: dbl.n,
./eigen.R: dbl.n,
./eigen.R: dbl.n,
./eigen.R: ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'cg' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R: z$values <- complex(re=z$values,im=z$ivalues)
./eigen.R- if(!only.values)
./eigen.R: z$vectors <- matrix(complex(re=z$vectors,
./eigen.R: im=z$ivectors), nc=n)
./eigen.R- }
./eigen.R- else {
./eigen.R: z <- .Fortran("rg",
./eigen.R: n,
./eigen.R: n,
./eigen.R: x,
./eigen.R: values = dbl.n,
./eigen.R: ivalues = dbl.n,
./eigen.R: !only.values,
./eigen.R: vectors = x,
./eigen.R: integer(n),
./eigen.R: dbl.n,
./eigen.R: ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'rg' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- ind <- z$ivalues > 0
./eigen.R- if(any(ind)) {#- have complex (conjugated) values
./eigen.R- ind <- seq(n)[ind]
./eigen.R: z$values <- complex(re=z$values,im=z$ivalues)
./eigen.R- if(!only.values) {
./eigen.R: z$vectors[, ind] <- complex(re=z$vectors[,ind],
./eigen.R: im=z$vectors[,ind+1])
./eigen.R: z$vectors[, ind+1] <- Conj(z$vectors[,ind])
./eigen.R- }
./eigen.R- }
./eigen.R- }
./eigen.R: ord <- sort.list(Mod(z$values), decreasing = TRUE)
./eigen.R- }
./eigen.R: list(values = z$values[ord],
./eigen.R: vectors = if(!only.values) z$vectors[,ord, drop = FALSE])
./eigen.R-}
--
./eval.R-.GlobalEnv <- environment()
./eval.R-parent.frame <- function(n = 1) .Internal(parent.frame(n))
./eval.R-
./eval.R-eval <-
./eval.R: function(expr, envir = parent.frame(),
./eval.R- enclos = if(is.list(envir) || is.pairlist(envir))
./eval.R- parent.frame())
./eval.R: .Internal(eval(expr, envir,enclos))
./eval.R-
./eval.R:eval.parent <- function(expr, n = 1){
./eval.R- p <- parent.frame(n + 1)
./eval.R: eval(expr , p)
./eval.R-}
./eval.R-
./eval.R-evalq <-
./eval.R: function (expr, envir, enclos)
./eval.R: eval.parent(substitute(eval(quote(expr), envir, enclos)))
./eval.R-
./eval.R:new.env <- function (hash=FALSE, parent=parent.frame())
./eval.R: .Internal(new.env(hash, parent))
./eval.R-
./eval.R-parent.env <- function(env)
./eval.R- .Internal(parent.env(env))
./eval.R-
./eval.R:"parent.env<-" <- function(env, value)
./eval.R: .Internal("parent.env<-"(env, value))
./eval.R-
./eval.R-local <-
./eval.R: function (expr, envir = new.env())
./eval.R: eval.parent(substitute(eval(quote(expr), envir)))
./eval.R-
./eval.R-Recall <- function(...) .Internal(Recall(...))
./eval.R-
./eval.R:with <- function(data, expr, ...) UseMethod("with")
./eval.R-
./eval.R:with.default <- function(data, expr, ...)
./eval.R: eval(substitute(expr), data, enclos=parent.frame())
./eval.R-
./eval.R-force <- function(x) x
--
./exists.R-exists <-
./exists.R: function (x, where = -1,
./exists.R: envir = if(missing(frame)) as.environment(where) else sys.frame(frame),
./exists.R: frame, mode = "any", inherits = TRUE)
./exists.R: .Internal(exists(x, envir, mode, inherits))
--
./expand.grid.R- if(! nargs) return(as.data.frame(list()))
./expand.grid.R- if(nargs == 1 && is.list(a1 <- args[[1]]))
./expand.grid.R- nargs <- length(args <- a1)
./expand.grid.R- if(nargs == 0) return(as.data.frame(list()))
./expand.grid.R- cargs <- args
./expand.grid.R: nmc <- paste("Var", 1:nargs, sep="")
./expand.grid.R- nm <- names(args)
./expand.grid.R- if(is.null(nm)) nm <- nmc
./expand.grid.R- if(any(ng0 <- nchar(nm) > 0)) nmc[ng0] <- nm[ng0]
./expand.grid.R- names(cargs) <- nmc
./expand.grid.R- rep.fac <- 1
./expand.grid.R: d <- sapply(args, length)
./expand.grid.R: dn <- vector("list", nargs)
./expand.grid.R- names(dn) <- nmc
./expand.grid.R- orep <- prod(d)
./expand.grid.R- for(i in 1:nargs) {
./expand.grid.R- x <- args[[i]]
./expand.grid.R: dn[[i]] <- paste(nmc[i], "=", if(is.numeric(x)) format(x) else x,
./expand.grid.R- sep = "")
./expand.grid.R- nx <- length(x)
./expand.grid.R- orep <- orep/nx
./expand.grid.R: x <- rep.int(rep.int(x, rep.int(rep.fac, nx)), orep)
./expand.grid.R- ## avoid sorting the levels of character variates
./expand.grid.R: if(!is.factor(x) && is.character(x)) x <- factor(x, levels = unique(x))
./expand.grid.R- cargs[[i]] <- x
./expand.grid.R- rep.fac <- rep.fac * nx
./expand.grid.R- }
./expand.grid.R: res <- do.call("cbind.data.frame", cargs)
./expand.grid.R: attr(res, "out.attrs") <- list(dim=d, dimnames=dn)
./expand.grid.R- res
./expand.grid.R-}
--
./factor.R:factor <- function (x, levels = sort(unique.default(x), na.last = TRUE),
./factor.R: labels=levels, exclude = NA, ordered = is.ordered(x))
./factor.R-{
./factor.R- if(is.null(x))
./factor.R- x <- list()
./factor.R: exclude <- as.vector(exclude, typeof(x))
./factor.R: levels <- levels[is.na(match(levels, exclude))]
./factor.R: f <- match(x, levels)
./factor.R- names(f) <- names(x)
./factor.R- nl <- length(labels)
./factor.R: attr(f, "levels") <-
./factor.R- if (nl == length(levels))
./factor.R- as.character(labels)
./factor.R- else if(nl == 1)
./factor.R: paste(labels, seq(along = levels), sep = "")
./factor.R- else
./factor.R: stop(gettextf("invalid labels; length %d should be 1 or %d",
./factor.R: nl, length(levels)), domain = NA)
./factor.R: class(f) <- c(if(ordered)"ordered", "factor")
./factor.R- f
./factor.R-}
./factor.R-
./factor.R:is.factor <- function(x) inherits(x, "factor")
./factor.R-as.factor <- function(x) if (is.factor(x)) x else factor(x)
./factor.R-
./factor.R-## Help old S users:
./factor.R-category <- function(...) .Defunct()
./factor.R-
./factor.R:levels <- function(x) attr(x, "levels")
./factor.R-nlevels <- function(x) length(levels(x))
./factor.R-
./factor.R:"levels<-" <- function(x, value) UseMethod("levels<-")
./factor.R-
./factor.R:"levels<-.default" <- function(x, value)
./factor.R-{
./factor.R: attr(x, "levels") <- value
./factor.R- x
./factor.R-}
./factor.R-
./factor.R:"levels<-.factor" <- function(x, value)
./factor.R-{
./factor.R- xlevs <- levels(x)
./factor.R- if (is.list(value)) {
./factor.R: nlevs <- rep.int(names(value), lapply(value, length))
./factor.R- value <- unlist(value)
./factor.R: m <- match(value, xlevs, nomatch=0)
./factor.R- xlevs[m] <- nlevs[m > 0]
./factor.R- } else {
./factor.R- if (length(xlevs) > length(value))
./factor.R- stop("number of levels differs")
./factor.R- nlevs <- xlevs <- as.character(value)
./factor.R- }
./factor.R: factor(xlevs[x], levels = unique(nlevs))
./factor.R-}
./factor.R-
./factor.R:as.vector.factor <- function(x, mode="any")
./factor.R-{
./factor.R- if(mode== "any" || mode== "character" || mode== "logical" || mode== "list")
./factor.R: as.vector(levels(x)[x], mode)
./factor.R- else
./factor.R: as.vector(unclass(x), mode)
./factor.R-}
./factor.R-
./factor.R:as.character.factor <- function(x,...)
./factor.R-{
./factor.R- cx <- levels(x)[x]
./factor.R- if("NA" %in% levels(x)) cx[is.na(x)] <- ""
./factor.R- cx
./factor.R-}
./factor.R-
./factor.R-## for `factor' *and* `ordered' :
./factor.R:print.factor <- function (x, quote = FALSE, max.levels = NULL,
./factor.R: width = getOption("width"), ...)
./factor.R-{
./factor.R- ord <- is.ordered(x)
./factor.R- if (length(x) <= 0)
./factor.R: cat(if(ord)"ordered" else "factor","(0)\n",sep="")
./factor.R- else
./factor.R: print(as.character(x), quote = quote, ...)
./factor.R- maxl <- if(is.null(max.levels)) TRUE else max.levels
./factor.R- if (maxl) {
./factor.R: n <- length(lev <- encodeString(levels(x), quote=ifelse(quote, '"', '')))
./factor.R- colsep <- if(ord) " < " else " "
./factor.R- T0 <- "Levels: "
./factor.R- if(is.logical(maxl))
./factor.R- maxl <- { ## smart default
./factor.R: width <- width - (nchar(T0, type="w") + 3 + 1 + 3)
./factor.R: # 3='...', 3=#lev, 1=extra
./factor.R: lenl <- cumsum(nchar(lev, type="w") + nchar(colsep, type="w"))
./factor.R- if(n <= 1 || lenl[n] <= width) n
./factor.R: else max(1, which(lenl > width)[1] - 1)
./factor.R- }
./factor.R- drop <- n > maxl
./factor.R: cat(if(drop)paste(format(n),""), T0,
./factor.R: paste(if(drop)c(lev[1:max(1,maxl-1)],"...",if(maxl > 1) lev[n])
./factor.R: else lev, collapse= colsep), "\n", sep="")
./factor.R- }
./factor.R- invisible(x)
./factor.R-}
./factor.R-
./factor.R-
./factor.R:Math.factor <- function(x, ...) {
./factor.R: stop(.Generic, " not meaningful for factors")
./factor.R-}
./factor.R:Summary.factor <- function(x, ...) {
./factor.R: stop(.Generic, " not meaningful for factors")
./factor.R-}
./factor.R:Ops.factor <- function(e1, e2)
./factor.R-{
./factor.R: ok <- switch(.Generic, "=="=, "!="=TRUE, FALSE)
./factor.R- if(!ok) {
./factor.R: warning(.Generic, " not meaningful for factors")
./factor.R: return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
./factor.R- }
./factor.R- nas <- is.na(e1) | is.na(e2)
./factor.R- if (nchar(.Method[1])) {
--
./factor.R- value <- NextMethod(.Generic)
./factor.R- value[nas] <- NA
./factor.R- value
./factor.R-}
./factor.R-
./factor.R:"[.factor" <- function(x, i, drop=FALSE)
./factor.R-{
./factor.R- y <- NextMethod("[")
./factor.R: attr(y,"contrasts")<-attr(x,"contrasts")
./factor.R- ## NB factor has levels before class in attribute list (PR#6799)
./factor.R: attr(y,"levels")<-attr(x,"levels")
./factor.R- class(y) <- oldClass(x)
./factor.R- if ( drop ) factor(y) else y
./factor.R-}
./factor.R-
./factor.R:"[<-.factor" <- function(x, i, value)
./factor.R-{
./factor.R- lx <- levels(x)
./factor.R- cx <- oldClass(x)
./factor.R-# nas <- is.na(x) # unused
./factor.R- if (is.factor(value))
./factor.R- value <- levels(value)[value]
./factor.R: m <- match(value, lx)
./factor.R- if (any(is.na(m) & !is.na(value)))
./factor.R: warning("invalid factor level, NAs generated")
./factor.R- class(x) <- NULL
./factor.R- if (missing(i))
./factor.R- x[] <- m
./factor.R- else
./factor.R- x[i] <- m
./factor.R: attr(x,"levels") <- lx
./factor.R- class(x) <- cx
./factor.R- x
./factor.R-}
./factor.R-
./factor.R-## ordered factors ...
./factor.R-
./factor.R:ordered <- function(x, ...) factor(x, ..., ordered=TRUE)
./factor.R-
./factor.R:is.ordered <- function(x) inherits(x, "ordered")
./factor.R-as.ordered <- function(x) if(is.ordered(x)) x else ordered(x)
./factor.R-
./factor.R-Ops.ordered <-
./factor.R:function (e1, e2)
./factor.R-{
./factor.R: ok <- switch(.Generic,
./factor.R: "<" = , ">" = , "<=" = , ">=" = ,"=="=, "!=" =TRUE,
./factor.R- FALSE)
./factor.R- if(!ok) {
./factor.R: warning(sprintf("'%s' is not meaningful for ordered factors",
./factor.R- .Generic))
./factor.R: return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
./factor.R- }
./factor.R: if (.Generic %in% c("==", "!="))
./factor.R: return(NextMethod(.Generic)) ##not S-PLUS compatible, but saner
./factor.R- nas <- is.na(e1) | is.na(e2)
./factor.R- ord1 <- FALSE
./factor.R- ord2 <- FALSE
--
./factor.R- ord2 <- TRUE
./factor.R- }
./factor.R- if (all(nchar(.Method)) && (length(l1) != length(l2) || !all(l2 == l1)))
./factor.R- stop("level sets of factors are different")
./factor.R- if (ord1 && ord2) {
./factor.R: e1 <- as.integer(e1) # was codes, but same thing for ordered factor.
./factor.R- e2 <- as.integer(e2)
./factor.R- }
./factor.R- else if (!ord1) {
./factor.R: e1 <- match(e1, l2)
./factor.R- e2 <- as.integer(e2)
./factor.R- }
./factor.R- else if (!ord2) {
./factor.R: e2 <- match(e2, l1)
./factor.R- e1 <- as.integer(e1)
./factor.R- }
./factor.R: value <- get(.Generic, mode = "function")(e1, e2)
./factor.R- value[nas] <- NA
./factor.R- value
./factor.R-}
./factor.R-
./factor.R:"is.na<-.factor" <- function(x, value)
./factor.R-{
./factor.R- lx <- levels(x)
./factor.R- cx <- oldClass(x)
./factor.R- class(x) <- NULL
./factor.R- x[value] <- NA
./factor.R: structure(x, levels = lx, class = cx)
./factor.R-}
./factor.R-
./factor.R:"length<-.factor" <- function(x, value)
./factor.R-{
./factor.R- cl <- class(x)
./factor.R- levs <- levels(x)
./factor.R- x <- NextMethod()
./factor.R: structure(x, levels=levs, class=cl)
./factor.R-}
--
./files.R-
./files.R-R.home <- function()
./files.R-.Internal(R.home())
./files.R-
./files.R-file.show <-
./files.R:function (..., header=rep("", nfiles), title="R Information",
./files.R: delete.file=FALSE, pager=getOption("pager"))
./files.R-{
./files.R- file <- c(...)
./files.R- nfiles <- length(file)
./files.R- if(nfiles == 0)
./files.R- return(invisible(NULL))
./files.R- if(is.function(pager))
./files.R: pager(file, header, title, delete.file)
./files.R- else
./files.R: .Internal(file.show(file, header, title, delete.file, pager))
./files.R-}
./files.R-
./files.R:file.append <- function(file1, file2)
./files.R:.Internal(file.append(file1, file2))
./files.R-
./files.R-file.remove <- function(...)
./files.R-.Internal(file.remove(c(...)))
./files.R-
./files.R:file.rename <- function(from, to)
./files.R:.Internal(file.rename(from, to))
./files.R-
./files.R:list.files <- function(path=".", pattern=NULL, all.files=FALSE,
./files.R: full.names=FALSE, recursive=FALSE)
./files.R:.Internal(list.files(path, pattern, all.files, full.names, recursive))
./files.R-
./files.R-dir <- list.files
./files.R-
./files.R-file.path <-
./files.R:function(..., fsep=.Platform$file.sep)
./files.R-{
./files.R: if(any(sapply(list(...), length) == 0)) return(character())
./files.R: paste(..., sep = fsep)
./files.R-}
./files.R-
./files.R-
--
./files.R-.Internal(file.create(c(...)))
./files.R-
./files.R-file.choose <- function(new=FALSE)
./files.R-.Internal(file.choose(new))
./files.R-
./files.R:file.copy <- function(from, to, overwrite=FALSE)
./files.R-{
./files.R- if (!(nf <- length(from))) stop("no files to copy from")
./files.R- if (!(nt <- length(to))) stop("no files to copy to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R: to <- file.path(to, basename(from))
./files.R- else if (nf > nt) stop("more 'from' files than 'to' files")
./files.R: if(nt > nf) from <- rep(from, length.out = nt)
./files.R- if (!overwrite) okay <- !file.exists(to)
./files.R: else okay <- rep.int(TRUE, length(to))
./files.R- if (any(from[okay] %in% to[okay]))
./files.R- stop("file can not be copied both 'from' and 'to'")
./files.R- if (any(okay)) { ## care: create could fail but append work.
./files.R- okay[okay] <- file.create(to[okay])
./files.R: if(any(okay)) okay[okay] <- file.append(to[okay], from[okay])
./files.R- }
./files.R- okay
./files.R-}
./files.R-
./files.R:file.symlink <- function(from, to) {
./files.R- if (!(length(from))) stop("no files to link from")
./files.R- if (!(nt <- length(to))) stop("no files/directory to link to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R: to <- file.path(to, basename(from))
./files.R: .Internal(file.symlink(from, to))
./files.R-}
./files.R-
./files.R-file.info <- function(...)
./files.R-{
./files.R- res <- .Internal(file.info(fn <- c(...)))
./files.R- class(res$mtime) <- class(res$ctime) <- class(res$atime) <-
./files.R: c("POSIXt", "POSIXct")
./files.R- class(res) <- "data.frame"
./files.R- row.names(res) <- fn
./files.R- res
./files.R-}
./files.R-
./files.R:file.access <- function(names, mode = 0)
./files.R-{
./files.R: res <- .Internal(file.access(names, mode))
./files.R- names(res) <- names
./files.R- res
./files.R-}
./files.R-
./files.R:dir.create <- function(path, showWarnings = TRUE, recursive = FALSE)
./files.R: invisible(.Internal(dir.create(path, showWarnings, recursive)))
./files.R-
./files.R:format.octmode <- function(x, ...)
./files.R-{
./files.R: if(!inherits(x, "octmode")) stop("calling wrong method")
./files.R- isna <- is.na(x)
./files.R- y <- x[!isna]
./files.R- class(y) <- NULL
./files.R- ans0 <- character(length(y))
./files.R- z <- NULL
./files.R- while(any(y > 0) || is.null(z)) {
./files.R- z <- y%%8
./files.R- y <- floor(y/8)
./files.R: ans0 <- paste(z, ans0, sep="")
./files.R- }
./files.R: ans <- rep.int(as.character(NA), length(x))
./files.R- ans[!isna] <- ans0
./files.R- ans
./files.R-}
./files.R-as.character.octmode <- format.octmode
./files.R-
./files.R:print.octmode <- function(x, ...)
./files.R-{
./files.R: print(format(x), ...)
./files.R- invisible(x)
./files.R-}
./files.R-
./files.R:"[.octmode" <- function (x, i)
./files.R-{
./files.R- cl <- oldClass(x)
./files.R- y <- NextMethod("[")
./files.R- oldClass(y) <- cl
./files.R- y
./files.R-}
./files.R-
./files.R-system.file <-
./files.R:function(..., package = "base", lib.loc = NULL)
./files.R-{
./files.R- if(nargs() == 0)
./files.R: return(file.path(.Library, "base"))
./files.R- if(length(package) != 1)
./files.R- stop("'package' must be of length 1")
./files.R: packagePath <- .find.package(package, lib.loc, quiet = TRUE)
./files.R- if(length(packagePath) == 0)
./files.R- return("")
./files.R: FILES <- file.path(packagePath, ...)
./files.R- present <- file.exists(FILES)
./files.R- if(any(present))
./files.R- FILES[present]
--
./format.R- else stop("'mode\' must be \"double\" (\"real\") or \"integer\"")
./format.R- if (mode == "character" || (!is.null(format) && format == "s")) {
./format.R- if (mode != "character") {
./format.R: warning('coercing argument to "character" for format="s"')
./format.R- x <- as.character(x)
./format.R- }
./format.R- return(format.char(x, width=width, flag=flag))
--
./findInt.R-### This is a `variant' of approx( method = "constant" ) :
./findInt.R:findInterval <- function(x, vec, rightmost.closed = FALSE, all.inside = FALSE)
./findInt.R-{
./findInt.R- ## Purpose: gives back the indices of x in vec; vec[] sorted
./findInt.R- ## -------------------------------------------------------------------------
./findInt.R: ## Author: Martin Maechler, Date: 4 Jan 2002, 10:16
./findInt.R-
./findInt.R- if(any(is.na(vec)))
./findInt.R- stop("'vec' contains NAs")
--
./findInt.R- ## deal with NA's in x:
./findInt.R- if(has.na <- any(ix <- is.na(x)))
./findInt.R- x <- x[!ix]
./findInt.R- nx <- length(x)
./findInt.R- index <- integer(nx)
./findInt.R: .C("find_interv_vec",
./findInt.R: xt = as.double(vec), n = as.integer(length(vec)),
./findInt.R: x = as.double(x), nx = as.integer(nx),
./findInt.R: as.logical(rightmost.closed),
./findInt.R: as.logical(all.inside),
./findInt.R: index, DUP = FALSE, NAOK = TRUE, # NAOK: 'Inf' only
./findInt.R- PACKAGE = "base")
./findInt.R- if(has.na) {
./findInt.R- ii <- as.integer(ix)
--
./formals.R-formals <- function(fun = sys.function(sys.parent())) {
./formals.R- if(is.character(fun))
./formals.R: fun <- get(fun, mode = "function", envir = parent.frame())
./formals.R- .Internal(formals(fun))
./formals.R-}
./formals.R-
./formals.R-body <- function(fun = sys.function(sys.parent())) {
./formals.R- if(is.character(fun))
./formals.R: fun <- get(fun, mode = "function", envir = parent.frame())
./formals.R- .Internal(body(fun))
./formals.R-}
./formals.R-
./formals.R-alist <- function (...) as.list(sys.call())[-1]
./formals.R-
./formals.R:"body<-" <- function (fun, envir = parent.frame(), value) {
./formals.R- if (is.expression(value)) value <- value[[1]]
./formals.R: as.function(c(formals(fun), value), envir)
./formals.R-}
./formals.R-
./formals.R:"formals<-" <- function (fun, envir = parent.frame(), value)
./formals.R: as.function(c(value, body(fun)), envir)
./formals.R-
--
./format.R:format <- function(x, ...) UseMethod("format")
./format.R-
./format.R-### -----
./format.R-###----- FIXME ----- the digits handling should rather happen in
./format.R-### ----- in .Internal(format(...)) in ../../../main/paste.c !
./format.R:### also the 'names' should be kept dealt with there (dim, dimnames *are*) !
./format.R-###
./format.R-### The new (1.2) switch "character" would be faster in .Internal()
./format.R:### combine with "width = ", and format.char() below!
./format.R-
./format.R-format.default <-
./format.R: function(x, trim = FALSE, digits = NULL, nsmall = 0,
./format.R: justify = c("left", "right", "none"),
./format.R: big.mark = "", big.interval = 3,
./format.R: small.mark = "", small.interval = 5, decimal.mark = ".",
./format.R- ...)
./format.R-{
./format.R: f.char <- function(x, justify) {
./format.R- if(length(x) <= 1) return(x)
./format.R: nc <- nchar(x, type="w")
./format.R- nc[is.na(nc)] <- 2
./format.R- w <- max(nc)
./format.R: sp <- substring(paste(rep.int(" ", w), collapse=""), 1, w-nc)
./format.R- res <-
./format.R: if(justify == "left") paste(x, sp, sep="") else paste(sp, x, sep="")
./format.R: attributes(res) <- attributes(x) ## at least names, dim, dimnames
./format.R- res
./format.R- }
./format.R- if(!is.null(digits)) {
./format.R- op <- options(digits=digits)
./format.R- on.exit(options(op))
./format.R- }
./format.R- justify <- match.arg(justify)
./format.R: switch(mode(x),
./format.R: NULL = "NULL",
./format.R: character = switch(justify,
./format.R: none = x,
./format.R: left = f.char(x, "left"),
./format.R: right= f.char(x, "right")),
./format.R: list = sapply(lapply(x, function(x)
./format.R: .Internal(format(unlist(x), trim=trim))),
./format.R: paste, collapse=", "),
./format.R: call=, expression=, "function"=, "(" = deparse(x),
./format.R: ## else: numeric, complex, .. :
./format.R: { r <- prettyNum(.Internal(format(x, trim = trim, small=nsmall)),
./format.R: big.mark = big.mark, big.interval = big.interval,
./format.R: small.mark = small.mark,
./format.R: small.interval = small.interval,
./format.R- decimal.mark = decimal.mark)
./format.R- if(!is.null(a <- attributes(x)) &&
./format.R- !is.null(a <- a[names(a) != "class"]))
--
./format.R-
./format.R-## MM: This should also happen in C(.) :
./format.R-## .Internal(format(..) should work with 'width =' and 'flag=.."
./format.R-## at least for the case of character arguments.
./format.R-## Note that format.default now has a `justify' argument
./format.R:format.char <- function(x, width = NULL, flag = "-")
./format.R-{
./format.R: ## Character formatting, flag: if "-" LEFT-justify
./format.R- if (is.null(x)) return("")
./format.R- if(!is.character(x)) {
./format.R- warning("format.char: coercing 'x' to 'character'")
--
./format.R- }
./format.R- if(is.null(width) && flag == "-")
./format.R- return(format(x)) # Left justified; width= max.width
./format.R-
./format.R- at <- attributes(x)
./format.R: nc <- nchar(x, type="w") #-- string widths
./format.R- nc[is.na(nc)] <- 2
./format.R- if(is.null(width)) width <- max(nc)
./format.R- else if(width<0) { flag <- "-"; width <- -width }
./format.R- ##- 0.90.1 and earlier:
./format.R: ##- pad <- sapply(pmax(0,width - nc),
./format.R: ##- function(no) paste(character(no+1), collapse =" "))
./format.R- ## Speedup by Jens Oehlschlaegel:
./format.R: tab <- unique(no <- pmax(0, width - nc))
./format.R: tabpad <- sapply(tab+1, function(n) paste(character(n), collapse = " "))
./format.R: pad <- tabpad[match(no, tab)]
./format.R-
./format.R- r <-
./format.R: if(flag=="-") paste(x, pad, sep="")#-- LEFT justified
./format.R: else paste(pad, x, sep="")#-- RIGHT justified
./format.R- if(!is.null(at))
./format.R- attributes(r) <- at
./format.R- r
./format.R-}
./format.R-
./format.R-
./format.R:format.pval <- function(pv, digits = max(1, getOption("digits")-2),
./format.R: eps = .Machine$double.eps, na.form = "NA")
./format.R-{
./format.R- ## Format P values; auxiliary for print.summary.[g]lm(.)
./format.R-
--
./format.R- ## Better than '0.0' for very small values `is0':
./format.R- r <- character(length(is0 <- pv < eps))
./format.R- if(any(!is0)) {
./format.R- rr <- pv <- pv[!is0]
./format.R- ## be smart -- differ for fixp. and expon. display:
./format.R: expo <- floor(log10(ifelse(pv > 0, pv, 1e-50)))
./format.R- fixp <- expo >= -3 | (expo == -4 & digits>1)
./format.R: if(any( fixp)) rr[ fixp] <- format(pv[ fixp], dig=digits)
./format.R: if(any(!fixp)) rr[!fixp] <- format(pv[!fixp], dig=digits)
./format.R- r[!is0]<- rr
./format.R- }
./format.R- if(any(is0)) {
./format.R: digits <- max(1,digits-2)
./format.R- if(any(!is0)) {
./format.R: nc <- max(nchar(rr, type="w"))
./format.R- if(digits > 1 && digits+6 > nc)
./format.R: digits <- max(1, nc - 7)
./format.R- sep <- if(digits==1 && nc <= 6) "" else " "
./format.R- } else sep <- if(digits==1) "" else " "
./format.R: r[is0] <- paste("<", format(eps, digits=digits), sep = sep)
./format.R- }
./format.R- if(has.na) { ## rarely...
./format.R- rok <- r
--
./format.R- r[ina] <- na.form
./format.R- }
./format.R- r
./format.R-}
./format.R-
./format.R:## Martin Maechler , 1994-1998 :
./format.R:formatC <- function (x, digits = NULL, width = NULL,
./format.R: format = NULL, flag = "", mode = NULL,
./format.R: big.mark = "", big.interval = 3,
./format.R: small.mark = "", small.interval = 5,
./format.R- decimal.mark = ".")
./format.R-{
./format.R- blank.chars <- function(no)
./format.R: sapply(no+1, function(n) paste(character(n), collapse=" "))
./format.R-
./format.R- if (!(n <- length(x))) return("")
./format.R- if (is.null(mode)) mode <- storage.mode(x)
./format.R: else if (any(mode == c("double", "real", "integer"))) {
./format.R- ## for .C call later on
./format.R- if(mode=="real") mode <- "double"
./format.R- storage.mode(x) <- mode
--
./format.R- if (mode == "character" || (!is.null(format) && format == "s")) {
./format.R- if (mode != "character") {
./format.R- warning('coercing argument to "character" for format="s"')
./format.R- x <- as.character(x)
./format.R- }
./format.R: return(format.char(x, width=width, flag=flag))
./format.R- }
./format.R- if (missing(format) || is.null(format))
./format.R- format <- if (mode == "integer") "d" else "g"
./format.R- else {
./format.R: if (any(format == c("f", "e", "E", "g", "G", "fg"))) {
./format.R- if (mode == "integer") mode <- storage.mode(x) <- "double"
./format.R- }
./format.R- else if (format == "d") {
./format.R- if (mode != "integer") mode <- storage.mode(x) <- "integer"
./format.R- }
./format.R: else stop('\'format\' must be one of {"f","e","E","g","G", "fg", "s"}')
./format.R- }
./format.R- some.special <- !all(Ok <- is.finite(x))
./format.R- if (some.special) {
./format.R- rQ <- as.character(x[!Ok])
./format.R: x[!Ok] <- as.vector(0, mode = mode)
./format.R- }
./format.R- if(is.null(width) && is.null(digits))
./format.R- width <- 1
--
./format.R- else if(digits < 0)
./format.R- digits <- 6
./format.R- if(is.null(width)) width <- digits + 1
./format.R- else if (width == 0)width <- digits
./format.R- i.strlen <-
./format.R: pmax(abs(width),
./format.R- if(format == "fg"||format == "f") {
./format.R: xEx <- as.integer(floor(log10(abs(x+ifelse(x==0,1,0)))))
./format.R- as.integer(x < 0 | flag!="") + digits +
./format.R- if(format == "f") {
./format.R: 2 + pmax(xEx,0)
./format.R- } else {# format == "fg"
./format.R: pmax(xEx, digits,digits+(-xEx)+1) +
./format.R: ifelse(flag != "", nchar(flag), 0) + 1
./format.R- }
./format.R- } else # format == "g" or "e":
./format.R: rep.int(digits+8, n)
./format.R- )
./format.R- ## sanity check for flags added 2.1.0
./format.R- flag <- as.character(flag)
./format.R: nf <- strsplit(flag, "")[[1]]
./format.R: if(!all(nf %in% c("0", "+", "-", " ", "#")))
./format.R- stop("'flag' can contain only '0+- #'")
./format.R: r <- .C("str_signif",
./format.R: x = x,
./format.R: n = n,
./format.R: mode = as.character(mode),
./format.R: width = as.integer(width),
./format.R: digits = as.integer(digits),
./format.R: format = as.character(format),
./format.R: flag = as.character(flag),
./format.R: result = blank.chars(i.strlen),
./format.R- PACKAGE = "base")$result
./format.R- if (some.special)
./format.R: r[!Ok] <- format.char(rQ, width=width, flag=flag)
./format.R-
./format.R- if(big.mark != "" || small.mark != "" || decimal.mark != ".")
./format.R: r <- prettyNum(r, big.mark = big.mark, big.interval = big.interval,
./format.R: small.mark = small.mark, small.interval = small.interval,
./format.R- decimal.mark = decimal.mark)
./format.R-
./format.R- if (!is.null(x.atr <- attributes(x)))
./format.R- attributes(r) <- x.atr
./format.R- r
./format.R-}
./format.R-
./format.R:format.factor <- function(x, ...)
./format.R: format(as.character(x), ...)
./format.R-
./format.R:format.data.frame <- function(x, ..., justify = "none")
./format.R-{
./format.R- dims <- dim(x)
./format.R- nr <- dims[1]
./format.R- nc <- dims[2]
./format.R: rval <- vector("list", nc)
./format.R- for(i in 1:nc)
./format.R: rval[[i]] <- format(x[[i]], ..., justify = justify)
./format.R: lens <- sapply(rval, NROW)
./format.R: if(any(lens != nr)) { # corrupt data frame, must have at least one column
./format.R- warning("corrupt data frame: columns will be truncated or padded with NAs")
./format.R- for(i in 1:nc) {
./format.R- len <- NROW(rval[[i]])
./format.R- if(len == nr) next
./format.R- if(length(dim(rval[[i]])) == 2) {
./format.R- rval[[i]] <- if(len < nr)
./format.R: rbind(rval[[i]], matrix(NA, nr-len, ncol(rval[[i]])))
./format.R: else rval[[i]][1:nr,]
./format.R- } else {
./format.R: rval[[i]] <- if(len < nr) c(rval[[i]], rep.int(NA, nr-len))
./format.R- else rval[[i]][1:nr]
./format.R- }
./format.R- }
./format.R- }
./format.R- dn <- dimnames(x)
./format.R- cn <- dn[[2]]
./format.R: m <- match(c("row.names", "check.rows", "check.names"), cn, 0)
./format.R: if(any(m > 0)) cn[m] <- paste("..dfd.", cn[m], sep="")
./format.R- names(rval) <- cn
./format.R- rval$check.names <- FALSE
./format.R- rval$row.names <- dn[[1]]
./format.R: x <- do.call("data.frame", rval)
./format.R- ## x will have more cols than rval if there are matrix/data.frame cols
./format.R: if(any(m > 0)) names(x) <- sub("^..dfd.", "", names(x))
./format.R- x
./format.R-}
./format.R-
./format.R:format.AsIs <- function(x, width = 12, ...)
./format.R-{
./format.R: if(is.character(x)) return(format.default(x, ...))
./format.R- n <- length(x)
./format.R: rvec <- rep.int(as.character(NA), n)
./format.R- for(i in 1:n)
./format.R: rvec[i] <- toString(x[[i]], width, ...)
./format.R:# return(format.char(rvec, flag = "+"))
./format.R: ## AsIs might be around a matrix, which is not a class.
./format.R- dim(rvec) <- dim(x)
./format.R: format.default(rvec, justify = "right")
./format.R-}
./format.R-
./format.R-prettyNum <-
./format.R: function(x,
./format.R: big.mark = "", big.interval = 3,
./format.R: small.mark = "", small.interval = 5,
./format.R: decimal.mark = ".", ...)
./format.R-{
./format.R- ## be fast in trivial case:
./format.R- if(!is.character(x))
./format.R: x <- sapply(x,format, ...)
./format.R- if(big.mark == "" && small.mark == "" && decimal.mark == ".")
./format.R- return(x)
./format.R- ## else
./format.R: x.sp <- strsplit(x, ".", fixed=TRUE)
./format.R: P0 <- function(...) paste(..., sep="")
./format.R- revStr <- function(cc)
./format.R: sapply(lapply(strsplit(cc,NULL), rev), paste, collapse="")
./format.R: B. <- sapply(x.sp, "[", 1) # Before "."
./format.R: A. <- sapply(x.sp, "[", 2) # After "." ; empty == NA
./format.R- if(any(iN <- is.na(A.))) A.[iN] <- ""
./format.R- if(nchar(big.mark) &&
./format.R: length(i.big <- grep(P0("[0-9]{", big.interval + 1,",}"), B.))
./format.R- ) { ## add `big.mark' in decimals before "." :
./format.R- B.[i.big] <-
./format.R: revStr(gsub(P0("([0-9]{",big.interval,"})\\B"),
./format.R: P0("\\1",big.mark), revStr(B.[i.big])))
./format.R- }
./format.R- if(nchar(small.mark) &&
./format.R: length(i.sml <- grep(P0("[0-9]{", small.interval + 1,",}"), A.))
./format.R- ) { ## add `small.mark' in decimals after "." :
./format.R: A.[i.sml] <- gsub(P0("([0-9]{",small.interval,"})"),
./format.R: P0("\\1",small.mark), A.[i.sml])
./format.R- }
./format.R: ## extraneous trailing dec.marks: paste(B., A., sep = decimal.mark)
./format.R: P0(B., c(decimal.mark, "")[iN+ 1:1], A.)
./format.R-}
--
./frametools.R:subset.data.frame <- function (x, subset, select, drop = FALSE, ...)
./frametools.R-{
./frametools.R- if(missing(subset))
./frametools.R- r <- TRUE
./frametools.R- else {
./frametools.R- e <- substitute(subset)
./frametools.R: r <- eval(e, x, parent.frame())
./frametools.R- if(!is.logical(r)) stop("'subset' must evaluate to logical")
./frametools.R- r <- r & !is.na(r)
./frametools.R- }
./frametools.R- if(missing(select))
./frametools.R- vars <- TRUE
./frametools.R- else {
./frametools.R- nl <- as.list(1:ncol(x))
./frametools.R- names(nl) <- names(x)
./frametools.R: vars <- eval(substitute(select), nl, parent.frame())
./frametools.R- }
./frametools.R: x[r, vars, drop = drop]
./frametools.R-}
./frametools.R-
./frametools.R:subset <- function(x, ...) UseMethod("subset")
./frametools.R-
./frametools.R:subset.default <- function(x, subset, ...) {
./frametools.R- if(!is.logical(subset)) stop("'subset' must be logical")
./frametools.R- x[subset & !is.na(subset)]
./frametools.R-}
./frametools.R-
./frametools.R:subset.matrix <- function(x, subset, select, drop = FALSE, ...)
./frametools.R-{
./frametools.R- if(missing(select))
./frametools.R- vars <- TRUE
./frametools.R- else {
./frametools.R- nl <- as.list(1:ncol(x))
./frametools.R- names(nl) <- colnames(x)
./frametools.R: vars <- eval(substitute(select), nl, parent.frame())
./frametools.R- }
./frametools.R- if(missing(subset)) subset <- TRUE
./frametools.R- else if(!is.logical(subset)) stop("'subset' must be logical")
./frametools.R: x[subset & !is.na(subset), vars, drop = drop]
./frametools.R-}
./frametools.R-
./frametools.R:transform.data.frame <- function (x, ...)
./frametools.R-{
./frametools.R: e <- eval(substitute(list(...)), x, parent.frame())
./frametools.R- tags <- names(e)
./frametools.R: inx <- match(tags, names(x))
./frametools.R- matched <- !is.na(inx)
./frametools.R- if (any(matched)) {
./frametools.R- x[inx[matched]] <- e[matched]
./frametools.R- x <- data.frame(x)
./frametools.R- }
./frametools.R- if (!all(matched))
./frametools.R: data.frame(x, e[!matched])
./frametools.R- else x
./frametools.R-}
./frametools.R-
./frametools.R:transform <- function(x,...) UseMethod("transform")
./frametools.R-
./frametools.R:## Actually, I have no idea what to transform(), except dataframes.
./frametools.R-## The default converts its argument to a dataframe and transforms
./frametools.R-## that. This is probably marginally useful at best. --pd
./frametools.R:transform.default <- function(x,...)
./frametools.R: transform.data.frame(data.frame(x),...)
./frametools.R-
./frametools.R:stack.data.frame <- function(x, select, ...)
./frametools.R-{
./frametools.R- if (!missing(select)) {
./frametools.R- nl <- as.list(1:ncol(x))
./frametools.R- names(nl) <- names(x)
./frametools.R: vars <- eval(substitute(select),nl, parent.frame())
./frametools.R: x <- x[, vars, drop=FALSE]
./frametools.R- }
./frametools.R: x <- x[, unlist(lapply(x, is.vector)), drop = FALSE]
./frametools.R: data.frame(values = unlist(unname(x)),
./frametools.R: ind = factor(rep.int(names(x), lapply(x, length))))
./frametools.R-}
./frametools.R-
./frametools.R:stack <- function(x, ...) UseMethod("stack")
./frametools.R-
./frametools.R:stack.default <- function(x, ...)
./frametools.R-{
./frametools.R- x <- as.list(x)
./frametools.R: x <- x[unlist(lapply(x, is.vector))]
./frametools.R: data.frame(values = unlist(unname(x)),
./frametools.R: ind = factor(rep.int(names(x), lapply(x, length))))
./frametools.R-}
./frametools.R-
./frametools.R:unstack.data.frame <- function(x, form = formula(x), ...)
./frametools.R-{
./frametools.R- form <- as.formula(form)
./frametools.R- if (length(form) < 3)
./frametools.R- stop("'form' must be a two-sided formula")
./frametools.R: res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
./frametools.R: if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
./frametools.R- return(res)
./frametools.R- data.frame(res)
./frametools.R-}
./frametools.R-
./frametools.R:unstack <- function(x, ...) UseMethod("unstack")
./frametools.R-
./frametools.R:unstack.default <- function(x, form, ...)
./frametools.R-{
./frametools.R- x <- as.list(x)
./frametools.R- form <- as.formula(form)
./frametools.R- if (length(form) < 3)
./frametools.R- stop("'form' must be a two-sided formula")
./frametools.R: res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
./frametools.R: if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
./frametools.R- return(res)
./frametools.R- data.frame(res)
./frametools.R-}
--
./get.R-get <-
./get.R: function (x, pos = -1, envir = as.environment(pos), mode = "any",
./get.R- inherits = TRUE)
./get.R: .Internal(get(x, envir, mode, inherits))
./get.R-
./get.R:mget <- function(x, envir, mode = "any",
./get.R- ifnotfound= list(function(x)
./get.R: stop(paste("value for '", x, "' not found", sep=""),
./get.R: call.=FALSE)),
./get.R- inherits = FALSE)
./get.R: .Internal(mget(x, envir, mode, ifnotfound, inherits))
--
./getenv.R-Sys.getenv <- function(x) {
./getenv.R- if (missing(x)) {
./getenv.R: x <- strsplit(.Internal(getenv(character())), "=", fixed=TRUE)
./getenv.R- v <- n <- character(LEN <- length(x))
./getenv.R- for (i in 1:LEN) {
./getenv.R- n[i] <- x[[i]][1]
./getenv.R: v[i] <- paste(x[[i]][-1], collapse = "=")
./getenv.R- }
./getenv.R: structure(v, names = n)
./getenv.R- } else {
./getenv.R: structure(.Internal(getenv(x)), names = x)
./getenv.R- }
./getenv.R-}
./getenv.R-
./getenv.R-Sys.putenv <- function(...)
./getenv.R-{
./getenv.R- x <- list(...)
./getenv.R- nm <- names(x)
./getenv.R- val <- as.character(unlist(x))
./getenv.R: x <- paste(nm,val, sep="=")
./getenv.R- invisible(.Internal(putenv(x)))
./getenv.R-}
./getenv.R-
--
./gl.R-## gl function of GLIM
./gl.R:gl <- function (n, k, length = n*k, labels=1:n, ordered=FALSE)
./gl.R: factor(rep(rep.int(1:n, rep.int(k,n)), length.out=length),
./gl.R: levels=1:n, labels=labels, ordered=ordered)
--
./grep.R-grep <-
./grep.R:function(pattern, x, ignore.case = FALSE, extended = TRUE, perl = FALSE,
./grep.R: value = FALSE, fixed = FALSE, useBytes = FALSE)
./grep.R-{
./grep.R- ## behaves like == for NA pattern
./grep.R- if (is.na(pattern)){
./grep.R- if(value)
./grep.R: return(rep.int(as.character(NA), length(x)))
./grep.R- else
./grep.R: return(rep.int(NA, length(x)))
./grep.R- }
./grep.R-
./grep.R- if(perl)
./grep.R: .Internal(grep.perl(pattern, x, ignore.case, value, useBytes))
./grep.R- else
./grep.R: .Internal(grep(pattern, x, ignore.case, extended, value, fixed, useBytes))
./grep.R-}
./grep.R-
./grep.R-sub <-
./grep.R:function(pattern, replacement, x, ignore.case = FALSE, extended = TRUE,
./grep.R: perl = FALSE, fixed = FALSE)
./grep.R-{
./grep.R- if (is.na(pattern))
./grep.R: return(rep.int(as.character(NA), length(x)))
./grep.R-
./grep.R- if(perl)
./grep.R: .Internal(sub.perl(pattern, replacement, x, ignore.case))
./grep.R- else
./grep.R: .Internal(sub(pattern, replacement, x, ignore.case,
./grep.R: extended, fixed))
./grep.R-}
./grep.R-
./grep.R-gsub <-
./grep.R:function(pattern, replacement, x, ignore.case = FALSE, extended = TRUE,
./grep.R: perl = FALSE, fixed = FALSE)
./grep.R-{
./grep.R- if (is.na(pattern))
./grep.R: return(rep.int(as.character(NA), length(x)))
./grep.R-
./grep.R- if(perl)
./grep.R: .Internal(gsub.perl(pattern, replacement, x, ignore.case))
./grep.R- else
./grep.R: .Internal(gsub(pattern, replacement, x, ignore.case,
./grep.R: extended, fixed))
./grep.R-}
./grep.R-
./grep.R-regexpr <-
./grep.R:function(pattern, text, extended = TRUE, perl = FALSE,
./grep.R: fixed = FALSE, useBytes = FALSE)
./grep.R-{
./grep.R- if(perl)
./grep.R: .Internal(regexpr.perl(pattern, text, useBytes))
./grep.R- else
./grep.R: .Internal(regexpr(pattern, text, extended, fixed, useBytes))
./grep.R-}
./grep.R-
./grep.R-agrep <-
./grep.R:function(pattern, x, ignore.case = FALSE, value = FALSE,
./grep.R- max.distance = 0.1)
./grep.R-{
./grep.R- ## behaves like == for NA pattern
./grep.R- if (is.na(pattern)){
./grep.R- if (value)
./grep.R: return(rep.int(as.character(NA), length(x)))
./grep.R- else
./grep.R: return(rep.int(NA, length(x)))
./grep.R- }
./grep.R-
./grep.R- if(!is.character(pattern)
--
./grep.R- max.insertions <- max.deletions <- max.substitutions <-
./grep.R- max.distance
./grep.R- }
./grep.R- else {
./grep.R- ## partial matching
./grep.R: table <- c("all", "deletions", "insertions", "substitutions")
./grep.R: ind <- pmatch(names(max.distance), table)
./grep.R- if(any(is.na(ind)))
./grep.R- warning("unknown match distance components ignored")
./grep.R- max.distance <- max.distance[!is.na(ind)]
--
./grep.R- max.insertions <- ceiling(n * max.insertions)
./grep.R- if(max.substitutions < 1)
./grep.R- max.substitutions <- ceiling(n * max.substitutions)
./grep.R- }
./grep.R-
./grep.R: .Internal(agrep(pattern, x, ignore.case, value, max.distance,
./grep.R: max.deletions, max.insertions, max.substitutions))
./grep.R-}
--
./identical.R:identical <- function(x, y) .Internal(identical(x,y))
./identical.R-
./identical.R:isTRUE <- function(x) identical(TRUE, x)
--
./ifelse.R-ifelse <-
./ifelse.R: function (test, yes, no)
./ifelse.R-{
./ifelse.R- storage.mode(test) <- "logical"
./ifelse.R- ans <- test
./ifelse.R- nas <- is.na(test)
./ifelse.R- if (any(test[!nas]))
./ifelse.R: ans[test & !nas] <- rep(yes, length.out = length(ans))[test & !nas]
./ifelse.R- if (any(!test[!nas]))
./ifelse.R: ans[!test & !nas] <- rep(no, length.out = length(ans))[!test & !nas]
./ifelse.R- ans[nas] <- NA
./ifelse.R- ans
./ifelse.R-}
--
./interaction.R-### This is almost like the Primitive ":" for factors
./interaction.R-### (that has no "drop = TRUE") --- it's not used anywhere in "standard R"
./interaction.R:interaction <- function(..., drop = FALSE, sep = ".")
./interaction.R-{
./interaction.R- args <- list(...)
./interaction.R- narg <- length(args)
--
./interaction.R- f <- args[[i]]
./interaction.R- if (!is.factor(f))
./interaction.R- f <- factor(f)
./interaction.R- l <- levels(f)
./interaction.R- ans <- ans * length(l) + as.integer(f) - 1
./interaction.R: lvs <- if (i == narg) l else as.vector(outer(l, lvs, paste, sep=sep))
./interaction.R- }
./interaction.R- ans <- ans + 1
./interaction.R- if (drop) {
./interaction.R- f <- unique(ans[!is.na(ans)])
./interaction.R: ans <- match(ans, f)
./interaction.R- lvs <- lvs[f]
./interaction.R- }
./interaction.R- ans <- as.integer(ans)
--
./is.R:is.vector <- function(x, mode="any") .Internal(is.vector(x,mode))
./is.R-## is.finite <- function(x) !is.na(x)
./is.R-
./is.R-is.name <- is.symbol # which is Primitive
./is.R-##Was is.symbol <- function(x) typeof(x)=="symbol"
./is.R-
./is.R-
./is.R:"is.na<-" <- function(x, value) UseMethod("is.na<-")
./is.R-
./is.R:"is.na<-.default" <- function(x, value)
./is.R-{
./is.R- x[value] <- NA
./is.R- x
./is.R-}
./is.R-
./is.R-is.primitive <- function(x)
./is.R: switch(typeof(x),
./is.R: "special" = , "builtin" = TRUE,
./is.R- FALSE)
./is.R-
./is.R-
--
./jitter.R-### Unimplemented Idea {for amount = NULL ?}
./jitter.R:### Really "optimal" (e.g. for rug()), use a non-constant amount,
./jitter.R-### e.g. use "d" = diff(xx) BEFORE taking min()...
./jitter.R-
./jitter.R:jitter <- function(x, factor = 1, amount=NULL)
./jitter.R-{
./jitter.R- if(length(x) == 0)
./jitter.R- return(x)
./jitter.R- z <- diff(r <- range(x[is.finite(x)]))
./jitter.R- if(z == 0) z <- abs(r[1])
./jitter.R- if(z == 0) z <- 1
./jitter.R-
./jitter.R- if(is.null(amount)) { # default: Find 'necessary' amount
./jitter.R: d <- diff(xx <- unique(sort(round(x, 3 - floor(log10(z))))))
./jitter.R- d <- if(length(d)) min(d) else if(xx!=0) xx/10 else z/10
./jitter.R- amount <- factor/5 * d
./jitter.R- } else if(amount == 0) # only then: S compatibility
./jitter.R- amount <- factor * (z/50)
./jitter.R-
./jitter.R: x + runif(length(x), - amount, amount)
./jitter.R-}
--
./kappa.R:kappa <- function(z, ...) UseMethod("kappa")
./kappa.R-
./kappa.R:kappa.lm <- function(z, ...)
./kappa.R-{
./kappa.R: kappa.qr(z$qr, ...)
./kappa.R-}
./kappa.R-
./kappa.R:kappa.default <- function(z, exact = FALSE, ...)
./kappa.R-{
./kappa.R- z <- as.matrix(z)
./kappa.R- if(exact) {
./kappa.R: s <- svd(z, nu=0, nv=0)$d
./kappa.R- max(s)/min(s[s > 0])
./kappa.R- } else if(is.qr(z)) kappa.qr(z)
./kappa.R- else if(nrow(z) < ncol(z)) kappa.qr(qr(t(z)))
./kappa.R- else kappa.qr(qr(z))
./kappa.R-}
./kappa.R-
./kappa.R:kappa.qr <- function(z, ...)
./kappa.R-{
./kappa.R- qr <- z$qr
./kappa.R: R <- qr[1:min(dim(qr)), , drop = FALSE]
./kappa.R- R[lower.tri(R)] <- 0
./kappa.R: kappa.tri(R, ...)
./kappa.R-}
./kappa.R-
./kappa.R:kappa.tri <- function(z, exact = FALSE, ...)
./kappa.R-{
./kappa.R- if(exact) kappa.default(z)
./kappa.R- else {
./kappa.R- p <- nrow(z)
./kappa.R- if(p != ncol(z)) stop("matrix should be square")
./kappa.R: 1 / .Fortran("dtrco",
./kappa.R: as.double(z),
./kappa.R: p,
./kappa.R: p,
./kappa.R: k = double(1),
./kappa.R: double(p),
./kappa.R: as.integer(1),
./kappa.R- PACKAGE="base")$k
./kappa.R- }
./kappa.R-}
--
./kronecker.R-"kronecker" <-
./kronecker.R:function (X, Y, FUN = "*", make.dimnames = FALSE, ...)
./kronecker.R-{
./kronecker.R- X <- as.array(X)
./kronecker.R- Y <- as.array(Y)
--
./kronecker.R- }
./kronecker.R- dX <- dim(X)
./kronecker.R- dY <- dim(Y)
./kronecker.R- ld <- length(dX) - length(dY)
./kronecker.R- if (ld < 0)
./kronecker.R: dX <- dim(X) <- c(dX, rep.int(1, -ld))
./kronecker.R- else if (ld > 0)
./kronecker.R: dY <- dim(Y) <- c(dY, rep.int(1, ld))
./kronecker.R: opobj <- outer(X, Y, FUN, ...)
./kronecker.R: dp <- as.vector(t(matrix(1:(2*length(dX)), ncol = 2)[, 2:1]))
./kronecker.R: opobj <- aperm(opobj, dp)
./kronecker.R- dim(opobj) <- dX * dY
./kronecker.R-
./kronecker.R- if (make.dimnames && !(is.null(dnx) && is.null(dny))) {
./kronecker.R-
./kronecker.R- if (is.null(dnx))
./kronecker.R: dnx <- rep.int(list(NULL), length(dX))
./kronecker.R- else if (ld < 0)
./kronecker.R: dnx <- c(dnx, rep.int(list(NULL), -ld))
./kronecker.R: tmp <- which(sapply(dnx, is.null))
./kronecker.R: dnx[tmp] <- lapply(tmp, function(i) rep.int("", dX[i]))
./kronecker.R-
./kronecker.R- if (is.null(dny))
./kronecker.R: dny <- rep.int(list(NULL), length(dY))
./kronecker.R- else if (ld > 0)
./kronecker.R: dny <- c(dny, rep.int(list(NULL), ld))
./kronecker.R: tmp <- which(sapply(dny, is.null))
./kronecker.R: dny[tmp] <- lapply(tmp, function(i) rep.int("", dY[i]))
./kronecker.R-
./kronecker.R- k <- length(dim(opobj))
./kronecker.R: dno <- vector("list", k)
./kronecker.R- for (i in 1:k) {
./kronecker.R: tmp <- outer(dnx[[i]], dny[[i]], FUN="paste", sep=":")
./kronecker.R- dno[[i]] <- as.vector(t(tmp))
./kronecker.R- }
./kronecker.R- dimnames(opobj) <- dno
./kronecker.R- }
./kronecker.R- opobj
./kronecker.R-}
./kronecker.R-
./kronecker.R:## Binary operator, hence don't simply do "%x%" <- kronecker.
./kronecker.R:"%x%" <- function(X, Y) kronecker(X, Y)
--
./labels.R:labels <- function(object, ...) UseMethod("labels")
./labels.R-
./labels.R:labels.default <- function(object, ...)
./labels.R-{
./labels.R- if(length(d <- dim(object))) { # array or data frame
./labels.R- nt <- dimnames(object)
./labels.R: if(is.null(nt)) nt <- vector("list", length(d))
./labels.R- for(i in 1:length(d))
./labels.R- if(!length(nt[[i]])) nt[[i]] <- as.character(seq(length = d[i]))
./labels.R- } else {
--
./lapply.R:lapply <- function (X, FUN, ...)
./lapply.R-{
./lapply.R- FUN <- match.fun(FUN)
./lapply.R- if (!is.list(X)) X <- as.list(X)
./lapply.R: rval <-.Internal(lapply(X, FUN))
./lapply.R- names(rval) <- names(X)
./lapply.R- return(rval)
./lapply.R-}
./lapply.R-if(FALSE) {
./lapply.R:lapply <- function(X, FUN, ...) {
./lapply.R- FUN <- match.fun(FUN)
./lapply.R- if (!is.list(X))
./lapply.R- X <- as.list(X)
./lapply.R: rval <- vector("list", length(X))
./lapply.R- for(i in seq(along = X))
./lapply.R: rval[i] <- list(FUN(X[[i]], ...))
./lapply.R- names(rval) <- names(X) # keep `names' !
./lapply.R- return(rval)
./lapply.R-}
--
./lazyload.R:lazyLoad <- function(filebase, envir = parent.frame(), filter)
./lazyload.R-{
./lazyload.R- ##
./lazyload.R- ## bootstrapping definitions so we can load base
./lazyload.R- ##
./lazyload.R: glue <- function (..., sep = " ", collapse = NULL)
./lazyload.R: .Internal(paste(list(...), sep, collapse))
./lazyload.R- readRDS <- function (file) {
./lazyload.R: halt <- function (message) .Internal(stop(TRUE, message))
./lazyload.R: gzfile <- function (description, open)
./lazyload.R: .Internal(gzfile(description, open, "", 6))
./lazyload.R: close <- function (con) .Internal(close(con, "rw"))
./lazyload.R- if (! is.character(file)) halt("bad file name")
./lazyload.R: con <- gzfile(file, "rb")
./lazyload.R- on.exit(close(con))
./lazyload.R: .Internal(unserializeFromConn(con, NULL))
./lazyload.R- }
./lazyload.R- "parent.env<-" <-
./lazyload.R: function (env, value) .Internal("parent.env<-"(env, value))
./lazyload.R- along <- function(x) { n <- length(x); if (n) 1 : n else NULL }
./lazyload.R: existsInFrame <- function (x, env) .Internal(exists(x, env, "any", FALSE))
./lazyload.R: getFromFrame <- function (x, env) .Internal(get(x, env, "any", FALSE))
./lazyload.R: set <- function (x, value, env) .Internal(assign(x, value, env, FALSE))
./lazyload.R- environment <- function () .Internal(environment(NULL))
./lazyload.R: mkenv <- function() .Internal(new.env(TRUE, NULL))
./lazyload.R- names <- function(x) .Internal(names(x))
./lazyload.R: lazyLoadDBfetch <- function(key, file, compressed, hook)
./lazyload.R: .Call("R_lazyLoadDBfetch", key, file, compressed, hook, PACKAGE="base")
./lazyload.R-
./lazyload.R- ##
./lazyload.R- ## main body
./lazyload.R- ##
./lazyload.R: mapfile <- glue(filebase, "rdx", sep = ".")
./lazyload.R: datafile <- glue(filebase, "rdb", sep = ".")
./lazyload.R- env <- mkenv()
./lazyload.R- map <- readRDS(mapfile)
./lazyload.R- vars <- names(map$variables)
./lazyload.R- rvars <- names(map$references)
./lazyload.R- compressed <- map$compressed
./lazyload.R- for (i in along(rvars))
./lazyload.R: set(rvars[i], map$references[[i]], env)
./lazyload.R- envenv <- mkenv()
./lazyload.R- envhook <- function(n) {
./lazyload.R: if (existsInFrame(n, envenv))
./lazyload.R: getFromFrame(n, envenv)
./lazyload.R- else {
./lazyload.R- e <- mkenv()
./lazyload.R: set(n, e, envenv) # MUST do this immediately
./lazyload.R: key <- getFromFrame(n, env)
./lazyload.R: data <- lazyLoadDBfetch(key, datafile, compressed, envhook)
./lazyload.R- parent.env(e) <- data$enclos
./lazyload.R- vars <- names(data$bindings)
./lazyload.R- for (i in along(vars))
./lazyload.R: set(vars[i], data$bindings[[i]], e)
./lazyload.R- e
./lazyload.R- }
./lazyload.R- }
./lazyload.R: expr <- quote(lazyLoadDBfetch(key, datafile, compressed, envhook))
./lazyload.R: setWrapped <- function(x, value, env) {
./lazyload.R- key <- value # force evaluation
./lazyload.R: .Internal(delayedAssign(x, expr, environment(), env))
./lazyload.R- }
./lazyload.R- if (! missing(filter)) {
./lazyload.R- for (i in along(vars))
./lazyload.R- if (filter(vars[i]))
./lazyload.R: setWrapped(vars[i], map$variables[[i]], envir)
./lazyload.R- } else {
./lazyload.R- for (i in along(vars))
./lazyload.R: setWrapped(vars[i], map$variables[[i]], envir)
./lazyload.R- }
./lazyload.R-
./lazyload.R- ## reduce memory use **** try some more trimming
--
./library.R:testPlatformEquivalence <- function(built, run)
./library.R-{
./library.R: ## args are "cpu-vendor-os", but os might be 'linux-gnu'!
./library.R- ## remove vendor field
./library.R: built <- gsub("([^-]*)-([^-]*)-(.*)", "\\1-\\3", built)
./library.R: run <- gsub("([^-]*)-([^-]*)-(.*)", "\\1-\\3", run)
./library.R: ## allow for small mismatches, e.g. OS version number and i686 vs i586.
./library.R: length(agrep(built, run)) > 0
./library.R-}
./library.R-
./library.R-library <-
./library.R:function(package, help, pos = 2, lib.loc = NULL, character.only = FALSE,
./library.R: logical.return = FALSE, warn.conflicts = TRUE,
./library.R: keep.source = getOption("keep.source.pkgs"),
./library.R: verbose = getOption("verbose"), version)
./library.R-{
./library.R: testRversion <- function(pkgInfo, pkgname)
./library.R- {
./library.R- current <- getRversion()
./library.R- ## depends on R version?
./library.R- if(length(Rdeps <- pkgInfo$Rdepends) > 1) {
./library.R- target <- Rdeps$version
./library.R: res <- eval(parse(text=paste("current", Rdeps$op, "target")))
./library.R- if(!res)
./library.R: stop(gettextf("This is R %s, package '%s' needs %s %s",
./library.R: current, pkgname, Rdeps$op, target),
./library.R: call. = FALSE, domain = NA)
./library.R- }
./library.R- ## which version was this package built under?
./library.R- if(!is.null(built <- pkgInfo$Built)) {
./library.R- ## must be >= 2.0.0
./library.R- if(built$R < "2.0.0")
./library.R: stop(gettextf("package '%s' was built before R 2.0.0: please re-install it",
./library.R: pkgname), call. = FALSE, domain = NA)
./library.R- ## warn if later than this version
./library.R- if(built$R > current)
./library.R: warning(gettextf("package '%s' was built under R version %s",
./library.R: pkgname, as.character(built$R)),
./library.R: call. = FALSE, domain = NA)
./library.R- if(.Platform$OS.type == "unix") {
./library.R- platform <- built$Platform
./library.R: if(length(grep("\\w", platform)) &&
./library.R: !testPlatformEquivalence(platform, R.version$platform))
./library.R: stop(gettextf("package '%s' was built for %s",
./library.R: pkgname, platform),
./library.R: call. = FALSE, domain = NA)
./library.R- }
./library.R- }
./library.R- else
./library.R: stop(gettextf("package '%s' has not been installed properly\n",
./library.R: pkgname),
./library.R: gettext("See the Note in ?library"),
./library.R: call. = FALSE, domain = NA)
./library.R- }
./library.R-
./library.R: checkNoGenerics <- function(env, pkg)
./library.R- {
./library.R- nenv <- env
./library.R- ns <- .Internal(getRegisteredNamespace(as.name(libraryPkgName(pkg))))
./library.R- if(!is.null(ns)) nenv <- asNamespace(ns)
./library.R: if (exists(".noGenerics", envir = nenv, inherits = FALSE))
./library.R- TRUE
./library.R- else {
./library.R- ## A package will have created a generic
./library.R- ## only if it has created a formal method.
./library.R: length(objects(env, pattern="^\\.__M", all=TRUE)) == 0
./library.R- }
./library.R- }
./library.R-
./library.R: checkConflicts <- function(package, pkgname, pkgpath, nogenerics)
./library.R- {
./library.R: dont.mind <- c("last.dump", "last.warning", ".Last.value",
./library.R: ".Random.seed", ".First.lib", ".Last.lib",
./library.R: ".packageName", ".noGenerics", ".required",
./library.R- ".no_S3_generics")
./library.R- sp <- search()
./library.R: lib.pos <- match(pkgname, sp)
./library.R- ## ignore generics not defined for the package
./library.R: ob <- objects(lib.pos, all = TRUE)
./library.R- if(!nogenerics && .isMethodsDispatchOn()) {
./library.R: these <- objects(lib.pos, all = TRUE)
./library.R: these <- these[substr(these, 1, 6) == ".__M__"]
./library.R: gen <- gsub(".__M__(.*):([^:]+)", "\\1", these)
./library.R: from <- gsub(".__M__(.*):([^:]+)", "\\2", these)
./library.R- gen <- gen[from != ".GlobalEnv"]
./library.R- ob <- ob[!(ob %in% gen)]
./library.R- }
./library.R- fst <- TRUE
./library.R: ipos <- seq(along = sp)[-c(lib.pos, match("Autoloads", sp))]
./library.R- for (i in ipos) {
./library.R: obj.same <- match(objects(i, all = TRUE), ob, nomatch = 0)
./library.R- if (any(obj.same > 0)) {
./library.R- same <- ob[obj.same]
./library.R- same <- same[!(same %in% dont.mind)]
./library.R: Classobjs <- grep("^\\.__", same)
./library.R- if(length(Classobjs)) same <- same[-Classobjs]
./library.R- if(length(same)) {
./library.R- if (fst) {
./library.R- fst <- FALSE
./library.R: cat(gettextf("\nAttaching package: '%s'\n\n", package))
./library.R- }
./library.R: cat("\n\tThe following object(s) are masked",
./library.R: if (i < lib.pos) "_by_" else "from", sp[i],
./library.R: ":\n\n\t", same, "\n\n")
./library.R- }
./library.R- }
./library.R- }
./library.R- }
./library.R-
./library.R: libraryPkgName <- function(pkgName, sep = "_")
./library.R: unlist(strsplit(pkgName, sep, fixed=TRUE))[1]
./library.R-
./library.R: libraryPkgVersion <- function(pkgName, sep = "_")
./library.R- {
./library.R: splitName <- unlist(strsplit(pkgName, sep, fixed=TRUE))
./library.R- if (length(splitName) > 1) splitName[2] else NULL
./library.R- }
./library.R-
--
./library.R- if(length(vers) == 0) return(integer(0))
./library.R- vers <- package_version(vers)
./library.R- min(which(vers == max(vers)))
./library.R- }
./library.R-
./library.R: runUserHook <- function(pkgname, pkgpath) {
./library.R: hook <- getHook(packageEvent(pkgname, "attach")) # might be list()
./library.R: for(fun in hook) try(fun(pkgname, pkgpath))
./library.R- }
./library.R-
./library.R: bindTranslations <- function(pkgname, pkgpath)
./library.R- {
./library.R: popath <- file.path(pkgpath, "po")
./library.R- if(!file.exists(popath)) return()
./library.R: bindtextdomain(pkgname, popath)
./library.R: bindtextdomain(paste("R", pkgname, sep="-"), popath)
./library.R- }
./library.R-
./library.R- if(!missing(package)) {
./library.R- if (is.null(lib.loc)) lib.loc <- .libPaths()
./library.R-
./library.R- if(!character.only)
./library.R- package <- as.character(substitute(package))
./library.R-
./library.R: if(package %in% c("ctest", "eda", "modreg", "mva", "nls",
./library.R: "stepfun", "ts")) {
./library.R- have.stats <- "package:stats" %in% search()
./library.R- if(!have.stats) require("stats")
./library.R- old <- "stats"
./library.R: warning(gettextf("package '%s' has been merged into '%s'",
./library.R: package, old),
./library.R: call. = FALSE, domain = NA)
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
./library.R- }
./library.R- if(package == "mle") {
./library.R- have.stats4 <- "package:stats4" %in% search()
./library.R- if(!have.stats4) require("stats4")
./library.R- old <- "stats4"
./library.R: warning(gettextf("package '%s' has been merged into '%s'",
./library.R: package, old),
./library.R: call. = FALSE, domain = NA)
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
./library.R- }
./library.R- if(package == "lqs") {
./library.R: warning("package 'lqs' has been moved back to package 'MASS'",
./library.R: call. = FALSE, immediate. = TRUE)
./library.R- have.VR <- "package:MASS" %in% search()
./library.R- if(!have.VR) {
./library.R: if(require("MASS", quietly=TRUE))
./library.R: warning("package 'MASS' has now been loaded",
./library.R: call. = FALSE, immediate. = TRUE)
./library.R- else {
./library.R- if(logical.return) return(FALSE)
./library.R- else
--
./library.R- }
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
./library.R- }
./library.R-
./library.R- if (!missing(version)) {
./library.R: package <- manglePackageName(package, version)
./library.R- } else {
./library.R- ## Need to find the proper package to install
./library.R: pkgDirs <- list.files(lib.loc,
./library.R: pattern = paste("^", package, sep=""))
./library.R- ## See if any directories in lib.loc match the pattern of
./library.R: ## 'package', if none do, just continue as it will get caught
./library.R: ## below. Otherwise, if there is actually a 'package', use
./library.R: ## that, and if not, then use the highest versioned dir.
./library.R- if (length(pkgDirs) > 0) {
./library.R- if (!(package %in% pkgDirs)) {
./library.R- ## Need to find the highest version available
./library.R: vers <- unlist(lapply(pkgDirs, libraryPkgVersion))
./library.R- vpos <- libraryMaxVersPos(vers)
./library.R- if (length(vpos) > 0) package <- pkgDirs[vpos]
./library.R- }
--
./library.R-
./library.R- ## NB from this point on `package' is either the original name or
./library.R- ## something like ash_1.0-8
./library.R- if(length(package) != 1)
./library.R- stop("'package' must be of length 1")
./library.R: pkgname <- paste("package", package, sep = ":")
./library.R: newpackage <- is.na(match(pkgname, search()))
./library.R- if(newpackage) {
./library.R- ## Check for the methods package before attaching this
./library.R- ## package.
./library.R- ## Only if it is _already_ here do we do cacheMetaData.
./library.R- ## The methods package caches all other libs when it is
./library.R- ## attached.
./library.R-
./library.R: pkgpath <- .find.package(package, lib.loc, quiet = TRUE,
./library.R- verbose = verbose)
./library.R- if(length(pkgpath) == 0) {
./library.R- vers <- libraryPkgVersion(package)
./library.R- txt <- if (!is.null(vers))
./library.R: gettextf("there is no package called '%s', version %s",
./library.R: libraryPkgName(package), vers)
./library.R- else
./library.R: gettextf("there is no package called '%s'",
./library.R- libraryPkgName(package))
./library.R- if(logical.return) {
./library.R: warning(txt, domain = NA)
./library.R- return(FALSE)
./library.R: } else stop(txt, domain = NA)
./library.R- }
./library.R- which.lib.loc <- dirname(pkgpath)
./library.R: pfile <- system.file("Meta", "package.rds", package = package,
./library.R- lib.loc = which.lib.loc)
./library.R- if(!nchar(pfile))
./library.R: stop(gettextf("'%s' is not a valid package -- installed < 2.0.0?",
./library.R: libraryPkgName(package)), domain = NA)
./library.R- pkgInfo <- .readRDS(pfile)
./library.R: testRversion(pkgInfo, package)
./library.R-
./library.R- ## The check for inconsistent naming is now in .find.package
./library.R-
./library.R- if(is.character(pos)) {
./library.R: npos <- match(pos, search())
./library.R- if(is.na(npos)) {
./library.R: warning(gettextf("'%s' not found on search path, using pos = 2", pos), domain = NA)
./library.R- pos <- 2
./library.R- } else pos <- npos
./library.R- }
./library.R- .getRequiredPackages2(pkgInfo)
./library.R:# .getRequiredPackages2(pkgInfo, lib.loc = lib.loc)
./library.R- ## If the name space mechanism is available and the package
./library.R: ## has a name space, then the name space loading mechanism
./library.R- ## takes over.
./library.R: if (packageHasNamespace(package, which.lib.loc)) {
./library.R- tt <- try({
./library.R: ns <- loadNamespace(package, c(which.lib.loc, lib.loc))
./library.R: dataPath <- file.path(which.lib.loc, package, "data")
./library.R: env <- attachNamespace(ns, pos = pos,
./library.R- dataPath = dataPath)
./library.R- })
./library.R: if (inherits(tt, "try-error"))
./library.R- if (logical.return)
./library.R- return(FALSE)
./library.R: else stop(gettextf("package/namespace load failed for '%s'",
./library.R: libraryPkgName(package)),
./library.R: call. = FALSE, domain = NA)
./library.R- else {
./library.R: on.exit(do.call("detach", list(name = pkgname)))
./library.R: nogenerics <- checkNoGenerics(env, package)
./library.R- if(warn.conflicts &&
./library.R: !exists(".conflicts.OK", envir = env, inherits = FALSE))
./library.R: checkConflicts(package, pkgname, pkgpath, nogenerics)
./library.R-
./library.R- if(!nogenerics && .isMethodsDispatchOn() &&
./library.R: !identical(pkgname, "package:methods"))
./library.R: methods::cacheMetaData(env, TRUE,
./library.R- searchWhere = .GlobalEnv)
./library.R: runUserHook(package, pkgpath)
./library.R- on.exit()
./library.R- if (logical.return)
./library.R- return(TRUE)
./library.R- else
./library.R- return(invisible(.packages()))
./library.R- }
./library.R- }
./library.R: codeFile <- file.path(which.lib.loc, package, "R",
./library.R- libraryPkgName(package))
./library.R- ## create environment (not attached yet)
./library.R: loadenv <- new.env(hash = TRUE, parent = .GlobalEnv)
./library.R- ## save the package name in the environment
./library.R: assign(".packageName", package, envir = loadenv)
./library.R- ## source file into loadenv
./library.R- if(file.exists(codeFile)) {
./library.R: res <- try(sys.source(codeFile, loadenv,
./library.R- keep.source = keep.source))
./library.R: if(inherits(res, "try-error"))
./library.R: stop(gettextf("unable to load R code in package '%s'",
./library.R: libraryPkgName(package)),
./library.R: call. = FALSE, domain = NA)
./library.R- } else if(verbose)
./library.R: warning(gettextf("package '%s' contains no R code",
./library.R: libraryPkgName(package)), domain = NA)
./library.R- ## lazy-load data sets if required
./library.R: dbbase <- file.path(which.lib.loc, package, "data", "Rdata")
./library.R: if(file.exists(paste(dbbase, ".rdb", sep="")))
./library.R: lazyLoad(dbbase, loadenv)
./library.R- ## lazy-load a sysdata database if present
./library.R: dbbase <- file.path(which.lib.loc, package, "R", "sysdata")
./library.R: if(file.exists(paste(dbbase, ".rdb", sep="")))
./library.R: lazyLoad(dbbase, loadenv)
./library.R- ## now transfer contents of loadenv to an attached frame
./library.R: env <- attach(NULL, pos = pos, name = pkgname)
./library.R- ## detach does not allow character vector args
./library.R: on.exit(do.call("detach", list(name = pkgname)))
./library.R: attr(env, "path") <- file.path(which.lib.loc, package)
./library.R- ## the actual copy has to be done by C code to avoid forcing
./library.R- ## promises that might have been created using delayedAssign().
./library.R: .Internal(lib.fixup(loadenv, env))
./library.R-
./library.R- ## Do this before we use any code from the package
./library.R: bindTranslations(libraryPkgName(package), pkgpath)
./library.R-
./library.R- ## run .First.lib
./library.R: if(exists(".First.lib", mode = "function",
./library.R: envir = env, inherits = FALSE)) {
./library.R: firstlib <- get(".First.lib", mode = "function",
./library.R: envir = env, inherits = FALSE)
./library.R: tt<- try(firstlib(which.lib.loc, package))
./library.R: if(inherits(tt, "try-error"))
./library.R- if (logical.return) return(FALSE)
./library.R: else stop(gettextf(".First.lib failed for '%s'",
./library.R: libraryPkgName(package)), domain = NA)
./library.R- }
./library.R- if(!is.null(firstlib <- getOption(".First.lib")[[package]])){
./library.R: tt<- try(firstlib(which.lib.loc, package))
./library.R: if(inherits(tt, "try-error"))
./library.R- if (logical.return) return(FALSE)
./library.R: else stop(gettextf(".First.lib failed for '%s'",
./library.R: libraryPkgName(package)), domain = NA)
./library.R- }
./library.R: nogenerics <- checkNoGenerics(env, package)
./library.R- if(warn.conflicts &&
./library.R: !exists(".conflicts.OK", envir = env, inherits = FALSE))
./library.R: checkConflicts(package, pkgname, pkgpath, nogenerics)
./library.R-
./library.R- if(!nogenerics && .isMethodsDispatchOn() &&
./library.R: !identical(pkgname, "package:methods"))
./library.R: methods::cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
./library.R: runUserHook(package, pkgpath)
./library.R- on.exit()
./library.R- }
./library.R- if (verbose && !newpackage)
./library.R: warning(gettextf("package '%s' already present in search()",
./library.R: libraryPkgName(package)), domain = NA)
./library.R-
./library.R- }
./library.R- else if(!missing(help)) {
./library.R- if(!character.only)
./library.R- help <- as.character(substitute(help))
./library.R- pkgName <- help[1] # only give help on one package
./library.R: pkgPath <- .find.package(pkgName, lib.loc, verbose = verbose)
./library.R: docFiles <- c(file.path(pkgPath, "Meta", "package.rds"),
./library.R: file.path(pkgPath, "INDEX"))
./library.R- if(file.exists(vignetteIndexRDS <-
./library.R: file.path(pkgPath, "Meta", "vignette.rds")))
./library.R: docFiles <- c(docFiles, vignetteIndexRDS)
./library.R: pkgInfo <- vector(length = 3, mode = "list")
./library.R- readDocFile <- function(f) {
./library.R- if(basename(f) %in% "package.rds") {
./library.R- txt <- .readRDS(f)$DESCRIPTION
./library.R: nm <- paste(names(txt), ":", sep="")
./library.R: formatDL(nm, txt, indent = max(nchar(nm, type="w")) + 3)
./library.R- } else if(basename(f) %in% "vignette.rds") {
./library.R- txt <- .readRDS(f)
./library.R- ## New-style vignette indexes are data frames with more
./library.R- ## info than just the base name of the PDF file and the
./library.R: ## title. For such an index, we give the names of the
./library.R: ## vignettes, their titles, and indicate whether PDFs
./library.R- ## are available.
./library.R- ## The index might have zero rows.
./library.R- if(is.data.frame(txt) && nrow(txt))
./library.R: cbind(basename(gsub("\\.[[:alpha:]]+$", "",
./library.R: txt$File)),
./library.R: paste(txt$Title,
./library.R: paste(rep.int("(source", NROW(txt)),
./library.R: ifelse(txt$PDF != "",
./library.R: ", pdf",
./library.R: ""),
./library.R: ")", sep = "")))
./library.R- else NULL
./library.R- } else
./library.R- readLines(f)
./library.R- }
./library.R- for(i in which(file.exists(docFiles)))
./library.R- pkgInfo[[i]] <- readDocFile(docFiles[i])
./library.R: y <- list(name = pkgName, path = pkgPath, info = pkgInfo)
./library.R- class(y) <- "packageInfo"
./library.R- return(y)
./library.R- }
./library.R- else {
./library.R- ## library():
./library.R- if(is.null(lib.loc))
./library.R- lib.loc <- .libPaths()
./library.R: db <- matrix(character(0), nr = 0, nc = 3)
./library.R- nopkgs <- character(0)
./library.R-
./library.R- for(lib in lib.loc) {
./library.R: a <- .packages(all.available = TRUE, lib.loc = lib)
./library.R- for(i in sort(a)) {
./library.R- ## All packages installed under 2.0.0 should have
./library.R- ## 'package.rds' but we have not checked.
./library.R: file <- system.file("Meta", "package.rds", package = i,
./library.R- lib.loc = lib)
./library.R- title <- if(file != "") {
./library.R- tmp <- .readRDS(file)
./library.R- if(is.list(tmp)) tmp <- tmp$DESCRIPTION
./library.R- tmp["Title"]
./library.R- } else NA
./library.R- if(is.na(title))
./library.R- title <- " ** No title available (pre-2.0.0 install?) ** "
./library.R: db <- rbind(db, cbind(i, lib, title))
./library.R- }
./library.R- if(length(a) == 0)
./library.R: nopkgs <- c(nopkgs, lib)
./library.R- }
./library.R: colnames(db) <- c("Package", "LibPath", "Title")
./library.R- if((length(nopkgs) > 0) && !missing(lib.loc)) {
./library.R: pkglist <- paste(sQuote(nopkgs), collapse = ", ")
./library.R: msg <- sprintf(ngettext(length(nopkgs),
./library.R: "library %s contains no packages",
./library.R: "libraries %s contain no packages"),
./library.R- pkglist)
./library.R: warning(msg, domain=NA)
./library.R- }
./library.R-
./library.R: y <- list(header = NULL, results = db, footer = NULL)
./library.R- class(y) <- "libraryIQR"
./library.R- return(y)
./library.R- }
--
./library.R- TRUE
./library.R- else invisible(.packages())
./library.R-}
./library.R-
./library.R-print.libraryIQR <-
./library.R:function(x, ...)
./library.R-{
./library.R- db <- x$results
./library.R- ## Split according to LibPath.
./library.R- out <- if(nrow(db) == 0)
./library.R- NULL
./library.R: else lapply(split(1 : nrow(db), db[, "LibPath"]),
./library.R: function(ind) db[ind, c("Package", "Title"),
./library.R- drop = FALSE])
./library.R- outFile <- tempfile("RlibraryIQR")
./library.R: outConn <- file(outFile, open = "w")
./library.R- first <- TRUE
./library.R- for(lib in names(out)) {
./library.R: writeLines(gettextf("%sPackages in library '%s':\n",
./library.R: ifelse(first, "", "\n"),
./library.R: lib),
./library.R- outConn)
./library.R: writeLines(formatDL(out[[lib]][, "Package"],
./library.R: out[[lib]][, "Title"]),
./library.R- outConn)
./library.R- first <- FALSE
./library.R- }
--
./library.R- unlink(outFile)
./library.R- message("no packages found")
./library.R- }
./library.R- else {
./library.R- if(!is.null(x$footer))
./library.R: writeLines(c("\n", x$footer), outConn)
./library.R- close(outConn)
./library.R: file.show(outFile, delete.file = TRUE,
./library.R- title = gettext("R packages available"))
./library.R- }
./library.R- invisible(x)
./library.R-}
./library.R-
./library.R-library.dynam <-
./library.R:function(chname, package = NULL, lib.loc = NULL,
./library.R: verbose = getOption("verbose"),
./library.R: file.ext = .Platform$dynlib.ext, ...)
./library.R-{
./library.R- dll_list <- .dynLibs()
./library.R-
./library.R- if(missing(chname) || (nc_chname <- nchar(chname)) == 0)
./library.R- return(dll_list)
./library.R-
./library.R- ## Be defensive about possible system-specific extension for shared
./library.R: ## libraries, although the docs clearly say they should not be
./library.R- ## added.
./library.R- nc_file_ext <- nchar(file.ext)
./library.R: if(substr(chname, nc_chname - nc_file_ext + 1, nc_chname)
./library.R- == file.ext)
./library.R: chname <- substr(chname, 1, nc_chname - nc_file_ext)
./library.R-
./library.R: for(pkg in .find.package(package, lib.loc, verbose = verbose)) {
./library.R: file <- file.path(pkg, "libs",
./library.R: paste(chname, file.ext, sep = ""))
./library.R- if(file.exists(file)) break else file <- ""
./library.R- }
./library.R- if(file == "")
./library.R: stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R: ind <- sapply(dll_list, function(x) x$path == file)
./library.R- if(any(ind)) {
./library.R- if(verbose)
./library.R: message(gettextf("shared library '%s' already loaded", chname),
./library.R- domain = NA)
./library.R- return(invisible(dll_list[[ seq(along = dll_list)[ind] ]]))
./library.R- }
./library.R- if(verbose)
./library.R: message(gettextf("now dyn.load(\"%s\") ...", file), domain = NA)
./library.R: dll <- dyn.load(file, ...)
./library.R: .dynLibs(c(dll_list, list(dll)))
./library.R- invisible(dll)
./library.R-}
./library.R-
./library.R-library.dynam.unload <-
./library.R:function(chname, libpath, verbose = getOption("verbose"),
./library.R- file.ext = .Platform$dynlib.ext)
./library.R-{
./library.R- dll_list <- .dynLibs()
./library.R-
./library.R- if(missing(chname) || (nc_chname <- nchar(chname)) == 0)
./library.R- stop("no shared library was specified")
./library.R-
./library.R- ## Be defensive about possible system-specific extension for shared
./library.R: ## libraries, although the docs clearly say they should not be
./library.R- ## added.
./library.R- nc_file_ext <- nchar(file.ext)
./library.R: if(substr(chname, nc_chname - nc_file_ext + 1, nc_chname)
./library.R- == file.ext)
./library.R: chname <- substr(chname, 1, nc_chname - nc_file_ext)
./library.R-
./library.R: file <- file.path(libpath, "libs",
./library.R: paste(chname, file.ext, sep = ""))
./library.R: pos <- which(sapply(dll_list, function(x) x$path == file))
./library.R- if(!length(pos))
./library.R: stop(gettextf("shared library '%s' was not loaded", chname),
./library.R- domain = NA)
./library.R-
./library.R- if(!file.exists(file))
./library.R: stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R- if(verbose)
./library.R: message(gettextf("now dyn.unload(\"%s\") ...", file), domain = NA)
./library.R- dyn.unload(file)
./library.R- .dynLibs(dll_list[-pos])
./library.R- invisible(dll_list[[pos]])
./library.R-}
./library.R-
./library.R-require <-
./library.R:function(package, quietly = FALSE, warn.conflicts = TRUE,
./library.R: keep.source = getOption("keep.source.pkgs"),
./library.R: character.only = FALSE, version, save = TRUE)
./library.R-{
./library.R- if( !character.only )
./library.R- package <- as.character(substitute(package)) # allowing "require(eda)"
./library.R- if (missing(version)) {
./library.R- pkgName <- package
./library.R: ## dont' care about versions, so accept any
./library.R: s <- sub("_[0-9.-]*", "", search())
./library.R: loaded <- paste("package", pkgName, sep = ":") %in% s
./library.R- } else {
./library.R: pkgName <- manglePackageName(package, version)
./library.R: loaded <- paste("package", pkgName, sep = ":") %in% search()
./library.R- }
./library.R-
./library.R- if (!loaded) {
./library.R- if (!quietly)
./library.R: cat(gettextf("Loading required package: %s\n", package))
./library.R: value <- library(package, character.only = TRUE, logical = TRUE,
./library.R: warn.conflicts = warn.conflicts, keep.source = keep.source,
./library.R- version = version)
./library.R- } else value <- TRUE
./library.R-
./library.R: if(identical(save, FALSE)) {}
./library.R- else {
./library.R- ## update the ".required" variable
./library.R: if(identical(save, TRUE)) {
./library.R- save <- topenv(parent.frame())
./library.R: ## (a package namespace, topLevelEnvironment option or
./library.R- ## .GlobalEnv)
./library.R: if(identical(save, .GlobalEnv)) {
./library.R- ## try to detect call from .First.lib in a package
./library.R- ##
./library.R- ## Although the docs have long and perhaps always had
./library.R: ## .First.lib(libname, pkgname)
./library.R- ## the majority of CRAN packages seems to use arguments
./library.R- ## 'lib' and 'pkg'.
./library.R- objectsInParentFrame <- sort(objects(parent.frame()))
./library.R: if(identical(sort(c("libname", "pkgname")),
./library.R- objectsInParentFrame))
./library.R- save <-
./library.R: as.environment(paste("package:",
./library.R: get("pkgname",
./library.R: parent.frame()),
./library.R- sep = ""))
./library.R: else if(identical(sort(c("lib", "pkg")),
./library.R- objectsInParentFrame))
./library.R- save <-
./library.R: as.environment(paste("package:",
./library.R: get("pkg",
./library.R: parent.frame()),
./library.R- sep = ""))
./library.R- ##
./library.R- ## else either from prompt or in the source for install
./library.R- ## with saved image ?
./library.R- }
./library.R- }
./library.R- else
./library.R- save <- as.environment(save)
./library.R: hasDotRequired <- exists(".required", save, inherits=FALSE)
./library.R- if(!isNamespace(save) || hasDotRequired) { ## so assignment allowed
./library.R- if(hasDotRequired)
./library.R: packages <- unique(c(package, get(".required", save)))
./library.R- else
./library.R- packages <- package
./library.R: assign(".required", packages, save)
./library.R- }
./library.R- }
./library.R- value
./library.R-}
./library.R-
./library.R:.packages <- function(all.available = FALSE, lib.loc = NULL)
./library.R-{
./library.R- if(is.null(lib.loc))
./library.R- lib.loc <- .libPaths()
--
./library.R- ans <- character(0)
./library.R- lib.loc <- lib.loc[file.exists(lib.loc)]
./library.R- valid_package_version_regexp <-
./library.R- .standard_regexps()$valid_package_version
./library.R- for(lib in lib.loc) {
./library.R: a <- list.files(lib, all.files = FALSE, full.names = FALSE)
./library.R- for(nam in a) {
./library.R- ## match .find.packages as to what is a package
./library.R: if(!file.exists(file.path(lib, nam, "DESCRIPTION")))
./library.R- next
./library.R: ## ("If there is no 'DESCRIPTION' file, it ain't a
./library.R- ## package. And that's the only check we have ...")
./library.R- ##
./library.R- ## All packages usable in R-ng must have 'package.rds'.
./library.R- ## (And we do not need to validate these meta data.)
./library.R- ## Should be simply ignore the others?
./library.R- ## (See also above ...)
./library.R: pfile <- file.path(lib, nam, "Meta", "package.rds")
./library.R- info <- if(file.exists(pfile))
./library.R: .readRDS(pfile)$DESCRIPTION[c("Package", "Version")]
./library.R- else
./library.R: try(read.dcf(file.path(lib, nam, "DESCRIPTION"),
./library.R: c("Package", "Version"))[1, ],
./library.R- silent = TRUE)
./library.R: ## In principle, info from 'package.rds' should be
./library.R: ## validated, but we already had counterexamples ...
./library.R- ##
./library.R- ## Shouldn't we warn about packages with bad meta data?
./library.R: if(inherits(info, "try-error")
./library.R- || (length(info) != 2)
./library.R- || any(is.na(info)))
./library.R- next
./library.R: if(regexpr(valid_package_version_regexp,
./library.R- info["Version"]) == -1)
./library.R- next
./library.R- ##
./library.R: ans <- c(ans, nam)
./library.R- ##
./library.R- }
./library.R- }
./library.R- return(unique(ans))
./library.R- } ## else
./library.R- s <- search()
./library.R: return(invisible(substring(s[substr(s, 1, 8) == "package:"], 9)))
./library.R-}
./library.R-
./library.R:.path.package <- function(package = NULL, quiet = FALSE)
./library.R-{
./library.R- if(is.null(package)) package <- .packages()
./library.R- if(length(package) == 0) return(character(0))
./library.R- s <- search()
./library.R- searchpaths <-
./library.R: lapply(1:length(s), function(i) attr(as.environment(i), "path"))
./library.R- searchpaths[[length(s)]] <- system.file()
./library.R: pkgs <- paste("package", package, sep = ":")
./library.R: pos <- match(pkgs, s)
./library.R- if(any(m <- is.na(pos))) {
./library.R- if(!quiet) {
./library.R- if(all(m))
./library.R- stop("none of the packages are loaded")
./library.R- else
./library.R: warning(sprintf(ngettext(as.integer(sum(m)),
./library.R: "package %s is not loaded",
./library.R: "packages %s are not loaded"),
./library.R: paste(package[m], collapse=", ")),
./library.R- domain = NA)
./library.R- }
./library.R- pos <- pos[!m]
./library.R- }
./library.R: unlist(searchpaths[pos], use.names = FALSE)
./library.R-}
./library.R-
./library.R-.find.package <-
./library.R:function(package = NULL, lib.loc = NULL, quiet = FALSE,
./library.R- verbose = getOption("verbose"))
./library.R-{
./library.R- if(is.null(package) && is.null(lib.loc) && !verbose) {
--
./library.R-
./library.R- bad <- character(0)
./library.R- out <- character(0)
./library.R-
./library.R- for(pkg in package) {
./library.R: if(any(grep("_", pkg))) {
./library.R- ## The package "name" contains the version info.
./library.R- ## Note that .packages() is documented to return the "base
./library.R- ## names" of all currently attached packages. In the case
./library.R: ## of versioned installs, this seems to contain both the
./library.R- ## package name *and* the version number (not sure if this
./library.R- ## is a bug or a feature).
./library.R- pkg_has_version <- TRUE
./library.R: pkg_regexp <- paste(pkg, "$", sep = "")
./library.R- }
./library.R- else {
./library.R- pkg_has_version <- FALSE
./library.R: pkg_regexp <- paste(pkg, "($|_)", sep = "")
./library.R- }
./library.R- paths <- character()
./library.R- for(lib in lib.loc) {
./library.R: dirs <- list.files(lib,
./library.R: pattern = paste("^", pkg_regexp,
./library.R: sep = ""),
./library.R- full = TRUE)
./library.R: ## Note that we cannot use tools::file_test() here, as
./library.R- ## cyclic name space dependencies are not supported. Argh.
./library.R: paths <- c(paths,
./library.R- dirs[file.info(dirs)$isdir &
./library.R: file.exists(file.path(dirs,
./library.R- "DESCRIPTION"))])
./library.R- }
./library.R- if(use_attached
./library.R: && any(pos <- grep(paste("^package:", pkg_regexp,
./library.R: sep = ""),
./library.R- search()))) {
./library.R: dirs <- sapply(pos, function(i) {
./library.R- if(is.null(env <- as.environment(i)))
./library.R- system.file()
./library.R- else
./library.R: attr(env, "path")
./library.R- })
./library.R: paths <- c(as.character(dirs), paths)
./library.R- }
./library.R: ## As an extra safety measure, only use the paths we found if
./library.R- ## their DESCRIPTION file registers the given package and has a
./library.R: ## valid version. Actually, we should really exclude all
./library.R: ## candidates with "bad" DESCRIPTION metadata, but we cannot use
./library.R- ## tools:::.check_package_description() for a full check here.
./library.R- ## (But then packages installed with R 2.0.0 or later must have
./library.R- ## valid DESCRIPTION metadata anyways.)
./library.R- if(length(paths)) {
./library.R- paths <- unique(paths)
./library.R- valid_package_version_regexp <-
./library.R- .standard_regexps()$valid_package_version
./library.R: db <- lapply(paths, function(p) {
./library.R- ##
./library.R- ## All packages usable in R-ng must have 'package.rds'.
./library.R- ## (And we do not need to validate these meta data.)
./library.R- ## Should be simply ignore the others?
./library.R- ## (See also above ...)
./library.R: pfile <- file.path(p, "Meta", "package.rds")
./library.R- info <- if(file.exists(pfile))
./library.R: .readRDS(pfile)$DESCRIPTION[c("Package", "Version")]
./library.R- else
./library.R: try(read.dcf(file.path(p, "DESCRIPTION"),
./library.R: c("Package", "Version"))[1, ],
./library.R- silent = TRUE)
./library.R: ## In principle, info from 'package.rds' should be
./library.R: ## validated, but we already had counterexamples ...
./library.R: if(inherits(info, "try-error")
./library.R- || (length(info) != 2)
./library.R- || any(is.na(info)))
./library.R: c(Package=NA, Version=NA) # need dimnames below
./library.R- else
./library.R- info
./library.R- ##
./library.R- })
./library.R: db <- do.call("rbind", db)
./library.R: ok <- (apply(!is.na(db), 1, all)
./library.R: & (db[, "Package"] == sub("_.*", "", pkg))
./library.R: & (regexpr(valid_package_version_regexp,
./library.R: db[, "Version"])) > -1)
./library.R- paths <- paths[ok]
./library.R- }
./library.R- if(length(paths) == 0) {
./library.R: bad <- c(bad, pkg)
./library.R- next
./library.R- }
./library.R- if(length(paths) > 1) {
./library.R- ## If a package was found more than once ...
./library.R- ## * For the case of an exact version match (if the "name"
./library.R: ## already contained the version), use the first path;
./library.R: ## * Otherwise, be consistent with the current logic in
./library.R: ## library(): if there are matching non-versioned paths,
./library.R: ## use the first of these; otherwise, use the first path
./library.R: ## with the highest version. (Actually, we should really
./library.R- ## return the path to the highest version which has
./library.R- ## resolvable dependencies against the current version of
./library.R- ## R ...)
--
./library.R- paths[1]
./library.R- }
./library.R- else if(any(pos <- which(basename(paths) == pkg)))
./library.R- paths[pos][1]
./library.R- else {
./library.R: versions <- package_version(db[ok, "Version"])
./library.R- pos <- min(which(versions == max(versions)))
./library.R- paths <- paths[pos][1]
./library.R- }
./library.R- if(verbose)
./library.R: warning(gettextf("package '%s' found more than once,\nusing the one found in '%s'",
./library.R: pkg, paths), domain = NA)
./library.R- }
./library.R: out <- c(out, paths)
./library.R- }
./library.R-
./library.R- if(!quiet && (length(bad) > 0)) {
./library.R- if(length(out) == 0)
./library.R- stop("none of the packages were found")
./library.R- for(pkg in bad)
./library.R: warning(gettextf("there is no package called '%s'", pkg),
./library.R- domain = NA)
./library.R- }
./library.R-
./library.R- out
./library.R-}
./library.R-
./library.R:print.packageInfo <- function(x, ...)
./library.R-{
./library.R: if(!inherits(x, "packageInfo")) stop("wrong class")
./library.R- outFile <- tempfile("RpackageInfo")
./library.R: outConn <- file(outFile, open = "w")
./library.R- vignetteMsg <-
./library.R: gettextf("Further information is available in the following vignettes in directory '%s':",
./library.R: file.path(x$path, "doc"))
./library.R: headers <- c(gettext("Description:\n\n"),
./library.R: gettext("Index:\n\n"),
./library.R: paste(paste(strwrap(vignetteMsg), collapse = "\n"),
./library.R: "\n\n", sep = ""))
./library.R: footers <- c("\n", "\n", "")
./library.R- formatDocEntry <- function(entry) {
./library.R- if(is.list(entry) || is.matrix(entry))
./library.R: formatDL(entry, style = "list")
./library.R- else
./library.R- entry
./library.R- }
./library.R: writeLines(gettextf("\n\t\tInformation on package '%s'\n", x$name),
./library.R- outConn)
./library.R: for(i in which(!sapply(x$info, is.null))) {
./library.R: writeLines(headers[i], outConn, sep = "")
./library.R: writeLines(formatDocEntry(x$info[[i]]), outConn)
./library.R: writeLines(footers[i], outConn, sep = "")
./library.R- }
./library.R- close(outConn)
./library.R: file.show(outFile, delete.file = TRUE,
./library.R: title = gettextf("Documentation for package '%s'", x$name))
./library.R- invisible(x)
./library.R-}
./library.R-
./library.R:manglePackageName <- function(pkgName, pkgVersion)
./library.R: paste(pkgName, "_", pkgVersion, sep = "")
./library.R-
./library.R-.getRequiredPackages <-
./library.R: function(file="DESCRIPTION", quietly = FALSE, useImports = FALSE)
./library.R-{
./library.R- ## OK to call tools as only used during installation.
./library.R- pkgInfo <- tools:::.split_description(tools:::.read_description(file))
./library.R: .getRequiredPackages2(pkgInfo, quietly, , useImports)
./library.R- invisible()
./library.R-}
./library.R-
./library.R-.getRequiredPackages2 <-
./library.R:function(pkgInfo, quietly = FALSE, lib.loc = NULL, useImports = FALSE)
./library.R-{
./library.R- pkgs <- names(pkgInfo$Depends)
./library.R- if (length(pkgs)) {
./library.R- sch <- search()
./library.R- pkgname <- pkgInfo$DESCRIPTION["Package"]
./library.R- for(pkg in pkgs) {
./library.R- z <- pkgInfo$Depends[[pkg]]
./library.R: if ( !paste("package", pkg, sep = ":") %in% sch ) {
./library.R- if (length(z) > 1) {
./library.R: pfile <- system.file("Meta", "package.rds",
./library.R: package = pkg, lib.loc = lib.loc)
./library.R- if(nchar(pfile) == 0)
./library.R: stop(gettext("package '%s' required by '%s' could not be found",
./library.R: pkg, pkgname),
./library.R: call. = FALSE, domain = NA)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R: if (!eval(parse(text=paste("current", z$op, "z$version"))))
./library.R: stop(gettextf("package '%s' %s was found, but %s %s is required by '%s'",
./library.R: pkg, current, z$op, z$version, pkgname),
./library.R: call. = FALSE, domain = NA)
./library.R- }
./library.R-
./library.R- if (!quietly)
./library.R: cat(gettextf("Loading required package: %s\n", pkg))
./library.R: library(pkg, character.only = TRUE, logical = TRUE,
./library.R- lib.loc = lib.loc) ||
./library.R: stop(gettextf("package '%s' could not be loaded", pkg),
./library.R: call. = FALSE, domain = NA)
./library.R- } else {
./library.R: ## check the required version number, if any
./library.R- if (length(z) > 1) {
./library.R: pfile <- system.file("Meta", "package.rds",
./library.R: package = pkg, lib.loc = lib.loc)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R: if (!eval(parse(text=paste("current", z$op, "z$version"))))
./library.R: stop(gettextf("package '%s' %s is loaded, but %s %s is required by '%s'",
./library.R: pkg, current, z$op, z$version, pkgname),
./library.R: call. = FALSE, domain = NA)
./library.R- }
./library.R- }
./library.R- }
./library.R- }
./library.R- if(useImports) {
./library.R- nss <- names(pkgInfo$Imports)
./library.R: for(ns in nss) loadNamespace(ns, lib.loc)
./library.R- }
./library.R-}
--
./license.R-licence <- license <- function() {
./license.R- cat("\nThis software is distributed under the terms of the GNU GENERAL\n")
./license.R: cat("PUBLIC LICENSE Version 2, June 1991. The terms of this license\n")
./license.R- cat("are in a file called COPYING which you should have received with\n")
./license.R- cat("this software.\n")
./license.R- cat("\n")
./license.R: cat("If you have not received a copy of this file, you can obtain one\n")
./license.R: cat("via WWW at http://www.gnu.org/copyleft/gpl.html, or by writing to:\n")
./license.R- cat("\n")
./license.R: cat(" The Free Software Foundation, Inc.,\n")
./license.R: cat(" 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.\n")
./license.R- cat("\n")
./license.R: cat("A small number of files (the API header files and export files,\n")
./license.R- cat("listed in R_HOME/COPYRIGHTS) are distributed under the\n")
./license.R- cat("LESSER GNU GENERAL PUBLIC LICENSE version 2.1.\n")
./license.R- cat("This can be obtained via WWW at\n")
./license.R: cat("http://www.gnu.org/copyleft/lgpl.html, or by writing to the\n")
./license.R- cat("address above\n")
./license.R- cat("\n")
./license.R- cat("``Share and Enjoy.''\n\n")
--
./load.R:load <- function (file, envir = parent.frame())
./load.R-{
./load.R- if (is.character(file)) {
./load.R: ## As zlib is available just open with gzfile, whether file
./load.R- ## is compressed or not; zlib works either way.
./load.R- con <- gzfile(file)
./load.R- on.exit(close(con))
./load.R- }
./load.R: else if (inherits(file, "connection")) con <- gzcon(file)
./load.R- else stop("bad file argument")
./load.R- if(!isOpen(con)) {
./load.R- ## code below assumes that the connection is open ...
./load.R: open(con, "rb")
./load.R- }
./load.R-
./load.R: magic <- readChar(con, 5)
./load.R- if(nchar(magic) == 0) {
./load.R- warning("no input is available")
./load.R- return(character(0))
./load.R- }
./load.R: if (regexpr("RD[AX]2\n", magic) == -1) {
./load.R- ## a check while we still know the args
./load.R: if(regexpr("RD[ABX][12]\r", magic) == 1)
./load.R: stop("input has been corrupted, with LF replaced by CR")
./load.R: ## Not a version 2 magic number, so try the old way.
./load.R- if (is.character(file)) {
./load.R- close(con)
./load.R- on.exit()
./load.R- }
./load.R- else stop("the input does not start with a magic number compatible with loading from a connection")
./load.R: .Internal(load(file, envir))
./load.R- }
./load.R: else .Internal(loadFromConn(con, envir))
./load.R-}
./load.R-
./load.R:save <- function(..., list = character(0),
./load.R: file = stop("'file' must be specified"),
./load.R: ascii = FALSE, version = NULL, envir = parent.frame(),
./load.R- compress = FALSE)
./load.R-{
./load.R- opts <- getOption("save.defaults")
--
./load.R- if (missing(ascii) && ! is.null(opts$ascii))
./load.R- ascii <- opts$ascii
./load.R- if (missing(version)) version <- opts$version
./load.R-
./load.R- names <- as.character( substitute( list(...)))[-1]
./load.R: list<- c(list, names)
./load.R- if (! is.null(version) && version == 1)
./load.R: invisible(.Internal(save(list, file, ascii, version, envir)))
./load.R- else {
./load.R- if (is.character(file)) {
./load.R- if (file == "") stop("'file' must be non-empty string")
./load.R: if (compress) con <- gzfile(file, "wb")
./load.R: else con <- file(file, "wb")
./load.R- on.exit(close(con))
./load.R- }
./load.R: else if (inherits(file, "connection"))
./load.R- con <- file
./load.R- else stop("bad file argument")
./load.R- if(isOpen(con) && summary(con)$text != "binary")
./load.R- stop("can only save to a binary connection")
./load.R: invisible(.Internal(saveToConn(list, con, ascii, version, envir)))
./load.R- }
./load.R-}
./load.R-
./load.R:save.image <- function (file = ".RData", version = NULL, ascii = FALSE,
./load.R: compress = FALSE, safe = TRUE) {
./load.R- if (! is.character(file) || file == "")
./load.R- stop("`file' must be non-empty string")
./load.R-
--
./load.R- if (missing(version)) version <- opts$version
./load.R-
./load.R- if (safe) {
./load.R- ## find a temporary file name in the same directory so we can
./load.R- ## rename it to the final output file on success
./load.R: outfile <- paste(file, "Tmp", sep = "")
./load.R- i <- 0;
./load.R- while (file.exists(outfile)) {
./load.R- i <- i + 1
./load.R: outfile <- paste(file, "Tmp", i, sep = "")
./load.R- }
./load.R- }
./load.R- else outfile <- file
./load.R-
./load.R- on.exit(file.remove(outfile))
./load.R: save(list = ls(envir = .GlobalEnv, all.names = TRUE), file = outfile,
./load.R: version = version, ascii = ascii, compress = compress,
./load.R- envir = .GlobalEnv)
./load.R- if (safe)
./load.R: if (! file.rename(outfile, file)) {
./load.R- on.exit()
./load.R: stop("image could not be renamed and is left in ", outfile)
./load.R- }
./load.R- on.exit()
./load.R-}
./load.R-
./load.R:sys.load.image <- function(name, quiet) {
./load.R- if (file.exists(name)) {
./load.R: load(name, envir = .GlobalEnv)
./load.R- if (! quiet)
./load.R- cat(gettext("[Previously saved workspace restored]\n\n"))
./load.R- }
--
./locales.R-Sys.getlocale <- function(category = "LC_ALL")
./locales.R-{
./locales.R: category <- match(category, c("LC_ALL", "LC_COLLATE", "LC_CTYPE",
./locales.R: "LC_MONETARY", "LC_NUMERIC", "LC_TIME"))
./locales.R- if(is.na(category)) stop("invalid 'category' argument")
./locales.R- .Internal(getlocale(category))
./locales.R-}
./locales.R-
./locales.R:Sys.setlocale <- function(category = "LC_ALL", locale = "")
./locales.R-{
./locales.R: category <- match(category, c("LC_ALL", "LC_COLLATE", "LC_CTYPE",
./locales.R: "LC_MONETARY", "LC_NUMERIC", "LC_TIME"))
./locales.R- if(is.na(category)) stop("invalid 'category' argument")
./locales.R: .Internal(setlocale(category, locale))
./locales.R-}
./locales.R-
./locales.R-Sys.localeconv <- function() .Internal(localeconv())
--
./log.R:log10 <- function(x) log(x,10)
./log.R:log2 <- function(x) log(x,2)
--
./lower.tri.R:lower.tri <- function(x, diag = FALSE)
./lower.tri.R-{
./lower.tri.R- x <- as.matrix(x)
./lower.tri.R- if(diag) row(x) >= col(x)
--
./mapply.R:mapply<-function(FUN,..., MoreArgs=NULL, SIMPLIFY=TRUE, USE.NAMES=TRUE)
./mapply.R-{
./mapply.R- FUN <- match.fun(FUN)
./mapply.R- dots <- list(...)
./mapply.R-
./mapply.R: answer<-.Call("do_mapply", FUN, dots, MoreArgs, environment(),
./mapply.R- PACKAGE="base")
./mapply.R-
./mapply.R- if (USE.NAMES && length(dots) && is.character(dots[[1]]) &&
./mapply.R- is.null(names(answer))) names(answer) <- dots[[1]]
./mapply.R- if (SIMPLIFY && length(answer) &&
./mapply.R: length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
./mapply.R- if (common.len == 1)
./mapply.R: unlist(answer, recursive = FALSE)
./mapply.R- else if (common.len > 1)
./mapply.R: array(unlist(answer, recursive = FALSE),
./mapply.R: dim = c(common.len, max(sapply(dots,length))),
./mapply.R: dimnames = list(names(answer[[1]]), names(answer)))
./mapply.R- else answer
./mapply.R- }
./mapply.R- else answer
--
./match.R-## till R 1.1.1:
./match.R:match <- function(x, table, nomatch=NA)
./match.R: .Internal(match(as.character(x), as.character(table), nomatch))
./match.R-## New:
./match.R:match <- function(x, table, nomatch=NA, incomparables = FALSE) {
./match.R- if(!is.logical(incomparables) || incomparables)
./match.R- .NotYetUsed("incomparables != FALSE")
./match.R: .Internal(match(if(is.factor(x)) as.character(x) else x,
./match.R: if(is.factor(table)) as.character(table) else table,
./match.R- nomatch))
./match.R-}
./match.R-
./match.R-match.call <-
./match.R: function(definition=NULL, call=sys.call(sys.parent()), expand.dots=TRUE)
./match.R: .Internal(match.call(definition,call,expand.dots))
./match.R-
./match.R-pmatch <-
./match.R: function(x, table, nomatch=NA, duplicates.ok=FALSE)
./match.R-{
./match.R: y <- .Internal(pmatch(x,table,duplicates.ok))
./match.R- y[y == 0] <- nomatch
./match.R- y
./match.R-}
./match.R-
./match.R:"%in%" <- function(x, table) match(x, table, nomatch = 0) > 0
./match.R-
./match.R:match.arg <- function (arg, choices) {
./match.R- if (missing(choices)) {
./match.R- formal.args <- formals(sys.function(sys.parent()))
./match.R- choices <- eval(formal.args[[deparse(substitute(arg))]])
./match.R- }
./match.R- if (all(arg == choices)) return(choices[1])
./match.R: i <- pmatch(arg, choices)
./match.R- if (is.na(i))
./match.R: stop("'arg' should be one of ", paste(choices, collapse = ", "))
./match.R- if (length(i) > 1) stop("there is more than one match in 'match.arg'")
./match.R- choices[i]
./match.R-}
./match.R-
./match.R-charmatch <-
./match.R: function(x, table, nomatch=NA)
./match.R-{
./match.R: y <- .Internal(charmatch(x,table))
./match.R- y[is.na(y)] <- nomatch
./match.R- y
./match.R-}
./match.R-
./match.R-char.expand <-
./match.R: function(input, target, nomatch = stop("no match"))
./match.R-{
./match.R- if(length(input) != 1)
./match.R- stop("'input' must have length 1")
./match.R- if(!(is.character(input) && is.character(target)))
./match.R- stop("'input' and 'target' must be character vectors")
./match.R: y <- .Internal(charmatch(input,target))
./match.R- if(any(is.na(y))) eval(nomatch)
./match.R- target[y]
./match.R-}
--
./match.fun.R:### clean up FUN arguments to *apply, outer, sweep, etc.
./match.fun.R-### note that this grabs two levels back and is not designed
./match.fun.R-### to be called at top level
./match.fun.R:match.fun <- function (FUN, descend = TRUE)
./match.fun.R-{
./match.fun.R- if ( is.function(FUN) )
./match.fun.R- return(FUN)
./match.fun.R- if (!(is.character(FUN) && length(FUN) == 1 || is.symbol(FUN))) {
./match.fun.R- ## Substitute in parent
./match.fun.R- FUN <- eval.parent(substitute(substitute(FUN)))
./match.fun.R- if (!is.symbol(FUN))
./match.fun.R: stop(gettextf("'%s' is not a function, character or symbol",
./match.fun.R: deparse(FUN)), domain = NA)
./match.fun.R- }
./match.fun.R- envir <- parent.frame(2)
./match.fun.R- if( descend )
./match.fun.R: FUN <- get(as.character(FUN), mode = "function", env=envir)
./match.fun.R- else {
./match.fun.R: FUN <- get(as.character(FUN), mode = "any", env=envir)
./match.fun.R- if( !is.function(FUN) )
./match.fun.R: stop(gettextf("found non-function '%s'", FUN), domain = NA)
./match.fun.R- }
./match.fun.R- return(FUN)
./match.fun.R-}
--
./matrix.R:matrix <- function(data=NA, nrow=1, ncol=1, byrow=FALSE, dimnames=NULL) {
./matrix.R- data <- as.vector(data)
./matrix.R- if(missing(nrow))
./matrix.R- nrow <- ceiling(length(data)/ncol)
./matrix.R- else if(missing(ncol))
./matrix.R- ncol <- ceiling(length(data)/nrow)
./matrix.R: x <- .Internal(matrix(data, nrow, ncol, byrow))
./matrix.R- dimnames(x) <- dimnames
./matrix.R- x
./matrix.R-}
--
./matrix.R-ncol <- function(x) dim(x)[2]
./matrix.R-
./matrix.R-NROW <- function(x) if(is.array(x)||is.data.frame(x)) nrow(x) else length(x)
./matrix.R-NCOL <- function(x) if(is.array(x) && length(dim(x)) > 1||is.data.frame(x)) ncol(x) else as.integer(1)
./matrix.R-
./matrix.R:rownames <- function(x, do.NULL = TRUE, prefix = "row")
./matrix.R-{
./matrix.R- dn <- dimnames(x)
./matrix.R- if(!is.null(dn[[1]]))
./matrix.R- dn[[1]]
./matrix.R- else {
./matrix.R: if(do.NULL) NULL else paste(prefix, seq(length=NROW(x)), sep="")
./matrix.R- }
./matrix.R-}
./matrix.R-
./matrix.R:"rownames<-" <- function(x, value)
./matrix.R-{
./matrix.R- dn <- dimnames(x)
./matrix.R- if(is.null(dn)) {
./matrix.R- if(is.null(value)) return(x)
./matrix.R- if((nd <- length(dim(x))) < 1)
./matrix.R- stop("attempt to set rownames on object with no dimensions")
./matrix.R: dn <- vector("list", nd)
./matrix.R- }
./matrix.R- if(length(dn) < 1)
./matrix.R- stop("attempt to set rownames on object with no dimensions")
./matrix.R- if(is.null(value)) dn[1] <- list(NULL) else dn[[1]] <- value
./matrix.R- dimnames(x) <- dn
./matrix.R- x
./matrix.R-}
./matrix.R-
./matrix.R:colnames <- function(x, do.NULL = TRUE, prefix = "col")
./matrix.R-{
./matrix.R- dn <- dimnames(x)
./matrix.R- if(!is.null(dn[[2]]))
./matrix.R- dn[[2]]
./matrix.R- else {
./matrix.R: if(do.NULL) NULL else paste(prefix, seq(length=NCOL(x)), sep="")
./matrix.R- }
./matrix.R-}
./matrix.R-
./matrix.R:"colnames<-" <- function(x, value)
./matrix.R-{
./matrix.R- dn <- dimnames(x)
./matrix.R- if(is.null(dn)) {
./matrix.R- if(is.null(value)) return(x)
./matrix.R- if((nd <- length(dim(x))) < 2)
./matrix.R- stop("attempt to set colnames on object with less than two dimensions")
./matrix.R: dn <- vector("list", nd)
./matrix.R- }
./matrix.R- if(length(dn) < 2)
./matrix.R- stop("attempt to set colnames on object with less than two dimensions")
./matrix.R- if(is.null(value)) dn[2] <- list(NULL) else dn[[2]] <- value
./matrix.R- dimnames(x) <- dn
./matrix.R- x
./matrix.R-}
./matrix.R-
./matrix.R:row <- function(x, as.factor=FALSE) {
./matrix.R: if(as.factor) factor(.Internal(row(x)), labels=rownames(x))
./matrix.R- else .Internal(row(x))
./matrix.R-}
./matrix.R-
./matrix.R:col <- function(x, as.factor=FALSE) {
./matrix.R: if(as.factor) factor(.Internal(col(x)), labels=colnames(x))
./matrix.R- else .Internal(col(x))
./matrix.R-}
./matrix.R-
./matrix.R:crossprod <- function(x, y=NULL) .Internal(crossprod(x,y))
./matrix.R-
./matrix.R-t <- function(x) UseMethod("t")
./matrix.R-## t.default is
--
./max.col.R-max.col <- function(m)
./max.col.R-{
./max.col.R- m <- as.matrix(m)
./max.col.R- n <- nrow(m)
./max.col.R: .C("R_max_col",
./max.col.R: as.double(m),
./max.col.R: n,
./max.col.R: ncol(m),
./max.col.R: rmax = integer(n),
./max.col.R: NAOK = TRUE,
./max.col.R: DUP = FALSE,
./max.col.R- PACKAGE = "base")$rmax
./max.col.R-}
./max.col.R-
--
./mean.R:mean <- function(x, ...) UseMethod("mean")
./mean.R-
./mean.R:mean.default <- function(x, trim = 0, na.rm = FALSE, ...)
./mean.R-{
./mean.R- if(!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
./mean.R- warning("argument is not numeric or logical: returning NA")
--
./mean.R- trim <- trim[1]
./mean.R- n <- length(x)
./mean.R- if(trim > 0 && n > 0) {
./mean.R- if(is.complex(x))
./mean.R- stop("trimmed means are not defined for complex data")
./mean.R: if(trim >= 0.5) return(median(x, na.rm=FALSE))
./mean.R- lo <- floor(n*trim)+1
./mean.R- hi <- n+1-lo
./mean.R: x <- sort(x, partial=unique(c(lo, hi)))[lo:hi]
./mean.R- n <- hi-lo+1
./mean.R- }
./mean.R: ## sum(int) can overflow, so convert here.
./mean.R- if(is.integer(x)) sum(as.numeric(x))/n else sum(x)/n
./mean.R-}
./mean.R-
./mean.R:mean.data.frame <- function(x, ...) sapply(x, mean, ...)
--
./merge.R:merge <- function(x, y, ...) UseMethod("merge")
./merge.R-
./merge.R:merge.default <- function(x, y, ...)
./merge.R: merge(as.data.frame(x), as.data.frame(y), ...)
./merge.R-
./merge.R-merge.data.frame <-
./merge.R: function(x, y, by = intersect(names(x), names(y)), by.x = by, by.y = by,
./merge.R: all = FALSE, all.x = all, all.y = all,
./merge.R: sort = TRUE, suffixes = c(".x",".y"), ...)
./merge.R-{
./merge.R: fix.by <- function(by, df)
./merge.R- {
./merge.R- ## fix up 'by' to be a valid set of cols by number: 0 is row.names
./merge.R- by <- as.vector(by)
./merge.R- nc <- ncol(df)
./merge.R- if(is.character(by))
./merge.R: by <- match(by, c("row.names", names(df))) - 1
./merge.R- else if(is.numeric(by)) {
./merge.R- if(any(by < 0) || any(by > nc))
./merge.R- stop("'by' must match numbers of columns")
--
./merge.R- unique(by)
./merge.R- }
./merge.R-
./merge.R- nx <- nrow(x <- as.data.frame(x)); ny <- nrow(y <- as.data.frame(y))
./merge.R- if (nx == 0 || ny == 0) stop("no rows to match")
./merge.R: by.x <- fix.by(by.x, x)
./merge.R: by.y <- fix.by(by.y, y)
./merge.R- if((l.b <- length(by.x)) != length(by.y))
./merge.R- stop("'by.x' and 'by.y' specify different numbers of columns")
./merge.R- if(l.b == 0) {
./merge.R- ## was: stop("no columns to match on")
./merge.R- ## return the cartesian product of x and y :
./merge.R: ij <- expand.grid(1:nx, 1:ny)
./merge.R: res <- cbind(x[ij[,1], , drop = FALSE], y[ij[,2], , drop = FALSE])
./merge.R- }
./merge.R- else {
./merge.R- if(any(by.x == 0)) {
./merge.R: x <- cbind(Row.names = row.names(x), x)
./merge.R- by.x <- by.x + 1
./merge.R- }
./merge.R- if(any(by.y == 0)) {
./merge.R: y <- cbind(Row.names = row.names(y), y)
./merge.R- by.y <- by.y + 1
./merge.R- }
./merge.R- row.names(x) <- 1:nx
./merge.R- row.names(y) <- 1:ny
./merge.R- ## create keys from 'by' columns:
./merge.R- if(l.b == 1) { # (be faster)
./merge.R: bx <- x[, by.x]; if(is.factor(bx)) bx <- as.character(bx)
./merge.R: by <- y[, by.y]; if(is.factor(by)) by <- as.character(by)
./merge.R- } else {
./merge.R- ## Do these together for consistency in as.character.
./merge.R- ## Use same set of names.
./merge.R: bx <- x[, by.x, drop=FALSE]; by <- y[, by.y, drop=FALSE]
./merge.R: names(bx) <- names(by) <- paste("V", 1:ncol(bx), sep="")
./merge.R: bz <- do.call("paste", c(rbind(bx, by), sep = "\r"))
./merge.R- bx <- bz[1:nx]
./merge.R- by <- bz[nx + (1:ny)]
./merge.R- }
./merge.R: comm <- match(bx, by, 0)
./merge.R- bxy <- bx[comm > 0] # the keys which are in both
./merge.R: xinds <- match(bx, bxy, 0)
./merge.R: yinds <- match(by, bxy, 0)
./merge.R- ## R-only solution {when !all.x && !all.y} :
./merge.R: ## o <- outer(xinds, yinds, function(x, y) (x > 0) & x==y)
./merge.R: ## m <- list(xi = row(o)[o], yi = col(o)[o])
./merge.R: m <- .Internal(merge(xinds, yinds, all.x, all.y))
./merge.R- nm <- nm.x <- names(x)[-by.x]
./merge.R- nm.by <- names(x)[by.x]
./merge.R- nm.y <- names(y)[-by.y]
--
./merge.R- if(all.y) all.y <- (nyy <- length(m$y.alone)) > 0
./merge.R- lxy <- length(m$xi) # == length(m$yi)
./merge.R- ## x = [ by | x ] :
./merge.R- has.common.nms <- any(cnm <- nm.x %in% nm.y)
./merge.R- if(has.common.nms)
./merge.R: nm.x[cnm] <- paste(nm.x[cnm], suffixes[1], sep="")
./merge.R: x <- x[c(m$xi, if(all.x) m$x.alone),
./merge.R: c(by.x, (1:ncx)[-by.x]), drop=FALSE]
./merge.R: names(x) <- c(nm.by, nm.x)
./merge.R- if(all.y) { ## add the 'y.alone' rows to x[]
./merge.R- ## need to have factor levels extended as well -> using [cr]bind
./merge.R: ya <- y[m$y.alone, by.y, drop=FALSE]
./merge.R- names(ya) <- nm.by
./merge.R: x <- rbind(x, cbind(ya, matrix(NA, nyy, ncx-l.b,
./merge.R: dimnames=list(NULL,nm.x))))
./merge.R- }
./merge.R- ## y (w/o 'by'):
./merge.R- if(has.common.nms) {
./merge.R- cnm <- nm.y %in% nm
./merge.R: nm.y[cnm] <- paste(nm.y[cnm], suffixes[2], sep="")
./merge.R- }
./merge.R: y <- y[c(m$yi, if(all.x) rep.int(1:1, nxx), if(all.y) m$y.alone),
./merge.R: -by.y, drop = FALSE]
./merge.R- if(all.x)
./merge.R- for(i in seq(along = y))
./merge.R- ## do it this way to invoke methods for e.g. factor
./merge.R- is.na(y[[i]]) <- (lxy+1):(lxy+nxx)
./merge.R-
./merge.R- if(has.common.nms) names(y) <- nm.y
./merge.R: res <- cbind(x, y)
./merge.R-
./merge.R- if (sort)
./merge.R- res <- res[if(all.x || all.y)## does NOT work
./merge.R: do.call("order", x[, 1:l.b, drop=FALSE])
./merge.R: else sort.list(bx[m$xi]),, drop=FALSE]
./merge.R- }
./merge.R-
./merge.R- row.names(res) <- seq(length=nrow(res))
--
./message.R-simpleMessage <-
./message.R:function(message, call = NULL)
./message.R: structure(list(message = message, call = call),
./message.R: class=c("condition", "message", "simpleMessage"))
./message.R-
./message.R-suppressMessages <-
./message.R-function(expr)
./message.R: withCallingHandlers(expr,
./message.R- message = function(c)
./message.R- invokeRestart("muffleMessage"))
./message.R-
./message.R-message <-
./message.R:function(..., domain = NULL)
./message.R-{
./message.R- args <- list(...)
./message.R: if (length(args) == 1 && inherits(args[[1]], "condition"))
./message.R- cond <- args[[1]]
./message.R- else {
./message.R- if(length(args) > 0) {
./message.R: args <- lapply(list(...), as.character)
./message.R- if(is.null(domain) || !is.na(domain))
./message.R: args <- .Internal(gettext(domain, unlist(args)))
./message.R: message <- paste(args, collapse = "")
./message.R- }
./message.R- else message <- ""
./message.R- call <- sys.call()
./message.R: cond <- simpleMessage(message, call)
./message.R- }
./message.R- defaultHandler <- function(c) {
./message.R- ## Maybe use special connection here?
./message.R: writeLines(conditionMessage(c), stderr())
./message.R- }
./message.R- withRestarts({
./message.R- signalCondition(cond)
./message.R- ## We don't get to the default handler if the signal
./message.R: ## is handled with a non-local exit, e.g. by
./message.R- ## invoking the muffleMessage restart.
./message.R- defaultHandler(cond)
./message.R: }, muffleMessage = function() NULL)
./message.R- invisible(NULL)
./message.R-}
--
./methodsSupport.R:trace <- function(what, tracer, exit, at, print, signature, where = topenv(parent.frame()), edit = FALSE) {
./methodsSupport.R- needsAttach <- nargs() > 1 && !.isMethodsDispatchOn()
./methodsSupport.R- if(needsAttach) {
./methodsSupport.R- ns <- try(loadNamespace("methods"))
./methodsSupport.R- if(isNamespace(ns))
./methodsSupport.R- methods::message("(loaded the methods namespace)")
./methodsSupport.R- else
./methodsSupport.R: stop("Tracing functions requires the methods package, but unable to load methods namespace")
./methodsSupport.R- }
./methodsSupport.R- else if(nargs() == 1)
./methodsSupport.R- return(.primTrace(what))
./methodsSupport.R- tState <- tracingState(FALSE)
./methodsSupport.R: ## now call the version in the methods package, to ensure we get
./methodsSupport.R: ## the correct name space (e.g., correct version of class())
./methodsSupport.R- call <- sys.call()
./methodsSupport.R- call[[1]] <- quote(methods::.TraceWithMethods)
./methodsSupport.R- call$where <- where
--
./methodsSupport.R- on.exit() ## no error
./methodsSupport.R- tracingState(tState)
./methodsSupport.R- value
./methodsSupport.R-}
./methodsSupport.R-
./methodsSupport.R:untrace <- function(what, signature = NULL, where = topenv(parent.frame())) {
./methodsSupport.R- ## NOTE: following test is TRUE after loadNamespace("methods") (even if not in search())
./methodsSupport.R- MethodsDispatchOn <- .isMethodsDispatchOn()
./methodsSupport.R- if(MethodsDispatchOn) {
--
./methodsSupport.R- on.exit(tracingState(tState))
./methodsSupport.R- }
./methodsSupport.R- if(!MethodsDispatchOn)
./methodsSupport.R- return(.primUntrace(what)) ## can't have called trace except in primitive form
./methodsSupport.R- ## at this point we can believe that the methods namespace was successfully loaded
./methodsSupport.R: ## now call the version in the methods package, to ensure we get
./methodsSupport.R: ## the correct name space (e.g., correct version of class())
./methodsSupport.R- call <- sys.call()
./methodsSupport.R- call[[1]] <- quote(methods::.TraceWithMethods)
./methodsSupport.R- call$where <- where
--
./methodsSupport.R- tracingState(tState)
./methodsSupport.R- invisible(value)
./methodsSupport.R-}
./methodsSupport.R-
./methodsSupport.R-.isMethodsDispatchOn <- function(onOff = NULL)
./methodsSupport.R: .Call("R_isMethodsDispatchOn", onOff, PACKAGE = "base")
./methodsSupport.R-
./methodsSupport.R-tracingState <- function( on = NULL)
./methodsSupport.R: .Call("R_traceOnOff", on, PACKAGE = "base")
--
./mode.R-mode <- function(x) {
./mode.R- if(is.expression(x)) return("expression")
./mode.R- if(is.call(x))
./mode.R: return(switch(deparse(x[[1]])[1],
./mode.R: "(" = "(",
./mode.R- ## otherwise
./mode.R- "call"))
./mode.R- if(is.name(x)) "name" else
./mode.R: switch(tx <- typeof(x),
./mode.R: double=, integer= "numeric",# 'real=' dropped, 2000/Jan/14
./mode.R: closure=, builtin=, special= "function",
./mode.R- ## otherwise
./mode.R- tx)
./mode.R-}
./mode.R-"storage.mode<-" <-
./mode.R:"mode<-" <- function(x, value)
./mode.R-{
./mode.R: mde <- paste("as.",value,sep="")
./mode.R- atr <- attributes(x)
./mode.R: x <- eval(call(mde,x), parent.frame())
./mode.R- attributes(x) <- atr
./mode.R: attr(x, "Csingle") <- if(value == "single") TRUE # else NULL
./mode.R- x
./mode.R-}
./mode.R-storage.mode <- function(x) {
--
./names.R-names <- function(x) UseMethod("names")
./names.R-names.default <- function(x) .Internal(names(x))
./names.R-
./names.R:"names<-" <- function(x, value) UseMethod("names<-")
./names.R:"names<-.default" <- function(x, value) .Internal("names<-"(x, value))
--
./namespace.R-## give the base namespace a table for registered methods
./namespace.R:".__S3MethodsTable__." <- new.env(hash = TRUE, parent = NULL)
./namespace.R-
./namespace.R-getNamespace <- function(name) {
./namespace.R- ns <- .Internal(getRegisteredNamespace(as.name(name)))
./namespace.R- if (! is.null(ns)) ns
./namespace.R: else tryCatch(loadNamespace(name),
./namespace.R- error = function(e) {
./namespace.R- # This assignment is needed because 'name' contains
./namespace.R- # version as second component when called from internal
./namespace.R- # serialization code
./namespace.R- name <- name[1]
./namespace.R: if (name %in% c("ctest","eda","modreg","mva","nls",
./namespace.R: "stepfun","ts")) {
./namespace.R- old <- "stats"
./namespace.R: warning(gettextf("package '%s' has been merged into '%s'",
./namespace.R: name, old),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R- return(getNamespace("stats"))
./namespace.R- }
./namespace.R: else stop(e, domain = NA)
./namespace.R- })
./namespace.R-}
./namespace.R-
./namespace.R-loadedNamespaces <- function()
./namespace.R: ls(env = .Internal(getNamespaceRegistry()), all = TRUE)
./namespace.R-
./namespace.R-getNamespaceName <- function(ns) {
./namespace.R- ns <- asNamespace(ns)
./namespace.R- if (isBaseNamespace(ns)) "base"
./namespace.R: else getNamespaceInfo(ns, "spec")["name"]
./namespace.R-}
./namespace.R-
./namespace.R-getNamespaceVersion <- function(ns) {
./namespace.R- ns <- asNamespace(ns)
./namespace.R- if (isBaseNamespace(ns))
./namespace.R: c(version = paste(R.version$major, R.version$minor, sep="."))
./namespace.R: else getNamespaceInfo(ns, "spec")["version"]
./namespace.R-}
./namespace.R-
./namespace.R-getNamespaceExports <- function(ns) {
./namespace.R- ns <- asNamespace(ns)
./namespace.R: if (isBaseNamespace(ns)) ls(NULL, all = TRUE)
./namespace.R: else ls(getNamespaceInfo(ns, "exports"), all = TRUE)
./namespace.R-}
./namespace.R-
./namespace.R-getNamespaceImports <- function(ns) {
./namespace.R- ns <- asNamespace(ns)
./namespace.R- if (isBaseNamespace(ns)) NULL
./namespace.R: else getNamespaceInfo(ns, "imports")
./namespace.R-}
./namespace.R-
./namespace.R-getNamespaceUsers <- function(ns) {
./namespace.R- nsname <- getNamespaceName(asNamespace(ns))
./namespace.R- users <- character(0)
./namespace.R- for (n in loadedNamespaces()) {
./namespace.R- inames <- names(getNamespaceImports(n))
./namespace.R: if (match(nsname, inames, 0))
./namespace.R: users <- c(n, users)
./namespace.R- }
./namespace.R- users
./namespace.R-}
./namespace.R-
./namespace.R:getExportedValue <- function(ns, name) {
./namespace.R: getInternalExportName <- function(name, ns) {
./namespace.R: exports <- getNamespaceInfo(ns, "exports")
./namespace.R: if (! exists(name, env = exports, inherits = FALSE))
./namespace.R: stop(gettextf("'%s' is not an exported object from 'namespace:%s'",
./namespace.R: name, getNamespaceName(ns)),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R: get(name, env = exports, inherits = FALSE)
./namespace.R- }
./namespace.R- ns <- asNamespace(ns)
./namespace.R: if (isBaseNamespace(ns)) get(name, env = ns, inherits=FALSE)
./namespace.R: else get(getInternalExportName(name, ns), env = ns)
./namespace.R-}
./namespace.R-
./namespace.R:"::" <- function(pkg, name){
./namespace.R- pkg <- as.character(substitute(pkg))
./namespace.R- name <- as.character(substitute(name))
./namespace.R: getExportedValue(pkg, name)
./namespace.R-}
./namespace.R-
./namespace.R:":::" <- function(pkg, name){
./namespace.R- pkg <- as.character(substitute(pkg))
./namespace.R- name <- as.character(substitute(name))
./namespace.R: get(name, env = asNamespace(pkg), inherits=FALSE)
./namespace.R-}
./namespace.R-
./namespace.R:attachNamespace <- function(ns, pos = 2, dataPath = NULL) {
./namespace.R: runHook <- function(hookname, env, ...) {
./namespace.R: if (exists(hookname, envir = env, inherits = FALSE)) {
./namespace.R: fun <- get(hookname, envir = env, inherits = FALSE)
./namespace.R- if (! is.null(try({ fun(...); NULL})))
./namespace.R: stop(gettextf("%s failed in 'attachNamespace'", hookname),
./namespace.R- call. = FALSE)
./namespace.R- }
./namespace.R- }
./namespace.R: ns <- asNamespace(ns, base.OK = FALSE)
./namespace.R- nsname <- getNamespaceName(ns)
./namespace.R: nspath <- getNamespaceInfo(ns, "path")
./namespace.R: attname <- paste("package", nsname, sep=":")
./namespace.R- if (attname %in% search())
./namespace.R- stop("name space is already attached")
./namespace.R: env <- attach(NULL, pos = pos, name = attname)
./namespace.R- on.exit(detach(pos = pos))
./namespace.R: attr(env, "path") <- nspath
./namespace.R- exports <- getNamespaceExports(ns)
./namespace.R: importIntoEnv(env, exports, ns, exports)
./namespace.R- if(!is.null(dataPath)) {
./namespace.R: dbbase <- file.path(dataPath, "Rdata")
./namespace.R: if(file.exists(paste(dbbase, ".rdb", sep=""))) lazyLoad(dbbase, env)
./namespace.R- }
./namespace.R: runHook(".onAttach", ns, dirname(nspath), nsname)
./namespace.R: lockEnvironment(env, TRUE)
./namespace.R- on.exit()
./namespace.R- invisible(env)
./namespace.R-}
./namespace.R-
./namespace.R:loadNamespace <- function (package, lib.loc = NULL,
./namespace.R: keep.source = getOption("keep.source.pkgs"),
./namespace.R: partial = FALSE, declarativeOnly = FALSE) {
./namespace.R- # eventually allow version as second component; ignore for now.
./namespace.R- package <- as.character(package)[[1]]
./namespace.R-
./namespace.R- # check for cycles
./namespace.R: dynGet <- function(name,
./namespace.R: notFound = stop(gettextf("%s not found", name),
./namespace.R- domain=NA))
./namespace.R- {
./namespace.R- n <- sys.nframe()
./namespace.R- while (n > 1) {
./namespace.R- n <- n - 1
./namespace.R- env <- sys.frame(n)
./namespace.R: if (exists(name, env = env, inherits = FALSE))
./namespace.R: return(get(name, env = env, inherits = FALSE))
./namespace.R- }
./namespace.R- notFound
./namespace.R- }
./namespace.R: loading <- dynGet("__NameSpacesLoading__", NULL)
./namespace.R: if (match(package, loading, 0))
./namespace.R- stop("cyclic name space dependencies are not supported")
./namespace.R: "__NameSpacesLoading__" <- c(package, loading)
./namespace.R-
./namespace.R- ns <- .Internal(getRegisteredNamespace(as.name(package)))
./namespace.R- if (! is.null(ns))
./namespace.R- ns
./namespace.R- else {
./namespace.R: runHook <- function(hookname, pkgname, env, ...) {
./namespace.R: if (exists(hookname, envir = env, inherits = FALSE)) {
./namespace.R: fun <- get(hookname, envir = env, inherits = FALSE)
./namespace.R- if (! is.null(try({ fun(...); NULL})))
./namespace.R: stop(gettextf("%s failed in 'loadNamespace' for '%s'",
./namespace.R: hookname, pkgname),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R- }
./namespace.R- }
./namespace.R: runUserHook <- function(pkgname, pkgpath) {
./namespace.R: hook <- getHook(packageEvent(pkgname, "onLoad")) # might be list()
./namespace.R: for(fun in hook) try(fun(pkgname, pkgpath))
./namespace.R- }
./namespace.R: makeNamespace <- function(name, version = NULL, lib = NULL) {
./namespace.R: impenv <- new.env(parent = .BaseNamespaceEnv, hash = TRUE)
./namespace.R: env <- new.env(parent = impenv, hash = TRUE)
./namespace.R- name <- as.character(as.name(name))
./namespace.R- version <- as.character(version)
./namespace.R: info <- new.env(hash = TRUE, parent = NULL)
./namespace.R: assign(".__NAMESPACE__.", info, env = env)
./namespace.R: assign("spec", c(name=name,version=version), env = info)
./namespace.R: setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = NULL))
./namespace.R: setNamespaceInfo(env, "imports", list("base"=TRUE))
./namespace.R: setNamespaceInfo(env, "path", file.path(lib, name))
./namespace.R: setNamespaceInfo(env, "dynlibs", NULL)
./namespace.R: setNamespaceInfo(env, "S3methods", matrix(as.character(NA), 0, 3))
./namespace.R: assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
./namespace.R- envir = env)
./namespace.R: .Internal(registerNamespace(name, env))
./namespace.R- env
./namespace.R- }
./namespace.R- sealNamespace <- function(ns) {
./namespace.R- namespaceIsSealed <- function(ns)
./namespace.R- environmentIsLocked(ns)
./namespace.R: ns <- asNamespace(ns, base.OK = FALSE)
./namespace.R- if (namespaceIsSealed(ns))
./namespace.R: stop(gettextf("namespace '%s' is already sealed in loadNamespace",
./namespace.R: getNamespaceName(ns)),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R: lockEnvironment(ns, TRUE)
./namespace.R: lockEnvironment(parent.env(ns), TRUE)
./namespace.R- }
./namespace.R: addNamespaceDynLibs <- function(ns, newlibs) {
./namespace.R: dynlibs <- getNamespaceInfo(ns, "dynlibs")
./namespace.R: setNamespaceInfo(ns, "dynlibs", c(dynlibs, newlibs))
./namespace.R- }
./namespace.R-
./namespace.R: bindTranslations <- function(pkgname, pkgpath)
./namespace.R- {
./namespace.R: popath <- file.path(pkgpath, "po")
./namespace.R- if(!file.exists(popath)) return()
./namespace.R: bindtextdomain(pkgname, popath)
./namespace.R: bindtextdomain(paste("R", pkgname, sep="-"), popath)
./namespace.R- }
./namespace.R- # find package and check it has a name space
./namespace.R: pkgpath <- .find.package(package, lib.loc, quiet = TRUE)
./namespace.R- if (length(pkgpath) == 0)
./namespace.R: stop(gettextf("there is no package called '%s'", package),
./namespace.R- domain = NA)
./namespace.R: bindTranslations(package, pkgpath)
./namespace.R- package.lib <- dirname(pkgpath)
./namespace.R- package<- basename(pkgpath) # need the versioned name
./namespace.R: if (! packageHasNamespace(package, package.lib))
./namespace.R: stop(gettextf("package '%s' does not have a name space", package),
./namespace.R- domain = NA)
./namespace.R-
./namespace.R- # create namespace; arrange to unregister on error
./namespace.R- ##
./namespace.R- ## Can we rely on the existence of R-ng 'nsInfo.rds' and
./namespace.R- ## 'package.rds'?
./namespace.R: nsInfoFilePath <- file.path(pkgpath, "Meta", "nsInfo.rds")
./namespace.R- nsInfo <- if(file.exists(nsInfoFilePath)) .readRDS(nsInfoFilePath)
./namespace.R: else parseNamespaceFile(package, package.lib, mustExist = FALSE)
./namespace.R: packageInfoFilePath <- file.path(pkgpath, "Meta", "package.rds")
./namespace.R- version <- if(file.exists(packageInfoFilePath))
./namespace.R- .readRDS(packageInfoFilePath)$DESCRIPTION["Version"]
./namespace.R- else
./namespace.R: read.dcf(file.path(pkgpath, "DESCRIPTION"),
./namespace.R- fields = "Version")
./namespace.R- ##
./namespace.R: ns <- makeNamespace(package, version = version, lib = package.lib)
./namespace.R- on.exit(.Internal(unregisterNamespace(package)))
./namespace.R-
./namespace.R- # process imports
./namespace.R- for (i in nsInfo$imports) {
./namespace.R- if (is.character(i))
./namespace.R: namespaceImport(ns, loadNamespace(i, c(lib.loc, .libPaths()),
./namespace.R- keep.source))
./namespace.R- else
./namespace.R: namespaceImportFrom(ns,
./namespace.R: loadNamespace(i[[1]],
./namespace.R: c(lib.loc, .libPaths()),
./namespace.R: keep.source), i[[2]])
./namespace.R- }
./namespace.R- for(imp in nsInfo$importClasses)
./namespace.R: namespaceImportClasses(ns, loadNamespace(imp[[1]],
./namespace.R: c(lib.loc, .libPaths()),
./namespace.R: keep.source), imp[[2]])
./namespace.R- for(imp in nsInfo$importMethods)
./namespace.R: namespaceImportMethods(ns, loadNamespace(imp[[1]],
./namespace.R: c(lib.loc, .libPaths()),
./namespace.R: keep.source), imp[[2]])
./namespace.R-
./namespace.R-
./namespace.R- # dynamic variable to allow/disable .Import and friends
./namespace.R- "__NamespaceDeclarativeOnly__" <- declarativeOnly
./namespace.R-
./namespace.R- # store info for loading name space for loadingNamespaceInfo to read
./namespace.R: "__LoadingNamespaceInfo__" <- list(libname = package.lib,
./namespace.R- pkgname = package)
./namespace.R-
./namespace.R- env <- asNamespace(ns)
./namespace.R- # save the package name in the environment
./namespace.R: assign(".packageName", package, envir = env)
./namespace.R-
./namespace.R- # load the code
./namespace.R: codename <- strsplit(package, "_", fixed=TRUE)[[1]][1]
./namespace.R: codeFile <- file.path(pkgpath, "R", codename)
./namespace.R- if (file.exists(codeFile)) {
./namespace.R: res <- try(sys.source(codeFile, env, keep.source = keep.source))
./namespace.R: if(inherits(res, "try-error"))
./namespace.R: stop(gettextf("unable to load R code in package '%s'", package),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R: } else warning(gettextf("package '%s' contains no R code", package),
./namespace.R- domain = NA)
./namespace.R-
./namespace.R- ## partial loading stops at this point
./namespace.R- ## -- used in preparing for lazy-loading
./namespace.R- if (partial) return(ns)
./namespace.R-
./namespace.R- # lazy-load any sysdata
./namespace.R: dbbase <- file.path(pkgpath, "R", "sysdata")
./namespace.R: if (file.exists(paste(dbbase, ".rdb", sep=""))) lazyLoad(dbbase, env)
./namespace.R-
./namespace.R- # register any S3 methods
./namespace.R: registerS3methods(nsInfo$S3methods, package, env)
./namespace.R-
./namespace.R- # load any dynamic libraries
./namespace.R- # We provide a way out for cross-building where we can't dynload
./namespace.R- if(!nchar(Sys.getenv("R_CROSS_BUILD"))) {
./namespace.R- dlls = list()
./namespace.R- for (lib in nsInfo$dynlibs) {
./namespace.R: dlls[[lib]] = library.dynam(lib, package, package.lib)
./namespace.R- }
./namespace.R: setNamespaceInfo(env, "DLLs", dlls)
./namespace.R- }
./namespace.R: addNamespaceDynLibs(env, nsInfo$dynlibs)
./namespace.R-
./namespace.R-
./namespace.R- # run the load hook
./namespace.R: runHook(".onLoad", package, env, package.lib, package)
./namespace.R-
./namespace.R: # process exports, seal, and clear on.exit action
./namespace.R- exports <- nsInfo$exports
./namespace.R-
./namespace.R- for (p in nsInfo$exportPatterns)
./namespace.R: exports <- c(ls(env, pat = p, all = TRUE), exports)
./namespace.R- if(.isMethodsDispatchOn() &&
./namespace.R: !exists(".noGenerics", envir = ns, inherits = FALSE)) {
./namespace.R- ## process class definition objects
./namespace.R- expClasses <- nsInfo$exportClasses
./namespace.R- if(length(expClasses) > 0) {
./namespace.R: missingClasses <- !sapply(expClasses, methods:::isClass, where = ns)
./namespace.R- if(any(missingClasses))
./namespace.R: stop(gettextf("in '%s' classes for export not defined: %s",
./namespace.R: package,
./namespace.R: paste(expClasses[missingClasses], collapse = ", ")),
./namespace.R- domain = NA)
./namespace.R: expClasses <- paste(methods:::classMetaName(""), expClasses, sep="")
./namespace.R- }
./namespace.R- ## process methods metadata explicitly exported or
./namespace.R- ## implied by exporting the generic function.
./namespace.R: allMethods <- unique(c(methods:::.getGenerics(ns),
./namespace.R- methods:::.getGenerics(parent.env(ns))))
./namespace.R- expMethods <- nsInfo$exportMethods
./namespace.R- if(length(allMethods) > 0) {
./namespace.R: expMethods <- unique(c(expMethods,
./namespace.R: exports[!is.na(match(exports, allMethods))]))
./namespace.R- missingMethods <- !(expMethods %in% allMethods)
./namespace.R- if(any(missingMethods))
./namespace.R: stop(gettextf("in '%s' methods for export not found: %s",
./namespace.R: package,
./namespace.R: paste(expMethods[missingMethods], collapse = ", ")),
./namespace.R- domain = NA)
./namespace.R- needMethods <- (exports %in% allMethods) & !(exports %in% expMethods)
./namespace.R- if(any(needMethods))
./namespace.R: expMethods <- c(expMethods, exports[needMethods])
./namespace.R- ## Primitives must have their methods exported as long
./namespace.R- ## as a global table is used in the C code to dispatch them:
./namespace.R- ## The following keeps the exported files consistent with
./namespace.R- ## the internal table.
./namespace.R- pm <- allMethods[!(allMethods %in% expMethods)]
./namespace.R- if(length(pm)>0) {
./namespace.R- prim <- logical(length(pm))
./namespace.R- for(i in seq(along=prim)) {
./namespace.R: f <- methods::getFunction(pm[[i]], FALSE, FALSE, ns)
./namespace.R- prim[[i]] <- is.primitive(f)
./namespace.R- }
./namespace.R: expMethods <- c(expMethods, pm[prim])
./namespace.R- }
./namespace.R- for(i in seq(along=expMethods)) {
./namespace.R- mi <- expMethods[[i]]
./namespace.R- if(!(mi %in% exports) &&
./namespace.R: exists(mi, envir = ns, mode = "function", inherits = FALSE))
./namespace.R: exports <- c(exports, mi)
./namespace.R: expMethods[[i]] <- methods:::mlistMetaName(mi, ns)
./namespace.R- }
./namespace.R- }
./namespace.R- else if(length(expMethods) > 0)
./namespace.R: stop(gettextf("in '%s' methods specified for export, but none defined: %s",
./namespace.R: package,
./namespace.R: paste(expMethods, collapse=", ")),
./namespace.R- domain = NA)
./namespace.R: exports <- c(exports, expClasses, expMethods)
./namespace.R- }
./namespace.R: namespaceExport(ns, exports)
./namespace.R- sealNamespace(ns)
./namespace.R- ## run user hooks here
./namespace.R: runUserHook(package, file.path(package.lib, package))
./namespace.R- on.exit()
./namespace.R- ns
./namespace.R- }
./namespace.R-}
./namespace.R-
./namespace.R-loadingNamespaceInfo <- function() {
./namespace.R: dynGet <- function(name, notFound = stop(name, " not found")) {
./namespace.R- n <- sys.nframe()
./namespace.R- while (n > 1) {
./namespace.R- n <- n - 1
./namespace.R- env <- sys.frame(n)
./namespace.R: if (exists(name, env = env, inherits = FALSE))
./namespace.R: return(get(name, env = env, inherits = FALSE))
./namespace.R- }
./namespace.R- notFound
./namespace.R- }
./namespace.R: dynGet("__LoadingNamespaceInfo__", stop("not loading a name space"))
./namespace.R-}
./namespace.R-
./namespace.R:saveNamespaceImage <- function (package, rdafile, lib.loc = NULL,
./namespace.R: keep.source = getOption("keep.source.pkgs"),
./namespace.R- compress = TRUE)
./namespace.R-{
./namespace.R- if (! is.null(.Internal(getRegisteredNamespace(as.name(package)))))
./namespace.R: stop(gettextf("name space '%s' is loaded", package), domain = NA)
./namespace.R: ns <- loadNamespace(package, lib.loc, keep.source, TRUE, TRUE)
./namespace.R: vars <- ls(ns, all = TRUE)
./namespace.R- vars <- vars[vars != ".__NAMESPACE__."]
./namespace.R: save(list = vars, file = rdafile, envir = ns, compress = compress)
./namespace.R-}
./namespace.R-
./namespace.R:topenv <- function(envir = parent.frame(),
./namespace.R- matchThisEnv = getOption("topLevelEnvironment")) {
./namespace.R- while (! is.null(envir)) {
./namespace.R: if (! is.null(attr(envir, "name")) ||
./namespace.R: identical(envir, matchThisEnv) ||
./namespace.R: identical(envir, .GlobalEnv) ||
./namespace.R- .Internal(isNamespaceEnv(envir)) ||
./namespace.R: exists(".packageName", envir = envir, inherits = FALSE))
./namespace.R- return(envir)
./namespace.R- else envir <- parent.env(envir)
./namespace.R- }
./namespace.R- return(.GlobalEnv)
./namespace.R-}
./namespace.R-
./namespace.R-unloadNamespace <- function(ns) {
./namespace.R: runHook <- function(hookname, env, ...) {
./namespace.R: if (exists(hookname, envir = env, inherits = FALSE)) {
./namespace.R: fun <- get(hookname, envir = env, inherits = FALSE)
./namespace.R- if (! is.null(try({ fun(...); NULL})))
./namespace.R: stop(gettextf("%s failed in unloadNamespace(%s)", hookname,
./namespace.R: ns), call. = FALSE, domain = NA)
./namespace.R- }
./namespace.R- }
./namespace.R: ns <- asNamespace(ns, base.OK = FALSE)
./namespace.R- nsname <- getNamespaceName(ns)
./namespace.R: pos <- match(paste("package", nsname, sep=":"), search())
./namespace.R- if (! is.na(pos)) detach(pos = pos)
./namespace.R- users <- getNamespaceUsers(ns)
./namespace.R- print(ns)
./namespace.R- if (length(users) != 0)
./namespace.R: stop(gettextf("name space '%s' is still used by: ",
./namespace.R: getNamespaceName(ns),
./namespace.R: paste(sQuote(users), collapse = ", ")),
./namespace.R- domain = NA)
./namespace.R: nspath <- getNamespaceInfo(ns, "path")
./namespace.R: hook <- getHook(packageEvent(nsname, "onUnload")) # might be list()
./namespace.R: for(fun in rev(hook)) try(fun(nsname, nspath))
./namespace.R: try(runHook(".onUnload", ns, nspath))
./namespace.R- .Internal(unregisterNamespace(nsname))
./namespace.R- invisible()
./namespace.R-}
./namespace.R-
./namespace.R-.Import <- function(...) {
./namespace.R: dynGet <- function(name, notFound = stop(name, " not found")) {
./namespace.R- n <- sys.nframe()
./namespace.R- while (n > 1) {
./namespace.R- n <- n - 1
./namespace.R- env <- sys.frame(n)
./namespace.R: if (exists(name, env = env, inherits = FALSE))
./namespace.R: return(get(name, env = env, inherits = FALSE))
./namespace.R- }
./namespace.R- notFound
./namespace.R- }
./namespace.R: if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
./namespace.R- stop("imperative name space directives are disabled")
./namespace.R- envir <- parent.frame()
./namespace.R- names <- as.character(substitute(list(...)))[-1]
./namespace.R- for (n in names)
./namespace.R: namespaceImportFrom(envir, n)
./namespace.R-}
./namespace.R-
./namespace.R:.ImportFrom <- function(name, ...) {
./namespace.R: dynGet <- function(name, notFound = stop(name, " not found")) {
./namespace.R- n <- sys.nframe()
./namespace.R- while (n > 1) {
./namespace.R- n <- n - 1
./namespace.R- env <- sys.frame(n)
./namespace.R: if (exists(name, env = env, inherits = FALSE))
./namespace.R: return(get(name, env = env, inherits = FALSE))
./namespace.R- }
./namespace.R- notFound
./namespace.R- }
./namespace.R: if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
./namespace.R- stop("imperative name space directives are disabled")
./namespace.R- envir <- parent.frame()
./namespace.R- name <- as.character(substitute(name))
./namespace.R- names <- as.character(substitute(list(...)))[-1]
./namespace.R: namespaceImportFrom(envir, name, names)
./namespace.R-}
./namespace.R-
./namespace.R-.Export <- function(...) {
./namespace.R: dynGet <- function(name, notFound = stop(name, " not found")) {
./namespace.R- n <- sys.nframe()
./namespace.R- while (n > 1) {
./namespace.R- n <- n - 1
./namespace.R- env <- sys.frame(n)
./namespace.R: if (exists(name, env = env, inherits = FALSE))
./namespace.R: return(get(name, env = env, inherits = FALSE))
./namespace.R- }
./namespace.R- notFound
./namespace.R- }
./namespace.R: if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
./namespace.R- stop("imperative name space directives are disabled")
./namespace.R: ns <- topenv(parent.frame(), NULL)
./namespace.R: if (identical(ns, .BaseNamespaceEnv))
./namespace.R- warning("all objects in base name space are currently exported.")
./namespace.R- else if (! isNamespace(ns))
./namespace.R- stop("can only export from a name space")
./namespace.R- else {
./namespace.R- names <- as.character(substitute(list(...)))[-1]
./namespace.R: namespaceExport(ns, names)
./namespace.R- }
./namespace.R-}
./namespace.R-
./namespace.R:.S3method <- function(generic, class, method) {
./namespace.R: dynGet <- function(name, notFound = stop(name, " not found")) {
./namespace.R- n <- sys.nframe()
./namespace.R- while (n > 1) {
./namespace.R- n <- n - 1
./namespace.R- env <- sys.frame(n)
./namespace.R: if (exists(name, env = env, inherits = FALSE))
./namespace.R: return(get(name, env = env, inherits = FALSE))
./namespace.R- }
./namespace.R- notFound
./namespace.R- }
./namespace.R: if (dynGet("__NamespaceDeclarativeOnly__", FALSE))
./namespace.R- stop("imperative name space directives are disabled")
./namespace.R- generic <- as.character(substitute(generic))
./namespace.R- class <- as.character(substitute(class))
./namespace.R: if (missing(method)) method <- paste(generic, class, sep=".")
./namespace.R: registerS3method(generic, class, method, envir = parent.frame())
./namespace.R- invisible(NULL)
./namespace.R-}
./namespace.R-
./namespace.R-isNamespace <- function(ns) .Internal(isNamespaceEnv(ns))
./namespace.R-
./namespace.R:isBaseNamespace <- function(ns) identical(ns, .BaseNamespaceEnv)
./namespace.R-
./namespace.R:getNamespaceInfo <- function(ns, which) {
./namespace.R: ns <- asNamespace(ns, base.OK = FALSE)
./namespace.R: info <- get(".__NAMESPACE__.", env = ns, inherits = FALSE)
./namespace.R: get(which, env = info, inherits = FALSE)
./namespace.R-}
./namespace.R-
./namespace.R:setNamespaceInfo <- function(ns, which, val) {
./namespace.R: ns <- asNamespace(ns, base.OK = FALSE)
./namespace.R: info <- get(".__NAMESPACE__.", env = ns, inherits = FALSE)
./namespace.R: assign(which, val, env = info)
./namespace.R-}
./namespace.R-
./namespace.R:asNamespace <- function(ns, base.OK = TRUE) {
./namespace.R- if (is.character(ns) || is.name(ns))
./namespace.R- ns <- getNamespace(ns)
./namespace.R- if (! isNamespace(ns))
--
./namespace.R- else if (! base.OK && isBaseNamespace(ns))
./namespace.R- stop("operation not allowed on base name space")
./namespace.R- else ns
./namespace.R-}
./namespace.R-
./namespace.R:namespaceImport <- function(self, ...) {
./namespace.R- for (ns in list(...))
./namespace.R: namespaceImportFrom(self, asNamespace(ns))
./namespace.R-}
./namespace.R-
./namespace.R:namespaceImportFrom <- function(self, ns, vars) {
./namespace.R: addImports <- function(ns, from, what) {
./namespace.R: imp <- structure(list(what), names = getNamespaceName(from))
./namespace.R- imports <- getNamespaceImports(ns)
./namespace.R: setNamespaceInfo(ns, "imports", c(imports, imp))
./namespace.R- }
./namespace.R- namespaceIsSealed <- function(ns)
./namespace.R- environmentIsLocked(ns)
--
./namespace.R- if (is.null(new)) new <- old
./namespace.R- else new[new==""] <- old[new==""]
./namespace.R- names(old) <- new
./namespace.R- old
./namespace.R- }
./namespace.R: mergeImportMethods <- function(impenv, expenv, metaname) {
./namespace.R: expMethods <- get(metaname, envir = expenv)
./namespace.R: if(exists(metaname, envir = impenv, inherits = FALSE)) {
./namespace.R: impMethods <- get(metaname, envir = impenv)
./namespace.R: assign(metaname, methods:::mergeMethods(impMethods, expMethods), envir = impenv)
./namespace.R- TRUE
./namespace.R- }
./namespace.R- else
--
./namespace.R- }
./namespace.R- whichMethodMetaNames <- function(impvars) {
./namespace.R- if(!.isMethodsDispatchOn())
./namespace.R- return(numeric())
./namespace.R- mm <- ".__M__" # methods:::mlistMetaName() is slow
./namespace.R: seq(along = impvars)[substr(impvars, 1, nchar(mm, type="c")) == mm]
./namespace.R- }
./namespace.R- if (is.character(self))
./namespace.R- self <- getNamespace(self)
--
./namespace.R- if (missing(vars)) impvars <- getNamespaceExports(ns)
./namespace.R- else impvars <- vars
./namespace.R- impvars <- makeImportExportNames(impvars)
./namespace.R- impnames <- names(impvars)
./namespace.R- if (any(duplicated(impnames))) {
./namespace.R: stop("duplicate import names ",
./namespace.R: paste(impnames[duplicated(impnames)], collapse=", "))
./namespace.R- }
./namespace.R- if (isNamespace(self) && isBaseNamespace(self)) {
./namespace.R- impenv <- self
--
./namespace.R- register <- FALSE
./namespace.R- }
./namespace.R- else stop("invalid import target")
./namespace.R- which <- whichMethodMetaNames(impvars)
./namespace.R- if(length(which)) {
./namespace.R: ## If methods are already in impenv, merge and don't import
./namespace.R- delete <- integer()
./namespace.R- for(i in which)
./namespace.R: if(mergeImportMethods(impenv, ns, impvars[[i]]))
./namespace.R: delete <- c(delete, i)
./namespace.R- if(length(delete)>0) {
./namespace.R- impvars <- impvars[-delete]
./namespace.R- impnames <- impnames[-delete]
./namespace.R- }
./namespace.R- }
./namespace.R- for (n in impnames)
./namespace.R: if (exists(n, env = impenv, inherits = FALSE))
./namespace.R: warning(msg, " ", n)
./namespace.R: importIntoEnv(impenv, impnames, ns, impvars)
./namespace.R- if (register) {
./namespace.R: if (missing(vars)) addImports(self, ns, TRUE)
./namespace.R: else addImports(self, ns, impvars)
./namespace.R- }
./namespace.R-}
./namespace.R-
./namespace.R:namespaceImportClasses <- function(self, ns, vars) {
./namespace.R- for(i in seq(along = vars))
./namespace.R- vars[[i]] <- methods:::classMetaName(vars[[i]])
./namespace.R: namespaceImportFrom(self, asNamespace(ns), vars)
./namespace.R-}
./namespace.R-
./namespace.R:namespaceImportMethods <- function(self, ns, vars) {
./namespace.R- allVars <- character()
./namespace.R- allMlists <- methods:::.getGenerics(ns)
./namespace.R: if(any(is.na(match(vars, allMlists))))
./namespace.R: stop(gettextf("requested 'methods' objects not found in environment/package '%s': %s",
./namespace.R: methods:::getPackageName(ns),
./namespace.R: paste(vars[is.na(match(vars, allMlists))],
./namespace.R: collapse = ", ")), domain = NA)
./namespace.R- for(i in seq(along = allMlists)) {
./namespace.R- ## import methods list objects if asked for
./namespace.R- ## or if the corresponding generic was imported
./namespace.R- g <- allMlists[[i]]
./namespace.R: if(exists(g, envir=self, inherits = FALSE) # already imported
./namespace.R- || g %in% vars) # requested explicitly
./namespace.R: allVars <- c(allVars, methods:::mlistMetaName(g, ns))
./namespace.R: if(g %in% vars && !exists(g, envir=self, inherits = FALSE) &&
./namespace.R: exists(g, envir=ns, inherits = FALSE) &&
./namespace.R: methods:::is(get(g, envir = ns), "genericFunction"))
./namespace.R: allVars <- c(allVars, g)
./namespace.R- }
./namespace.R: namespaceImportFrom(self, asNamespace(ns), allVars)
./namespace.R-}
./namespace.R-
./namespace.R:importIntoEnv <- function(impenv, impnames, expenv, expnames) {
./namespace.R: exports <- getNamespaceInfo(expenv, "exports")
./namespace.R: ex <- .Internal(ls(exports, TRUE))
./namespace.R- if(!all(expnames %in% ex)) {
./namespace.R- miss <- expnames[! expnames %in% ex]
./namespace.R: stop(sprintf(ngettext(length(miss),
./namespace.R: "object %s is not exported by 'namespace:%s'",
./namespace.R: "objects %s are not exported by 'namespace:%s'"),
./namespace.R: paste(sQuote(miss), collapse=", "),
./namespace.R: getNamespaceName(expenv)),
./namespace.R- domain = NA)
./namespace.R- }
./namespace.R: expnames <- unlist(lapply(expnames, get, env = exports, inherits = FALSE))
./namespace.R- if (is.null(impnames)) impnames <- character(0)
./namespace.R- if (is.null(expnames)) expnames <- character(0)
./namespace.R: .Internal(importIntoEnv(impenv, impnames, expenv, expnames))
./namespace.R-}
./namespace.R-
./namespace.R:namespaceExport <- function(ns, vars) {
./namespace.R- namespaceIsSealed <- function(ns)
./namespace.R- environmentIsLocked(ns)
./namespace.R- if (namespaceIsSealed(ns))
./namespace.R- stop("cannot add to exports of a sealed name space")
./namespace.R: ns <- asNamespace(ns, base.OK = FALSE)
./namespace.R- if (length(vars) > 0) {
./namespace.R: addExports <- function(ns, new) {
./namespace.R: exports <- getNamespaceInfo(ns, "exports")
./namespace.R- expnames <- names(new)
./namespace.R- intnames <- new
./namespace.R: objs <- .Internal(ls(exports, TRUE))
./namespace.R- ex <- expnames %in% objs
./namespace.R- if(any(ex))
./namespace.R: warning(sprintf(ngettext(sum(notex),
./namespace.R: "previous export %s is being replaced",
./namespace.R: "previous exports %s are being replaced"),
./namespace.R: paste(sQuote(info[notex, 3]), collapse=", ")),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R- for (i in seq(along = new))
./namespace.R: assign(expnames[i], intnames[i], env = exports)
./namespace.R- }
./namespace.R- makeImportExportNames <- function(spec) {
./namespace.R- old <- as.character(spec)
--
./namespace.R- else new[new==""] <- old[new==""]
./namespace.R- names(old) <- new
./namespace.R- old
./namespace.R- }
./namespace.R- new <- makeImportExportNames(unique(vars))
./namespace.R: ## calling exists each time is too slow, so do two phases
./namespace.R: undef <- new[! new %in% .Internal(ls(ns, TRUE))]
./namespace.R: undef <- undef[! sapply(undef, exists, env = ns)]
./namespace.R- if (length(undef) != 0) {
./namespace.R: undef <- do.call("paste", as.list(c(undef, sep=", ")))
./namespace.R: stop("undefined exports :", undef)
./namespace.R- }
./namespace.R: if(.isMethodsDispatchOn()) .mergeExportMethods(new, ns)
./namespace.R: addExports(ns, new)
./namespace.R- }
./namespace.R-}
./namespace.R-
./namespace.R:.mergeExportMethods <- function(new, ns) {
./namespace.R-# if(!.isMethodsDispatchOn()) return(FALSE)
./namespace.R- mm <- methods:::mlistMetaName()
./namespace.R: newMethods <- new[substr(new, 1, nchar(mm, type="c")) == mm]
./namespace.R- nsimports <- parent.env(ns)
./namespace.R- for(what in newMethods) {
./namespace.R: if(exists(what, envir = nsimports, inherits = FALSE)) {
./namespace.R: m1 <- get(what, envir = nsimports)
./namespace.R: m2 <- get(what, envir = ns)
./namespace.R: assign(what, envir = ns, methods:::mergeMethods(m1, m2))
./namespace.R- }
./namespace.R- }
./namespace.R-}
./namespace.R-
./namespace.R:## NB this needs a decorated name, foo_ver, if appropriate
./namespace.R:packageHasNamespace <- function(package, package.lib) {
./namespace.R: namespaceFilePath <- function(package, package.lib)
./namespace.R: file.path(package.lib, package, "NAMESPACE")
./namespace.R: file.exists(namespaceFilePath(package, package.lib))
./namespace.R-}
./namespace.R-
./namespace.R:parseNamespaceFile <- function(package, package.lib, mustExist = TRUE) {
./namespace.R: namespaceFilePath <- function(package, package.lib)
./namespace.R: file.path(package.lib, package, "NAMESPACE")
./namespace.R: nsFile <- namespaceFilePath(package, package.lib)
./namespace.R- if (file.exists(nsFile))
./namespace.R- directives <- parse(nsFile)
./namespace.R- else if (mustExist)
./namespace.R: stop(gettextf("package '%s' has no NAMESPACE file", package),
./namespace.R- domain = NA)
./namespace.R- else directives <- NULL
./namespace.R- exports <- character(0)
--
./namespace.R- exportMethods <- character(0)
./namespace.R- imports <- list()
./namespace.R- importMethods <- list()
./namespace.R- importClasses <- list()
./namespace.R- dynlibs <- character(0)
./namespace.R: S3methods <- matrix(as.character(NA), 500, 3)
./namespace.R- nS3 <- 0
./namespace.R- parseDirective <- function(e) {
./namespace.R: switch(as.character(e[[1]]),
./namespace.R: "if" = if (eval(e[[2]], .GlobalEnv))
./namespace.R- parseDirective(e[[3]])
./namespace.R- else if (length(e) == 4)
./namespace.R: parseDirective(e[[4]]),
./namespace.R: "{" = for (ee in as.list(e[-1])) parseDirective(ee),
./namespace.R- export = {
./namespace.R- exp <- e[-1]
./namespace.R: exp <- structure(as.character(exp), names=names(exp))
./namespace.R: exports <<- c(exports, exp)
./namespace.R: },
./namespace.R- exportPattern = {
./namespace.R- pat <- as.character(e[-1])
./namespace.R: exportPatterns <<- c(pat, exportPatterns)
./namespace.R: },
./namespace.R: exportClass = , exportClasses = {
./namespace.R: exportClasses <<- c(as.character(e[-1]), exportClasses)
./namespace.R: },
./namespace.R- exportMethods = {
./namespace.R: exportMethods <<- c(as.character(e[-1]), exportMethods)
./namespace.R: },
./namespace.R: import = imports <<- c(imports,as.list(as.character(e[-1]))),
./namespace.R- importFrom = {
./namespace.R- imp <- e[-1]
./namespace.R- ivars <- imp[-1]
./namespace.R- inames <- names(ivars)
./namespace.R: imp <- list(as.character(imp[1]),
./namespace.R: structure(as.character(ivars), names=inames))
./namespace.R: imports <<- c(imports, list(imp))
./namespace.R: },
./namespace.R: importClassFrom = , importClassesFrom = {
./namespace.R- imp <- as.character(e[-1])
./namespace.R- pkg <- imp[[1]]
./namespace.R- impClasses <- imp[-1]
./namespace.R: imp <- list(as.character(pkg), as.character(impClasses))
./namespace.R: importClasses <<- c(importClasses, list(imp))
./namespace.R: },
./namespace.R- importMethodsFrom = {
./namespace.R- imp <- as.character(e[-1])
./namespace.R- pkg <- imp[[1]]
./namespace.R- impMethods <- imp[-1]
./namespace.R: imp <- list(as.character(pkg), as.character(impMethods))
./namespace.R: importMethods <<- c(importMethods, list(imp))
./namespace.R: },
./namespace.R- useDynLib = {
./namespace.R- dyl <- e[-1]
./namespace.R: dynlibs <<- c(dynlibs, as.character(dyl))
./namespace.R: },
./namespace.R- S3method = {
./namespace.R- spec <- e[-1]
./namespace.R- if (length(spec) != 2 && length(spec) != 3)
./namespace.R: stop(gettextf("bad 'S3method' directive: %s", deparse(e)),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R- nS3 <<- nS3 + 1;
./namespace.R- if(nS3 > 500)
./namespace.R: stop("too many 'S3method' directives", call. = FALSE)
./namespace.R: S3methods[nS3, 1:length(spec)] <<- as.character(spec)
./namespace.R: },
./namespace.R: stop(gettextf("unknown namespace directive: %s", deparse(e)),
./namespace.R: call. = FALSE, domain = FALSE)
./namespace.R- )
./namespace.R- }
./namespace.R- for (e in directives)
./namespace.R- parseDirective(e)
./namespace.R: list(imports=imports, exports=exports, exportPatterns = exportPatterns,
./namespace.R: importClasses=importClasses, importMethods=importMethods,
./namespace.R: exportClasses=exportClasses, exportMethods=exportMethods,
./namespace.R: dynlibs=dynlibs, S3methods = S3methods[seq(len=nS3), ,drop=FALSE])
./namespace.R-}
./namespace.R-
./namespace.R:registerS3method <- function(genname, class, method, envir = parent.frame()) {
./namespace.R: addNamespaceS3method <- function(ns, generic, class, method) {
./namespace.R: regs <- getNamespaceInfo(ns, "S3methods")
./namespace.R: regs <- cbind(regs, c(generic, class, method))
./namespace.R: setNamespaceInfo(ns, "S3methods", regs)
./namespace.R- }
./namespace.R: groupGenerics <- c("Math", "Ops", "Summary", "Complex")
./namespace.R- defenv <- if(genname %in% groupGenerics) .BaseNamespaceEnv
./namespace.R- else {
./namespace.R: genfun <- get(genname, envir = envir)
./namespace.R: if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
./namespace.R- genfun <- methods::finalDefaultMethod(methods::getMethods(genname))@.Data
./namespace.R- if (typeof(genfun) == "closure") environment(genfun)
./namespace.R- else .BaseNamespaceEnv
./namespace.R- }
./namespace.R: if (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
./namespace.R: assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
./namespace.R- envir = defenv)
./namespace.R: table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
./namespace.R- if (is.character(method)) {
./namespace.R: assignWrapped <- function(x, method, home, envir) {
./namespace.R- method <- method # force evaluation
./namespace.R- home <- home # force evaluation
./namespace.R: delayedAssign(x, get(method, env = home), assign.env = envir)
./namespace.R- }
./namespace.R: if(!exists(method, env = envir)) {
./namespace.R: warning(gettextf("S3 method '%s' was declared in NAMESPACE but not found",
./namespace.R: method), call. = FALSE)
./namespace.R- } else {
./namespace.R: assignWrapped(paste(genname, class, sep = "."), method, home = envir,
./namespace.R- envir = table)
./namespace.R- }
./namespace.R- }
./namespace.R- else if (is.function(method))
./namespace.R: assign(paste(genname, class, sep = "."), method, envir = table)
./namespace.R- else stop("bad method")
./namespace.R: if (isNamespace(envir) && ! identical(envir, .BaseNamespaceEnv))
./namespace.R: addNamespaceS3method(envir, genname, class, method)
./namespace.R-}
./namespace.R-
./namespace.R:# export <- function(expr, where = topenv(parent.frame()),
./namespace.R:# exclusions = c("last.dump", "last.warning", ".Last.value",
./namespace.R:# ".Random.seed", ".packageName", ".noGenerics", ".required")) {
./namespace.R-# ns <- as.environment(where)
./namespace.R-# if(isNamespace(ns)) {
./namespace.R:# expEnv <- new.env(hash = TRUE, parent =ns)
./namespace.R-# ## copy .packageName (will also make this qualify as topenv()
./namespace.R-# ## for class & method assignment
./namespace.R:# assign(".packageName", get(".packageName", envir = ns), envir = expEnv)
./namespace.R:# eval(substitute(expr), expEnv)
./namespace.R-# ## objects assigned will be exported.
./namespace.R:# allObjects <- objects(expEnv, all=TRUE)
./namespace.R-# newExports <- allObjects[!(allObjects %in% exclusions)]
./namespace.R-# ## Merge any methods lists with existing versions in ns == parent.env(expEnv)
./namespace.R:# .mergeExportMethods(newExports, expEnv)
./namespace.R-# ## copy the objects
./namespace.R-# for(what in allObjects)
./namespace.R:# assign(what, get(what, envir = expEnv), envir = ns)
./namespace.R-# ## and update the exports information
./namespace.R:# exports <- getNamespaceInfo(ns, "exports")
./namespace.R-# for(what in newExports)
./namespace.R:# assign(what, what, envir = exports)
./namespace.R-# }
./namespace.R-# else
./namespace.R:# eval(substitute(expr), ns)
./namespace.R-# }
./namespace.R-
./namespace.R:registerS3methods <- function(info, package, env)
./namespace.R-{
./namespace.R: assignWrapped <- function(x, method, home, envir) {
./namespace.R- method <- method # force evaluation
./namespace.R- home <- home # force evaluation
./namespace.R: delayedAssign(x, get(method, env = home), assign.env = envir)
./namespace.R- }
./namespace.R: .registerS3method <- function(genname, class, method, nm, envir)
./namespace.R- {
./namespace.R- ## S3 generics should either be imported explicitly or be in
./namespace.R: ## the base namespace, so we start the search at the imports
./namespace.R: ## environment, parent.env(envir), which is followed by the
./namespace.R- ## base namespace. (We have already looked in the namespace.)
./namespace.R: ## However, in case they have not been imported, we first
./namespace.R- ## look up where some commonly used generics are (including the
./namespace.R- ## group generics).
./namespace.R- defenv <- if(!is.na(w <- .knownS3Generics[genname])) asNamespace(w)
./namespace.R- else {
./namespace.R: if(!exists(genname, envir = parent.env(envir)))
./namespace.R: stop(gettextf("object '%s' not found whilst loading namespace '%s'",
./namespace.R: genname, package), call. = FALSE, domain = NA)
./namespace.R: genfun <- get(genname, envir = parent.env(envir))
./namespace.R: if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) {
./namespace.R: genfun <- methods::slot(genfun, "default")@methods$ANY
./namespace.R: warning(gettextf("found an S4 version of '%s' so it has not been imported correctly",
./namespace.R: genname), call. = FALSE, domain = NA)
./namespace.R- }
./namespace.R- if (typeof(genfun) == "closure") environment(genfun)
./namespace.R- else .BaseNamespaceEnv
./namespace.R- }
./namespace.R: if (! exists(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))
./namespace.R: assign(".__S3MethodsTable__.", new.env(hash = TRUE, parent = NULL),
./namespace.R- envir = defenv)
./namespace.R: table <- get(".__S3MethodsTable__.", envir = defenv, inherits = FALSE)
./namespace.R: assignWrapped(nm, method, home = envir, envir = table)
./namespace.R- }
./namespace.R-
./namespace.R- n <- NROW(info)
./namespace.R- if(n == 0) return()
./namespace.R: methname <- paste(info[,1], info[,2], sep=".")
./namespace.R: z <- is.na(info[,3])
./namespace.R: info[z,3] <- methname[z]
./namespace.R: Info <- cbind(info, methname)
./namespace.R: loc <- .Internal(ls(env, TRUE))
./namespace.R: notex <- !(info[,3] %in% loc)
./namespace.R- if(any(notex))
./namespace.R: warning(sprintf(ngettext(sum(notex),
./namespace.R: "S3 method %s was declared in NAMESPACE but not found",
./namespace.R: "S3 methods %s were declared in NAMESPACE but not found"),
./namespace.R: paste(sQuote(info[notex, 3]), collapse=", ")),
./namespace.R: call. = FALSE, domain = NA)
./namespace.R: Info <- Info[!notex, , drop = FALSE]
./namespace.R-
./namespace.R- ## do local generics first -- this could be load-ed if pre-computed.
./namespace.R: localGeneric <- Info[,1] %in% loc
./namespace.R: lin <- Info[localGeneric, , drop = FALSE]
./namespace.R: S3MethodsTable <- get(".__S3MethodsTable__.", envir = env,
./namespace.R- inherits = FALSE)
./namespace.R- for(i in seq(len=nrow(lin)))
./namespace.R: assign(lin[i,4], get(lin[i,3], envir=env), envir = S3MethodsTable)
./namespace.R-
./namespace.R- ## now the rest
./namespace.R: fin <- Info[!localGeneric, , drop = FALSE]
./namespace.R- for(i in seq(len=nrow(fin)))
./namespace.R: .registerS3method(fin[i, 1], fin[i, 2], fin[i, 3], fin[i, 4], env)
./namespace.R-
./namespace.R: setNamespaceInfo(env, "S3methods",
./namespace.R: rbind(info, getNamespaceInfo(env, "S3methods")))
./namespace.R-}
--
./notyet.R-.NotYetImplemented <- function ()
./notyet.R: stop(gettextf("'%s' is not implemented yet",
./notyet.R: as.character(sys.call(sys.parent())[[1]])), call. = FALSE)
./notyet.R-
./notyet.R:.NotYetUsed <- function(arg, error = TRUE) {
./notyet.R: msg <- gettextf("argument '%s' is not used (yet)", arg)
./notyet.R: if(error) stop(msg, domain = NA, call. = FALSE)
./notyet.R: else warning(msg, domain = NA, call. = FALSE)
./notyet.R-}
--
./options.R-options <- function(...) .Internal(options(...))
./options.R-
./options.R-getOption <- function(x) options(x)[[1]]
./options.R-
./options.R:## transferred to system profile, where all the others are
./options.R-## initial options settings (others are done in C code in InitOptions)
./options.R:## options(defaultPackages = c("methods", "ctest"))
./options.R-
--
./outer.R:outer <- function (X, Y, FUN = "*", ...)
./outer.R-{
./outer.R- no.nx <- is.null(nx <- dimnames(X <- as.array(X))); dX <- dim(X)
./outer.R- no.ny <- is.null(ny <- dimnames(Y <- as.array(Y))); dY <- dim(Y)
./outer.R- if (is.character(FUN) && FUN=="*") {
./outer.R- robj <- as.vector(X) %*% t(as.vector(Y))
./outer.R: dim(robj) <- c(dX, dY)
./outer.R- } else {
./outer.R- FUN <- match.fun(FUN)
./outer.R: ## Y may have a class, so don't use rep.int
./outer.R: Y <- rep(Y, rep.int(length(X), length(Y)))
./outer.R- ## length.out is not an argument of the generic rep()
./outer.R:## X <- rep(X, length.out = length(Y))
./outer.R- if(length(X) > 0)
./outer.R: X <- rep(X, times = ceiling(length(Y)/length(X)))
./outer.R: robj <- FUN(X, Y, ...)
./outer.R: dim(robj) <- c(dX, dY) # careful not to lose class here
./outer.R- }
./outer.R- ## no dimnames if both don't have ..
./outer.R: if(no.nx) nx <- vector("list", length(dX)) else
./outer.R: if(no.ny) ny <- vector("list", length(dY))
./outer.R- if(!(no.nx && no.ny))
./outer.R: dimnames(robj) <- c(nx, ny)
./outer.R- robj
./outer.R-}
./outer.R-
./outer.R:## Binary operator, hence don't simply do "%o%" <- outer.
./outer.R:"%o%" <- function(X, Y) outer(X, Y)
--
./packages.R:## A simple S3 class for package versions, and associated methods.
./packages.R-
./packages.R-## We represent "vectors" of package versions as lists of sequences of
./packages.R:## integers, as obtained by splitting by splitting the package version
./packages.R:## strings on the separators. By default, only valid version specs
./packages.R:## (sequences of integers of length at least two, corresponding to major
./packages.R:## and minor, separated by '.' or '-'), are allowed. If strictness is
./packages.R:## turned off, invalid specs result in integer() (rather than NA) to
./packages.R-## keep things simple. (Note: using NULL would make subscripting more
./packages.R-## cumbersome ...)
./packages.R-
./packages.R:## (In fact, the underlying mechanism could easily be extended to more
./packages.R:## version specs. E.g., one could allow "letters" in version numbers by
./packages.R-## replacing the non-sep characters in the version string by their ASCII
./packages.R-## codes.)
./packages.R-
./packages.R-package_version <-
./packages.R:function(x, strict = TRUE)
./packages.R-{
./packages.R- x <- as.character(x)
./packages.R: y <- rep.int(list(integer()), length(x))
./packages.R- valid_package_version_regexp <-
./packages.R: sprintf("^%s$", .standard_regexps()$valid_package_version)
./packages.R- if(length(x) > 0) {
./packages.R: ok <- (regexpr(valid_package_version_regexp, x) > -1)
./packages.R- if(!all(ok) && strict) stop("invalid version specification")
./packages.R: y[ok] <- lapply(strsplit(x[ok], "[.-]"), as.integer)
./packages.R- }
./packages.R- class(y) <- "package_version"
./packages.R- y
./packages.R-}
./packages.R-
./packages.R-is.package_version <-
./packages.R-function(x)
./packages.R: inherits(x, "package_version")
./packages.R-as.package_version <-
./packages.R-function(x)
./packages.R- if(is.package_version(x)) x else package_version(x)
./packages.R-
./packages.R-.encode_package_version <-
./packages.R:function(x, base = NULL)
./packages.R-{
./packages.R- if(!is.package_version(x)) stop("wrong class")
./packages.R: if(is.null(base)) base <- max(unlist(x), 0) + 1
./packages.R: lens <- as.numeric(sapply(x, length))
./packages.R- ## We store the lengths so that we know when to stop when decoding.
./packages.R: ## Alternatively, we need to be smart about trailing zeroes. One
./packages.R- ## approach is to increment all numbers in the version specs and
./packages.R: ## base by 1, and when decoding only retain the non-zero entries and
./packages.R- ## decrement by 1 one again.
./packages.R: x <- as.numeric(sapply(x,
./packages.R- function(t)
./packages.R: sum(t / base^seq(0, length = length(t)))))
./packages.R: attr(x, "base") <- base
./packages.R: attr(x, "lens") <- lens
./packages.R- x
./packages.R-}
./packages.R-.decode_package_version <-
./packages.R:function(x, base = NULL)
./packages.R-{
./packages.R: if(is.null(base)) base <- attr(x, "base")
./packages.R- if(!is.numeric(base)) stop("wrong argument")
./packages.R: lens <- attr(x, "lens")
./packages.R: y <- vector("list", length = length(x))
./packages.R- for(i in seq(along = x)) {
./packages.R- n <- lens[i]
./packages.R- encoded <- x[i]
--
./packages.R- y
./packages.R-}
./packages.R-
./packages.R-as.character.package_version <-
./packages.R-function(x)
./packages.R: as.character(unlist(lapply(x, paste, collapse = ".")))
./packages.R-print.package_version <-
./packages.R:function(x, ...)
./packages.R-{
./packages.R: print(noquote(sQuote(as.character(x))), ...)
./packages.R- invisible(x)
./packages.R-}
./packages.R-Ops.package_version <-
./packages.R:function(e1, e2)
./packages.R-{
./packages.R- if(nargs() == 1)
./packages.R: stop("unary ", .Generic, " not defined for package_version objects")
./packages.R: boolean <- switch(.Generic, "<" = , ">" = , "==" = , "!=" = ,
./packages.R: "<=" = , ">=" = TRUE, FALSE)
./packages.R- if(!boolean)
./packages.R: stop(.Generic, " not defined for package_version objects")
./packages.R- if(!is.package_version(e1)) e1 <- as.package_version(e1)
./packages.R- if(!is.package_version(e2)) e2 <- as.package_version(e2)
./packages.R: base <- max(unlist(e1), unlist(e2), 0) + 1
./packages.R: e1 <- .encode_package_version(e1, base = base)
./packages.R: e2 <- .encode_package_version(e2, base = base)
./packages.R- NextMethod(.Generic)
./packages.R-}
./packages.R-Summary.package_version <-
./packages.R:function(x, ...)
./packages.R-{
./packages.R: ok <- switch(.Generic, max = , min = TRUE, FALSE)
./packages.R- if(!ok)
./packages.R: stop(.Generic, " not defined for package_version objects")
./packages.R: x <- list(x, ...)
./packages.R- x$na.rm <- NULL
./packages.R: x <- do.call("c", lapply(x, as.package_version))
./packages.R- ##
./packages.R: switch(.Generic,
./packages.R: max = x[which.max(.encode_package_version(x))],
./packages.R- min = x[which.min(.encode_package_version(x))])
./packages.R-}
./packages.R-
./packages.R-c.package_version <-
./packages.R:function(..., recursive = FALSE)
./packages.R-{
./packages.R: x <- unlist(lapply(list(...), as.package_version),
./packages.R- recursive = FALSE)
./packages.R- class(x) <- "package_version"
./packages.R- x
./packages.R-}
./packages.R-
./packages.R-"[.package_version" <-
./packages.R:function(x, i, j)
./packages.R-{
./packages.R- y <- if(missing(j))
./packages.R- unclass(x)[i]
./packages.R- else
./packages.R: lapply(unclass(x)[i], "[", j)
./packages.R- ## Change sequences which are NULL or contains NAs to integer().
./packages.R: bad <- as.logical(sapply(y,
./packages.R- function(t) is.null(t) || any(is.na(t))))
./packages.R- if(any(bad))
./packages.R: y[bad] <- rep.int(list(integer()), length(bad))
./packages.R- class(y) <- "package_version"
./packages.R- y
./packages.R-}
./packages.R-
./packages.R-"[[.package_version" <-
./packages.R:function(x, i)
./packages.R- unclass(x)[[i]]
./packages.R-
./packages.R-"$.package_version" <-
./packages.R:function(x, name)
./packages.R-{
./packages.R: name <- pmatch(name, c("major", "minor", "patchlevel"))
./packages.R: switch(name,
./packages.R: major = as.integer(sapply(x, "[", 1)),
./packages.R: minor = as.integer(sapply(x, "[", 2)),
./packages.R- patchlevel = {
./packages.R: as.integer(sapply(x,
./packages.R: function(s) s[min(3, length(s))]))
./packages.R- })
./packages.R-}
./packages.R-
./packages.R-as.data.frame.package_version <- as.data.frame.vector
./packages.R-
./packages.R-getRversion <- function()
./packages.R: package_version(paste(R.version[c("major", "minor")], collapse = "."))
--
./pairlist.R:as.pairlist <- function(x) .Internal(as.vector(x, "pairlist"))
./pairlist.R-pairlist <- function(...) as.pairlist(list(...))
./pairlist.R-## This is now .Primitive:
./pairlist.R-##is.pairlist <- function(x) typeof(x) == "pairlist"
--
./parse.R:parse <- function(file = "", n = NULL, text = NULL, prompt = "?")
./parse.R-{
./parse.R- if(!is.null(text) && length(as.character(text)) == 0)
./parse.R- return(expression())
./parse.R- if(is.character(file))
./parse.R- if(file == "") file <- stdin()
./parse.R- else {
./parse.R: file <- file(file, "r")
./parse.R- on.exit(close(file))
./parse.R- }
./parse.R: .Internal(parse(file, n, text, prompt))
./parse.R-}
--
./paste.R:paste <- function (..., sep = " ", collapse = NULL)
./paste.R-{
./paste.R- args <- list(...)
./paste.R- if(length(args) == 0)
./paste.R- if(length(collapse) == 0) character(0) else ""
./paste.R- else {
./paste.R- for(i in seq(along = args)) args[[i]] <- as.character(args[[i]])
./paste.R: .Internal(paste(args, sep, collapse))
./paste.R- }
./paste.R-}
./paste.R-
./paste.R-##=== Could we extend paste(.) to (optionally) accept a
./paste.R-## 2-vector for collapse ? With the following functionality
./paste.R-
./paste.R:##- paste.extra <- function(r, collapse=c(", "," and ")) {
./paste.R-##- n <- length(r)
./paste.R-##- if(n <= 1) paste(r)
./paste.R-##- else
./paste.R:##- paste(paste(r[-n],collapse=collapse[1]),
./paste.R:##- r[n], sep=collapse[min(2,length(collapse))])
./paste.R-##- }
--
./pmax.R-### pmax() & pmin() only differ by name and ONE character :
./pmax.R-
./pmax.R:pmax <- function (..., na.rm = FALSE)
./pmax.R-{
./pmax.R- elts <- list(...)
./pmax.R- mmm <- as.vector(elts[[1]])
./pmax.R- has.na <- FALSE
./pmax.R- for (each in elts[-1]) {
./pmax.R: work <- cbind(mmm, as.vector(each)) # recycling..
./pmax.R- nas <- is.na(work)
./pmax.R- if(has.na || (has.na <- any(nas))) {
./pmax.R: work[,1][nas[,1]] <- work[,2][nas[,1]]
./pmax.R: work[,2][nas[,2]] <- work[,1][nas[,2]]
./pmax.R- }
./pmax.R: change <- work[,1] < work[,2]
./pmax.R- change <- change & !is.na(change)
./pmax.R: work[,1][change] <- work[,2][change]
./pmax.R: if (has.na && !na.rm) work[,1][nas[,1] | nas[,2]] <- NA
./pmax.R: mmm <- work[,1]
./pmax.R- }
./pmax.R- mostattributes(mmm) <- attributes(elts[[1]])
./pmax.R- mmm
./pmax.R-}
./pmax.R-
./pmax.R:pmin <- function (..., na.rm = FALSE)
./pmax.R-{
./pmax.R- elts <- list(...)
./pmax.R- mmm <- as.vector(elts[[1]])
./pmax.R- has.na <- FALSE
./pmax.R- for (each in elts[-1]) {
./pmax.R: work <- cbind(mmm, as.vector(each)) # recycling..
./pmax.R- nas <- is.na(work)
./pmax.R- if(has.na || (has.na <- any(nas))) {
./pmax.R: work[,1][nas[,1]] <- work[,2][nas[,1]]
./pmax.R: work[,2][nas[,2]] <- work[,1][nas[,2]]
./pmax.R- }
./pmax.R: change <- work[,1] > work[,2]
./pmax.R- change <- change & !is.na(change)
./pmax.R: work[,1][change] <- work[,2][change]
./pmax.R: if(has.na && !na.rm) work[,1][nas[,1] | nas[,2]] <- NA
./pmax.R: mmm <- work[,1]
./pmax.R- }
./pmax.R- mostattributes(mmm) <- attributes(elts[[1]])
./pmax.R- mmm
--
./pretty.R:pretty <- function(x, n=5, min.n= n %/% 3, shrink.sml = 0.75,
./pretty.R: high.u.bias = 1.5, u5.bias = .5 + 1.5*high.u.bias,
./pretty.R- eps.correct = 0)
./pretty.R-{
./pretty.R- if(!is.numeric(x))
--
./pretty.R- if(!is.numeric(high.u.bias) || high.u.bias < 0)
./pretty.R- stop("'high.u.bias' must be non-negative numeric")
./pretty.R- if(!is.numeric(u5.bias) || u5.bias < 0)
./pretty.R- stop("'u5.bias' must be non-negative numeric")
./pretty.R- if((eps.correct <- as.integer(eps.correct)) < 0 || eps.correct > 2)
./pretty.R: stop("'eps.correct' must be 0, 1, or 2")
./pretty.R: z <- .C("R_pretty", l=as.double(min(x)), u=as.double(max(x)),
./pretty.R: n = n,
./pretty.R: min.n,
./pretty.R: shrink = as.double(shrink.sml),
./pretty.R: high.u.fact = as.double(c(high.u.bias, u5.bias)),
./pretty.R: eps.correct,
./pretty.R: DUP = FALSE, PACKAGE = "base")
./pretty.R: s <- seq(z$l, z$u, length = z$n+1)
./pretty.R- if(!eps.correct && z$n) { # maybe zap smalls from seq() rounding errors
./pretty.R: ## better than zapsmall(s, digits = 14) :
./pretty.R: delta <- diff(range(z$l, z$u)) / z$n
./pretty.R- if(any(small <- abs(s) < 1e-14 * delta))
./pretty.R- s[small] <- 0
./pretty.R- }
--
./print.R:print <- function(x, ...) UseMethod("print")
./print.R-
./print.R:##- Need '...' such that it can be called as NextMethod("print", ...):
./print.R:print.default <- function(x, digits = NULL, quote = TRUE, na.print = NULL,
./print.R: print.gap = NULL, right = FALSE, ...)
./print.R-{
./print.R- noOpt <- missing(digits) && missing(quote) && missing(na.print) &&
./print.R- missing(print.gap) && missing(right) && length(list(...)) == 0
./print.R: .Internal(print.default(x, digits, quote, na.print, print.gap, right,
./print.R- noOpt))
./print.R-}
./print.R-
./print.R-print.matrix <- print.default ## back-compatibility
./print.R-
./print.R-prmatrix <-
./print.R: function (x, rowlab = dn[[1]], collab = dn[[2]],
./print.R: quote = TRUE, right = FALSE,
./print.R: na.print = NULL, ...)
./print.R-{
./print.R- x <- as.matrix(x)
./print.R- dn <- dimnames(x)
./print.R: .Internal(prmatrix(x, rowlab, collab, quote, right, na.print))
./print.R-}
./print.R-
./print.R-noquote <- function(obj) {
./print.R- ## constructor for a useful "minor" class
./print.R: if(!inherits(obj,"noquote")) class(obj) <- c(attr(obj, "class"),"noquote")
./print.R- obj
./print.R-}
./print.R-
./print.R:as.matrix.noquote <- function(x) noquote(NextMethod("as.matrix", x))
./print.R:c.noquote <- function(..., recursive = FALSE) structure(NextMethod(...), class = "noquote")
./print.R-
./print.R:"[.noquote" <- function (x, ...) {
./print.R- attr <- attributes(x)
./print.R- r <- unclass(x)[...] ## shouldn't this be NextMethod?
./print.R: attributes(r) <- c(attributes(r),
./print.R: attr[is.na(match(names(attr),
./print.R: c("dim","dimnames","names")))])
./print.R- r
./print.R-}
./print.R-
./print.R:print.noquote <- function(x, ...) {
./print.R: if(!is.null(cl <- attr(x, "class"))) {
./print.R- cl <- cl[cl != "noquote"]
./print.R: attr(x, "class") <-
./print.R- (if(length(cl)>0) cl else NULL)
./print.R- }
./print.R: print(x, quote = FALSE, ...)
./print.R-}
./print.R-
./print.R-## for alias:
./print.R:print.listof <- function(x, ...)
./print.R-{
./print.R- nn <- names(x)
./print.R- ll <- length(x)
./print.R: if(length(nn) != ll) nn <- paste("Component", seq(ll))
./print.R- for(i in seq(length=ll)) {
./print.R: cat(nn[i], ":\n"); print(x[[i]], ...); cat("\n")
./print.R- }
./print.R- invisible(x)
./print.R-}
./print.R-
./print.R-## used for version:
./print.R:print.simple.list <- function(x, ...)
./print.R: print(noquote(cbind("_"=unlist(x))), ...)
./print.R-
--
./qr.R-#is.qr <- function(x) !is.null(x$qr) && !is.null(x$rank) && !is.null(x$qraux)
./qr.R-
./qr.R:is.qr <- function(x) inherits(x, "qr")
./qr.R-
./qr.R:qr <- function(x, tol = 1e-07, LAPACK = FALSE)
./qr.R-{
./qr.R- x <- as.matrix(x)
./qr.R- if(is.complex(x))
./qr.R: return(structure(.Call("La_zgeqp3", x, PACKAGE = "base"), class="qr"))
./qr.R- if(LAPACK) {
./qr.R: res <- .Call("La_dgeqp3", x, PACKAGE = "base")
./qr.R: attr(res, "useLAPACK") <- TRUE
./qr.R- class(res) <- "qr"
./qr.R- return(res)
./qr.R- }
./qr.R-
./qr.R- p <- ncol(x) # guaranteed to be integer
./qr.R- n <- nrow(x)
./qr.R- if(!is.double(x))
./qr.R- storage.mode(x) <- "double"
./qr.R: res <- .Fortran("dqrdc2",
./qr.R: qr=x,
./qr.R: n,
./qr.R: n,
./qr.R: p,
./qr.R: as.double(tol),
./qr.R: rank=integer(1),
./qr.R: qraux = double(p),
./qr.R: pivot = as.integer(1:p),
./qr.R: double(2*p),
./qr.R: PACKAGE="base")[c(1,6,7,8)]# c("qr", "rank", "qraux", "pivot")
./qr.R- class(res) <- "qr"
./qr.R- res
./qr.R-}
./qr.R-
./qr.R:qr.coef <- function(qr, y)
./qr.R-{
./qr.R- if( !is.qr(qr) )
./qr.R- stop("first argument must be a QR decomposition")
--
./qr.R- p <- ncol(qr$qr)
./qr.R- k <- as.integer(qr$rank)
./qr.R- im <- is.matrix(y)
./qr.R- if (!im) y <- as.matrix(y)
./qr.R- ny <- ncol(y)
./qr.R: if (p==0) return( if (im) matrix(0,p,ny) else numeric(0) )
./qr.R- if(is.complex(qr$qr)) {
./qr.R- if(!is.complex(y)) y[] <- as.complex(y)
./qr.R: coef <- matrix(as.complex(NA), nr=p, nc=ny)
./qr.R: coef[qr$pivot,] <- .Call("qr_coef_cmplx", qr, y, PACKAGE = "base")[1:p]
./qr.R- return(if(im) coef else c(coef))
./qr.R- }
./qr.R- ## else {not complex} :
./qr.R: a <- attr(qr, "useLAPACK")
./qr.R- if(!is.null(a) && is.logical(a) && a) {
./qr.R: coef <- matrix(as.double(NA), nr=p, nc=ny)
./qr.R: coef[qr$pivot,] <- .Call("qr_coef_real", qr, y, PACKAGE = "base")[1:p]
./qr.R- return(if(im) coef else c(coef))
./qr.R- }
./qr.R: if (k==0) return( if (im) matrix(NA,p,ny) else rep.int(NA,p))
./qr.R-
./qr.R- storage.mode(y) <- "double"
./qr.R- if( nrow(y) != n )
./qr.R- stop("'qr' and 'y' must have the same number of rows")
./qr.R: z <- .Fortran("dqrcf",
./qr.R: as.double(qr$qr),
./qr.R: n, k,
./qr.R: as.double(qr$qraux),
./qr.R: y,
./qr.R: ny,
./qr.R: coef=matrix(0,nr=k,nc=ny),
./qr.R: info=integer(1),
./qr.R: NAOK = TRUE, PACKAGE="base")[c("coef","info")]
./qr.R- if(z$info != 0) stop("exact singularity in 'qr.coef'")
./qr.R- if(k < p) {
./qr.R: coef <- matrix(as.double(NA), nr=p, nc=ny)
./qr.R: coef[qr$pivot[1:k],] <- z$coef
./qr.R- }
./qr.R- else coef <- z$coef
./qr.R-
--
./qr.R- colnames(coef) <- nam
./qr.R-
./qr.R- if(im) coef else drop(coef)
./qr.R-}
./qr.R-
./qr.R:qr.qy <- function(qr, y)
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R- if(is.complex(qr$qr)) {
./qr.R- y <- as.matrix(y)
./qr.R- if(!is.complex(y)) y[] <- as.complex(y)
./qr.R: return(.Call("qr_qy_cmplx", qr, y, 0, PACKAGE = "base"))
./qr.R- }
./qr.R: a <- attr(qr, "useLAPACK")
./qr.R- if(!is.null(a) && is.logical(a) && a)
./qr.R: return(.Call("qr_qy_real", qr, as.matrix(y), 0, PACKAGE = "base"))
./qr.R- n <- nrow(qr$qr)
./qr.R-# p <- ncol(qr$qr)
./qr.R- k <- as.integer(qr$rank)
./qr.R- ny <- NCOL(y)
./qr.R- storage.mode(y) <- "double"
./qr.R- if(NROW(y) != n)
./qr.R- stop("'qr' and 'y' must have the same number of rows")
./qr.R: .Fortran("dqrqy",
./qr.R: as.double(qr$qr),
./qr.R: n, k,
./qr.R: as.double(qr$qraux),
./qr.R: y,
./qr.R: ny,
./qr.R: qy = y,# incl. {dim}names
./qr.R- PACKAGE="base")$qy
./qr.R-}
./qr.R-
./qr.R:qr.qty <- function(qr, y)
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R- if(is.complex(qr$qr)){
./qr.R- y <- as.matrix(y)
./qr.R- if(!is.complex(y)) y[] <- as.complex(y)
./qr.R: return(.Call("qr_qy_cmplx", qr, y, 1, PACKAGE = "base"))
./qr.R- }
./qr.R: a <- attr(qr, "useLAPACK")
./qr.R- if(!is.null(a) && is.logical(a) && a)
./qr.R: return(.Call("qr_qy_real", qr, as.matrix(y), 1, PACKAGE = "base"))
./qr.R-
./qr.R- n <- nrow(qr$qr)
./qr.R-# p <- ncol(qr$qr)
./qr.R- k <- as.integer(qr$rank)
./qr.R- ny <- NCOL(y)
./qr.R- if(NROW(y) != n)
./qr.R- stop("'qr' and 'y' must have the same number of rows")
./qr.R- storage.mode(y) <- "double"
./qr.R: .Fortran("dqrqty",
./qr.R: as.double(qr$qr),
./qr.R: n, k,
./qr.R: as.double(qr$qraux),
./qr.R: y,
./qr.R: ny,
./qr.R: qty = y,# incl. {dim}names
./qr.R- PACKAGE = "base")$qty
./qr.R-}
./qr.R-
./qr.R:qr.resid <- function(qr, y)
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R- if(is.complex(qr$qr)) stop("not implemented for complex 'qr'")
./qr.R: a <- attr(qr, "useLAPACK")
./qr.R- if(!is.null(a) && is.logical(a) && a)
./qr.R- stop("not supported for LAPACK QR")
./qr.R- k <- as.integer(qr$rank)
--
./qr.R-# p <- ncol(qr$qr)
./qr.R- ny <- NCOL(y)
./qr.R- if( NROW(y) != n )
./qr.R- stop("'qr' and 'y' must have the same number of rows")
./qr.R- storage.mode(y) <- "double"
./qr.R: .Fortran("dqrrsd",
./qr.R: as.double(qr$qr), n, k,
./qr.R: as.double(qr$qraux),
./qr.R: y,
./qr.R: ny,
./qr.R: rsd = y,# incl. {dim}names
./qr.R- PACKAGE="base")$rsd
./qr.R-}
./qr.R-
./qr.R:qr.fitted <- function(qr, y, k=qr$rank)
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R- if(is.complex(qr$qr)) stop("not implemented for complex 'qr'")
./qr.R: a <- attr(qr, "useLAPACK")
./qr.R- if(!is.null(a) && is.logical(a) && a)
./qr.R- stop("not supported for LAPACK QR")
./qr.R- n <- nrow(qr$qr)
--
./qr.R- if(k > qr$rank) stop("'k' is too large")
./qr.R- ny <- NCOL(y)
./qr.R- if( NROW(y) != n )
./qr.R- stop("'qr' and 'y' must have the same number of rows")
./qr.R- storage.mode(y) <- "double"
./qr.R: .Fortran("dqrxb",
./qr.R: as.double(qr$qr),
./qr.R: n, k,
./qr.R: as.double(qr$qraux),
./qr.R: y,
./qr.R: ny,
./qr.R: xb = (yy <- y),# incl. {dim}names
./qr.R: DUP=FALSE, PACKAGE="base")$xb
./qr.R-}
./qr.R-
./qr.R-## qr.solve is defined in ./solve.R
./qr.R-
./qr.R-##---- The next three are from Doug Bates ('st849'):
./qr.R:qr.Q <- function (qr, complete = FALSE,
./qr.R: Dvec = rep.int(if (cmplx) 1 + 0i else 1,
./qr.R- if (complete) dqr[1] else min(dqr)))
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R- dqr <- dim(qr$qr)
./qr.R- cmplx <- mode(qr$qr) == "complex"
./qr.R- D <-
./qr.R: if (complete) diag(Dvec, dqr[1])
./qr.R- else {
./qr.R- ncols <- min(dqr)
./qr.R: diag(Dvec[1:ncols], nrow = dqr[1], ncol = ncols)
./qr.R- }
./qr.R: qr.qy(qr, D)
./qr.R-}
./qr.R-
./qr.R:qr.R <- function (qr, complete = FALSE)
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R- R <- qr$qr
./qr.R- if (!complete)
./qr.R: R <- R[seq(min(dim(R))), , drop = FALSE]
./qr.R- R[row(R) > col(R)] <- 0
./qr.R- R
./qr.R-}
./qr.R-
./qr.R:qr.X <- function (qr, complete = FALSE,
./qr.R- ncol = if (complete) nrow(R) else min(dim(R)))
./qr.R-{
./qr.R- if(!is.qr(qr)) stop("argument is not a QR decomposition")
./qr.R: pivoted <- !identical(qr$pivot, seq(along=qr$pivot))
./qr.R: R <- qr.R(qr, complete = TRUE)
./qr.R- if(pivoted && ncol < length(qr$pivot))
./qr.R- stop("need larger value of 'ncol' as pivoting occurred")
./qr.R- cmplx <- mode(R) == "complex"
./qr.R- p <- dim(R)[2]
./qr.R- if (ncol < p)
./qr.R: R <- R[, 1:ncol, drop = FALSE]
./qr.R- else if (ncol > p) {
./qr.R: tmp <- diag(if (!cmplx) 1 else 1 + 0i, nrow(R), ncol)
./qr.R: tmp[, 1:p] <- R
./qr.R- R <- tmp
./qr.R- }
./qr.R: res <- qr.qy(qr, R)
./qr.R: if(pivoted) res[, qr$pivot] <- res[, seq(along=qr$pivot)]
./qr.R- res
./qr.R-}
--
./quit.R:quit <- function(save = "default", status=0, runLast=TRUE)
./quit.R: .Internal(quit(save, status, runLast))
./quit.R-q <- quit
--
./range.R:range <- function(..., na.rm = FALSE)
./range.R: .Internal(range(..., na.rm = na.rm))
./range.R-
./range.R:range.default <- function(..., na.rm = FALSE, finite = FALSE) {
./range.R: x <- c(..., recursive = TRUE)
./range.R- if(finite) x <- x[is.finite(x)]
./range.R- else if(na.rm) x <- x[!is.na(x)]
./range.R: c(min(x), max(x)) # even if x is empty from 1.5.0
./range.R-}
--
./rank.R:rank <- function(x, na.last = TRUE,
./rank.R: ties.method=c("average", "first", "random", "max", "min"))
./rank.R-{
./rank.R- nas <- is.na(x)
./rank.R- ties.method <- match.arg(ties.method)
./rank.R: y <- switch(ties.method,
./rank.R: "average"= , "min"= , "max" =
./rank.R: .Internal(rank( x[!nas], ties.method)),
./rank.R: "first" = sort.list(sort.list(x[!nas])),
./rank.R: "random" = sort.list(order( x[!nas], runif(sum(!nas)))))
./rank.R- if(!is.na(na.last) && any(nas)) {
./rank.R: ## the internal code has ranks in [1, length(y)]
./rank.R- storage.mode(x) <- "double"
./rank.R- NAkeep <- (na.last == "keep")
./rank.R- if(NAkeep || na.last) {
--
./raw.R:raw <- function(length = 0) vector("raw", length)
./raw.R-
./raw.R:as.raw <- function(x) as.vector(x, "raw")
./raw.R-
./raw.R-charToRaw <- function(x) .Internal(charToRaw(x))
./raw.R:rawToChar <- function(x, multiple=FALSE) .Internal(rawToChar(x, multiple))
./raw.R-
./raw.R:rawShift <- function(x, n) .Internal(rawShift(x, n))
./raw.R-
./raw.R-rawToBits <- function(x) .Internal(rawToBits(x))
./raw.R-intToBits <- function(x) .Internal(intToBits(x))
./raw.R-
./raw.R:packBits <- function(x, type=c("raw", "integer"))
./raw.R-{
./raw.R- type <- match.arg(type)
./raw.R: .Internal(packBits(x, type))
./raw.R-}
--
./readtable.R-count.fields <-
./readtable.R:function(file, sep = "", quote = "\"'", skip = 0,
./readtable.R: blank.lines.skip = TRUE, comment.char = "#")
./readtable.R-{
./readtable.R- if(is.character(file)) {
./readtable.R- file <- file(file)
./readtable.R- on.exit(close(file))
./readtable.R- }
./readtable.R: if(!inherits(file, "connection"))
./readtable.R- stop("'file' must be a character string or connection")
./readtable.R: .Internal(count.fields(file, sep, quote, skip, blank.lines.skip,
./readtable.R- comment.char))
./readtable.R-}
./readtable.R-
./readtable.R-
./readtable.R-type.convert <-
./readtable.R:function(x, na.strings = "NA", as.is = FALSE, dec = ".")
./readtable.R: .Internal(type.convert(x, na.strings, as.is, dec))
./readtable.R-
./readtable.R-
./readtable.R-read.table <-
./readtable.R:function(file, header = FALSE, sep = "", quote = "\"'", dec = ".",
./readtable.R: row.names, col.names, as.is = FALSE,
./readtable.R: na.strings = "NA", colClasses = NA,
./readtable.R: nrows = -1, skip = 0,
./readtable.R: check.names = TRUE, fill = !blank.lines.skip,
./readtable.R: strip.white = FALSE, blank.lines.skip = TRUE,
./readtable.R- comment.char = "#")
./readtable.R-{
./readtable.R- if(is.character(file)) {
./readtable.R: file <- file(file, "r")
./readtable.R- on.exit(close(file))
./readtable.R- }
./readtable.R: if(!inherits(file, "connection"))
./readtable.R- stop("'file' must be a character string or connection")
./readtable.R- if(!isOpen(file)) {
./readtable.R: open(file, "r")
./readtable.R- on.exit(close(file))
./readtable.R- }
./readtable.R-
./readtable.R: if(skip > 0) readLines(file, skip)
./readtable.R: ## read a few lines to determine header, no of cols.
./readtable.R: nlines <- if (nrows < 0) 5 else min(5, (header + nrows))
./readtable.R-
./readtable.R: lines <- .Internal(readTableHead(file, nlines, comment.char,
./readtable.R: blank.lines.skip, quote))
./readtable.R- nlines <- length(lines)
./readtable.R- if(!nlines) {
./readtable.R- if(missing(col.names))
./readtable.R- stop("no lines available in input")
./readtable.R- else {
./readtable.R: tmp <- vector("list", length(col.names))
./readtable.R- names(tmp) <- col.names
./readtable.R- class(tmp) <- "data.frame"
./readtable.R- return(tmp)
./readtable.R- }
./readtable.R- }
./readtable.R- if(all(nchar(lines) == 0)) stop("empty beginning of file")
./readtable.R: pushBack(c(lines, lines), file)
./readtable.R: first <- scan(file, what = "", sep = sep, quote = quote,
./readtable.R: nlines = 1, quiet = TRUE, skip = 0,
./readtable.R: strip.white = TRUE,
./readtable.R: blank.lines.skip = blank.lines.skip,
./readtable.R- comment.char = comment.char)
./readtable.R- col1 <- if(missing(col.names)) length(first) else length(col.names)
./readtable.R- col <- numeric(nlines - 1)
./readtable.R- if (nlines > 1)
./readtable.R- for (i in seq(along=col))
./readtable.R: col[i] <- length(scan(file, what = "", sep = sep,
./readtable.R: quote = quote,
./readtable.R: nlines = 1, quiet = TRUE, skip = 0,
./readtable.R: strip.white = strip.white,
./readtable.R: blank.lines.skip = blank.lines.skip,
./readtable.R- comment.char = comment.char))
./readtable.R: cols <- max(col1, col)
./readtable.R-
./readtable.R- ## basic column counting and header determination;
./readtable.R- ## rlabp (logical) := it looks like we have column names
--
./readtable.R- if(rlabp && missing(header))
./readtable.R- header <- TRUE
./readtable.R- if(!header) rlabp <- FALSE
./readtable.R-
./readtable.R- if (header) {
./readtable.R: readLines(file, 1) # skip over header
./readtable.R- if(missing(col.names)) col.names <- first
./readtable.R- else if(length(first) != length(col.names))
./readtable.R- warning("header and 'col.names' are of different lengths")
./readtable.R-
./readtable.R- } else if (missing(col.names))
./readtable.R: col.names <- paste("V", 1:cols, sep = "")
./readtable.R- if(length(col.names) + rlabp < cols)
./readtable.R- stop("more columns than column names")
./readtable.R- if(fill && length(col.names) > cols)
--
./readtable.R- if(!fill && cols > 0 && length(col.names) > cols)
./readtable.R- stop("more column names than columns")
./readtable.R- if(cols == 0) stop("first five rows are empty: giving up")
./readtable.R-
./readtable.R-
./readtable.R: if(check.names) col.names <- make.names(col.names, unique = TRUE)
./readtable.R: if (rlabp) col.names <- c("row.names", col.names)
./readtable.R-
./readtable.R- nmColClasses <- names(colClasses)
./readtable.R- if(length(colClasses) < cols)
./readtable.R- if(is.null(nmColClasses)) {
./readtable.R: colClasses <- rep(colClasses, length.out=cols)
./readtable.R- } else {
./readtable.R: tmp <- rep(as.character(NA), length.out=cols)
./readtable.R- names(tmp) <- col.names
./readtable.R: i <- match(nmColClasses, col.names, 0)
./readtable.R- if(any(i <= 0))
./readtable.R- warning("not all columns named in 'colClasses' exist")
./readtable.R- tmp[ i[i > 0] ] <- colClasses
--
./readtable.R-
./readtable.R-
./readtable.R- ## set up for the scan of the file.
./readtable.R- ## we read unknown values as character strings and convert later.
./readtable.R-
./readtable.R: what <- rep.int(list(""), cols)
./readtable.R- names(what) <- col.names
./readtable.R-
./readtable.R: colClasses[colClasses %in% c("real", "double")] <- "numeric"
./readtable.R- known <- colClasses %in%
./readtable.R: c("logical", "integer", "numeric", "complex", "character")
./readtable.R: what[known] <- sapply(colClasses[known], do.call, list(0))
./readtable.R- what[colClasses %in% "NULL"] <- list(NULL)
./readtable.R: keep <- !sapply(what, is.null)
./readtable.R-
./readtable.R: data <- scan(file = file, what = what, sep = sep, quote = quote,
./readtable.R: dec = dec, nmax = nrows, skip = 0,
./readtable.R: na.strings = na.strings, quiet = TRUE, fill = fill,
./readtable.R: strip.white = strip.white,
./readtable.R: blank.lines.skip = blank.lines.skip, multi.line = FALSE,
./readtable.R- comment.char = comment.char)
./readtable.R-
./readtable.R- nlines <- length(data[[ which(keep)[1] ]])
--
./readtable.R- ## convert to numeric or factor variables
./readtable.R- ## (depending on the specified value of "as.is").
./readtable.R- ## we do this here so that columns match up
./readtable.R-
./readtable.R- if(cols != length(data)) { # this should never happen
./readtable.R: warning("cols = ", cols, " != length(data) = ", length(data),
./readtable.R- domain = NA)
./readtable.R- cols <- length(data)
./readtable.R- }
./readtable.R-
./readtable.R- if(is.logical(as.is)) {
./readtable.R: as.is <- rep(as.is, length.out=cols)
./readtable.R- } else if(is.numeric(as.is)) {
./readtable.R- if(any(as.is < 1 | as.is > cols))
./readtable.R- stop("invalid numeric 'as.is' expression")
./readtable.R: i <- rep.int(FALSE, cols)
./readtable.R- i[as.is] <- TRUE
./readtable.R- as.is <- i
./readtable.R- } else if(is.character(as.is)) {
./readtable.R: i <- match(as.is, col.names, 0)
./readtable.R- if(any(i <= 0))
./readtable.R- warning("not all columns named in 'as.is' exist")
./readtable.R- i <- i[i > 0]
./readtable.R: as.is <- rep.int(FALSE, cols)
./readtable.R- as.is[i] <- TRUE
./readtable.R- } else if (length(as.is) != cols)
./readtable.R: stop(gettextf("'as.is' has the wrong length %d != cols = %d",
./readtable.R: length(as.is), cols), domain = NA)
./readtable.R-
./readtable.R- do <- keep & !known # & !as.is
./readtable.R- if(rlabp) do[1] <- FALSE # don't convert "row.names"
./readtable.R- for (i in (1:cols)[do]) {
./readtable.R- data[[i]] <-
./readtable.R- if (is.na(colClasses[i]))
./readtable.R: type.convert(data[[i]], as.is = as.is[i], dec = dec,
./readtable.R- na.strings = character(0))
./readtable.R- ## as na.strings have already been converted to
./readtable.R- else if (colClasses[i] == "factor") as.factor(data[[i]])
./readtable.R- else if (colClasses[i] == "Date") as.Date(data[[i]])
./readtable.R- else if (colClasses[i] == "POSIXct") as.POSIXct(data[[i]])
./readtable.R: else as(data[[i]], colClasses[i])
./readtable.R- }
./readtable.R-
./readtable.R- ## now determine row names
--
./readtable.R- else row.names <- as.character(seq(len=nlines))
./readtable.R- } else if (is.null(row.names)) {
./readtable.R- row.names <- as.character(seq(len=nlines))
./readtable.R- } else if (is.character(row.names)) {
./readtable.R- if (length(row.names) == 1) {
./readtable.R: rowvar <- (1:cols)[match(col.names, row.names, 0) == 1]
./readtable.R- row.names <- data[[rowvar]]
./readtable.R- data <- data[-rowvar]
./readtable.R- keep <- keep[-rowvar]
--
./readtable.R- row.names(data) <- row.names
./readtable.R- data
./readtable.R-}
./readtable.R-
./readtable.R-read.csv <-
./readtable.R:function (file, header = TRUE, sep = ",", quote="\"", dec=".",
./readtable.R: fill = TRUE, ...)
./readtable.R: read.table(file = file, header = header, sep = sep,
./readtable.R: quote = quote, dec = dec, fill = fill, ...)
./readtable.R-
./readtable.R-read.csv2 <-
./readtable.R:function (file, header = TRUE, sep = ";", quote="\"", dec=",",
./readtable.R: fill = TRUE, ...)
./readtable.R: read.table(file = file, header = header, sep = sep,
./readtable.R: quote = quote, dec = dec, fill = fill, ...)
./readtable.R-
./readtable.R-read.delim <-
./readtable.R:function (file, header = TRUE, sep = "\t", quote="\"", dec=".",
./readtable.R: fill = TRUE, ...)
./readtable.R: read.table(file = file, header = header, sep = sep,
./readtable.R: quote = quote, dec = dec, fill = fill, ...)
./readtable.R-
./readtable.R-read.delim2 <-
./readtable.R:function (file, header = TRUE, sep = "\t", quote="\"", dec=",",
./readtable.R: fill = TRUE, ...)
./readtable.R: read.table(file = file, header = header, sep = sep,
./readtable.R: quote = quote, dec = dec, fill = fill, ...)
./readtable.R-
--
./rep.R:rep <- function(x, times, ...) UseMethod("rep")
./rep.R-
./rep.R:rep.default <- function(x, times, length.out, each, ...)
./rep.R-{
./rep.R- if (length(x) == 0)
./rep.R- return(if(missing(length.out)) x else x[seq(len=length.out)])
./rep.R- if (!missing(each)) {
./rep.R: tm <- .Internal(rep(each, length(x)))
./rep.R- nm <- names(x)
./rep.R: x <- .Internal(rep(x, tm))
./rep.R: if(!is.null(nm)) names(x) <- .Internal(rep(nm, tm))
./rep.R- if(missing(length.out) && missing(times)) return(x)
./rep.R- }
./rep.R- if (!missing(length.out)) # takes precedence over times
./rep.R- times <- ceiling(length.out/length(x))
./rep.R: r <- .Internal(rep(x, times))
./rep.R: if(!is.null(nm <- names(x))) names(r) <- .Internal(rep(nm, times))
./rep.R- if (!missing(length.out))
./rep.R- return(r[if(length.out > 0) 1:length.out else integer(0)])
./rep.R- return(r)
./rep.R-}
./rep.R-
./rep.R:rep.int <- function(x, times) .Internal(rep(x, times))
--
./replace.R-replace <-
./replace.R: function (x, list, values)
./replace.R-{
./replace.R- x[list] <- values
./replace.R- x
--
./replicate.R:replicate <- function(n, expr, simplify = TRUE)
./replicate.R: sapply(integer(n),
./replicate.R: eval.parent(substitute(function(...)expr)), simplify = simplify)
--
./rle.R-{
./rle.R- if (!is.vector(x))
./rle.R- stop("'x' must be a vector")
./rle.R- n <- length(x)
./rle.R- if (n == 0)
./rle.R: return(list(lengths = integer(0), values = x))
./rle.R- y <- x[-1] != x[-n]
./rle.R: i <- c(which(y | is.na(y)), n)
./rle.R: structure(list(lengths = diff(c(0:0, i)), values = x[i]),
./rle.R- class = "rle")
./rle.R-}
./rle.R-
./rle.R:print.rle <- function(x, digits = getOption("digits"), ...)
./rle.R-{
./rle.R- if(is.null(digits)) digits <- getOption("digits")
./rle.R- cat("Run Length Encoding\n lengths:")
./rle.R- str(x$lengths)
./rle.R- cat(" values :")
./rle.R: str(x$values, digits = digits)
./rle.R- invisible(x)
./rle.R-}
./rle.R-
./rle.R:inverse.rle <- function(x, ...)
./rle.R-{
./rle.R- if(is.null(le <- x$lengths) ||
./rle.R- is.null(v <- x$values) || length(le) != length(v))
./rle.R- stop("invalid 'rle' structure")
./rle.R: rep(v, le)
./rle.R-}
./rle.R-
--
./rm.R-rm <-
./rm.R: function (..., list = character(0), pos = -1, envir = as.environment(pos),
./rm.R- inherits = FALSE)
./rm.R-{
./rm.R: names <- sapply(match.call(expand.dots=FALSE)$..., as.character)
./rm.R- if (length(names)==0) names<-character(0)
./rm.R: list <- .Primitive("c")(list, names)
./rm.R: .Internal(remove(list, envir, inherits))
./rm.R-}
./rm.R-
./rm.R-remove <- rm
--
./rowsum.R:rowsum<-function(x,group,reorder=TRUE,...)
./rowsum.R- UseMethod("rowsum")
./rowsum.R-
./rowsum.R:rowsum.default <-function(x,group,reorder=TRUE,...){
./rowsum.R- if (!is.numeric(x))
./rowsum.R- stop("'x' must be numeric")
./rowsum.R- if (length(group) != NROW(x))
./rowsum.R- stop("incorrect length for 'group'")
./rowsum.R- if (any(is.na(group)))
./rowsum.R- warning("missing values for 'group'")
./rowsum.R- ugroup<-unique(group)
./rowsum.R: if (reorder) ugroup<-sort(ugroup,na.last=TRUE)
./rowsum.R-
./rowsum.R: rval<-.Call("Rrowsum_matrix",x,NCOL(x),group,ugroup,PACKAGE="base")
./rowsum.R-
./rowsum.R: dimnames(rval)<-list(as.character(ugroup),dimnames(x)[[2]])
./rowsum.R- rval
./rowsum.R-}
./rowsum.R-
./rowsum.R:rowsum.data.frame<-function(x,group,reorder=TRUE,...){
./rowsum.R- if (!is.data.frame(x)) stop("not a data frame") ## make MM happy
./rowsum.R- if (length(group) != NROW(x))
./rowsum.R- stop("incorrect length for 'group'")
./rowsum.R- if (any(is.na(group)))
./rowsum.R- warning("missing values for 'group'")
./rowsum.R- ugroup<-unique(group)
./rowsum.R: if (reorder) ugroup<-sort(ugroup,na.last=TRUE)
./rowsum.R-
./rowsum.R: rval<-.Call("Rrowsum_df", x, NCOL(x), group, ugroup, PACKAGE="base")
./rowsum.R-
./rowsum.R: as.data.frame(rval, row.names=as.character(ugroup))
./rowsum.R-}
--
./sample.R:sample <- function(x, size, replace=FALSE, prob=NULL)
./sample.R-{
./sample.R- if(length(x) == 1 && x >= 1) {
./sample.R- if(missing(size)) size <- x
./sample.R: .Internal(sample(x, size, replace, prob))
./sample.R- }
./sample.R- else {
./sample.R- if(missing(size)) size <- length(x)
./sample.R: x[.Internal(sample(length(x), size, replace, prob))]
./sample.R- }
./sample.R-}
--
./sapply.R:sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE)
./sapply.R-{
./sapply.R- FUN <- match.fun(FUN)
./sapply.R: answer <- lapply(as.list(X), FUN, ...)
./sapply.R- if(USE.NAMES && is.character(X) && is.null(names(answer)))
./sapply.R- names(answer) <- X
./sapply.R- if(simplify && length(answer) &&
./sapply.R: length(common.len <- unique(unlist(lapply(answer, length)))) == 1) {
./sapply.R- if(common.len == 1)
./sapply.R: unlist(answer, recursive = FALSE)
./sapply.R- else if(common.len > 1)
./sapply.R: array(unlist(answer, recursive = FALSE),
./sapply.R: dim= c(common.len, length(X)),
./sapply.R- dimnames= if(!(is.null(n1 <- names(answer[[1]])) &
./sapply.R: is.null(n2 <- names(answer)))) list(n1,n2))
./sapply.R- else answer
./sapply.R- } else answer
./sapply.R-}
--
./scale.R:scale <- function(x, center = TRUE, scale = TRUE) UseMethod("scale")
./scale.R-
./scale.R:scale.default <- function(x, center = TRUE, scale = TRUE)
./scale.R-{
./scale.R- x <- as.matrix(x)
./scale.R- nc <- ncol(x)
./scale.R- if (is.logical(center)) {
./scale.R- if (center) {
./scale.R: center <- colMeans(x, na.rm=TRUE)
./scale.R: x <- sweep(x, 2, center)
./scale.R- }
./scale.R- }
./scale.R- else if (is.numeric(center) && (length(center) == nc))
./scale.R: x <- sweep(x, 2, center)
./scale.R- else
./scale.R- stop("length of 'center' must equal the number of columns of 'x'")
./scale.R- if (is.logical(scale)) {
./scale.R- if (scale) {
./scale.R- f <- function(v) {
./scale.R- v <- v[!is.na(v)]
./scale.R: sqrt(sum(v^2) / max(1, length(v) - 1))
./scale.R- }
./scale.R: scale <- apply(x, 2, f)
./scale.R: x <- sweep(x, 2, scale, "/")
./scale.R- }
./scale.R- }
./scale.R- else if (is.numeric(scale) && length(scale) == nc)
./scale.R: x <- sweep(x, 2, scale, "/")
./scale.R- else
./scale.R- stop("length of 'scale' must equal the number of columns of 'x'")
./scale.R: if(is.numeric(center)) attr(x, "scaled:center") <- center
./scale.R: if(is.numeric(scale)) attr(x, "scaled:scale") <- scale
./scale.R- x
./scale.R-}
--
./scan.R-scan <-
./scan.R:function(file = "", what = double(0), nmax = -1, n = -1, sep = "",
./scan.R: quote = if(identical(sep, "\n")) "" else "'\"",
./scan.R: dec = ".", skip = 0, nlines = 0,
./scan.R: na.strings = "NA", flush = FALSE, fill = FALSE,
./scan.R: strip.white = FALSE, quiet = FALSE, blank.lines.skip = TRUE,
./scan.R: multi.line = TRUE, comment.char = "", allowEscapes = TRUE)
./scan.R-{
./scan.R- na.strings <- as.character(na.strings)# allow it to be NULL
./scan.R- if(!missing(n)) {
./scan.R- if(missing(nmax))
./scan.R: nmax <- n / pmax(length(what), 1)
./scan.R- else
./scan.R: stop("either specify 'nmax' or 'n', but not both.")
./scan.R- }
./scan.R- if(is.character(file))
./scan.R- if(file == "") file <- stdin()
./scan.R- else {
./scan.R: file <- file(file, "r")
./scan.R- on.exit(close(file))
./scan.R- }
./scan.R: if(!inherits(file, "connection"))
./scan.R- stop("'file' must be a character string or connection")
./scan.R: .Internal(scan(file, what, nmax, sep, dec, quote, skip, nlines,
./scan.R: na.strings, flush, fill, strip.white, quiet,
./scan.R: blank.lines.skip, multi.line, comment.char,
./scan.R- allowEscapes))
./scan.R-}
--
./seq.R-seq <- function(...) UseMethod("seq")
./seq.R-
./seq.R-seq.default <-
./seq.R: function(from = 1, to = 1, by = ((to - from)/(length.out - 1)),
./seq.R: length.out = NULL, along.with = NULL, ...)
./seq.R-{
./seq.R- if((One <- nargs() == 1) && !missing(from)) {
./seq.R- lf <- length(from)
--
./seq.R- if(n < 0)
./seq.R- stop("wrong sign in 'by' argument")
./seq.R- if(n > .Machine$integer.max)
./seq.R- stop("'by' argument is much too small")
./seq.R-
./seq.R: dd <- abs(del)/max(abs(to), abs(from))
./seq.R- if (dd < 100*.Machine$double.eps) return(from)
./seq.R- n <- as.integer(n + 1e-7)
./seq.R- from + (0:n) * by
--
./seq.R- to <- from + length.out - 1
./seq.R- if(missing(from))
./seq.R- from <- to - length.out + 1
./seq.R- if(length.out > 2)
./seq.R- if(from == to)
./seq.R: rep.int(from, length.out)
./seq.R: else as.vector(c(from, from + (1:(length.out - 2)) * by, to))
./seq.R: else as.vector(c(from, to))[1:length.out]
./seq.R- }
./seq.R- else if(missing(to))
./seq.R- from + (0:(length.out - 1)) * by
--
./seq.R-
./seq.R-sequence <- function(nvec)
./seq.R-{
./seq.R- s <- integer(0)
./seq.R- for(i in nvec)
./seq.R: s <- c(s, 1:i)
./seq.R- return(s)
./seq.R-}
--
./serialize.R-.saveRDS <-
./serialize.R:function(object, file = "", ascii = FALSE, version = NULL,
./serialize.R: compress = FALSE, refhook = NULL)
./serialize.R-{
./serialize.R- if(is.character(file)) {
./serialize.R- if(file == "") stop("'file' must be non-empty string")
./serialize.R- mode <- if(ascii) "w" else "wb"
./serialize.R: con <- if(compress) gzfile(file, mode) else file(file, mode)
./serialize.R- on.exit(close(con))
./serialize.R- }
./serialize.R: else if(inherits(file, "connection")) {
./serialize.R- con <- file
./serialize.R- if(missing(ascii)) ascii <- summary(con)$text == "text"
./serialize.R- }
./serialize.R- else
./serialize.R- stop("bad 'file' argument")
./serialize.R: invisible(.Internal(serializeToConn(object, con, ascii, version, refhook)))
./serialize.R-}
./serialize.R-
./serialize.R-.readRDS <-
./serialize.R:function(file, refhook = NULL)
./serialize.R-{
./serialize.R- if(is.character(file)) {
./serialize.R: con <- gzfile(file, "rb")
./serialize.R- on.exit(close(con))
./serialize.R- }
./serialize.R: else if(inherits(file, "connection"))
./serialize.R- con <- gzcon(file)
./serialize.R- else
./serialize.R- stop("bad 'file' argument")
./serialize.R: .Internal(unserializeFromConn(con, refhook))
./serialize.R-}
./serialize.R-
./serialize.R:serialize <- function(object, connection, ascii = FALSE, refhook = NULL) {
./serialize.R- if (! is.null(connection)) {
./serialize.R: if (!inherits(connection, "connection"))
./serialize.R- stop("'connection' must be a connection")
./serialize.R- if (missing(ascii)) ascii <- summary(connection)$text == "text"
./serialize.R- }
./serialize.R: if (! ascii && inherits(connection, "sockconn"))
./serialize.R: .Call("R_serializeb", object, connection, refhook, PACKAGE="base")
./serialize.R- else
./serialize.R: .Call("R_serialize", object, connection, ascii, refhook,
./serialize.R- PACKAGE="base")
./serialize.R-}
./serialize.R-
./serialize.R:unserialize <- function(connection, refhook = NULL) {
./serialize.R: if (! is.character(connection) && !inherits(connection, "connection"))
./serialize.R- stop("'connection' must be a connection")
./serialize.R: .Call("R_unserialize", connection, refhook, PACKAGE="base")
./serialize.R-}
--
./sets.R:union <- function(x, y) unique(c(x, y))
./sets.R-
./sets.R:intersect <- function(x, y) unique(y[match(x, y, 0)])
./sets.R-
./sets.R:setdiff <- function(x, y)
./sets.R: unique(if(length(x) || length(y)) x[match(x, y, 0) == 0] else x)
./sets.R-
./sets.R:## Faster versions, see R-devel, Jan.4-6, 2000; optimize later...
./sets.R:setequal <- function(x, y) all(c(match(x, y, 0) > 0, match(y, x, 0) > 0))
./sets.R-
./sets.R-## same as %in% ( ./match.R ) but different arg names:
./sets.R:is.element <- function(el, set) match(el, set, 0) > 0
--
./sink.R:sink <- function(file=NULL, append = FALSE, type = c("output", "message"),
./sink.R- split=FALSE)
./sink.R-{
./sink.R- type <- match.arg(type)
./sink.R- if(type == "message") {
./sink.R- if(is.null(file)) file <- stderr()
./sink.R: else if(!inherits(file, "connection") || !isOpen(file))
./sink.R- stop("'file' must be NULL or an already open connection")
./sink.R- if (split) stop("cannot split the message connection")
./sink.R: .Internal(sink(file, FALSE, TRUE, FALSE))
./sink.R- } else {
./sink.R- closeOnExit <- FALSE
./sink.R- if(is.null(file)) file <- -1
./sink.R- else if(is.character(file)) {
./sink.R: file <- file(file, ifelse(append, "a", "w"))
./sink.R- closeOnExit <- TRUE
./sink.R: } else if(!inherits(file, "connection"))
./sink.R: stop("'file' must be NULL, a connection or a character string")
./sink.R: .Internal(sink(file, closeOnExit, FALSE,split))
./sink.R- }
./sink.R-}
./sink.R-
./sink.R:sink.number <- function(type = c("output", "message"))
./sink.R-{
./sink.R- type <- match.arg(type)
./sink.R- .Internal(sink.number(type != "message"))
--
./solve.R:solve.qr <- function(a, b, ...)
./solve.R-{
./solve.R- if( !is.qr(a) )
./solve.R- stop("this is the \"qr\" method for the generic function solve()")
--
./solve.R- if( a$rank != nc )
./solve.R- stop("singular matrix 'a' in 'solve'")
./solve.R- if( missing(b) ) {
./solve.R- if( nc != nrow(a$qr) )
./solve.R- stop("only square matrices can be inverted")
./solve.R: b <- diag(1, nc)
./solve.R- }
./solve.R: return(qr.coef(a, b))
./solve.R-}
./solve.R-
./solve.R-solve.default <-
./solve.R: function(a, b, tol = ifelse(LINPACK, 1e-7, .Machine$double.eps),
./solve.R: LINPACK = FALSE, ...)
./solve.R-{
./solve.R- if(is.complex(a) || (!missing(b) && is.complex(b))) {
./solve.R- a <- as.matrix(a)
./solve.R- if(missing(b)) {
./solve.R: b <- diag(1+0i, nrow(a))
./solve.R- colnames(b) <- rownames(a)
./solve.R- } else if(!is.complex(b)) b[] <- as.complex(b)
./solve.R- if(!is.complex(a)) a[] <- as.complex(a)
./solve.R- return (if (is.matrix(b)) {
./solve.R- rownames(b) <- colnames(a)
./solve.R: .Call("La_zgesv", a, b, PACKAGE = "base")
./solve.R- } else
./solve.R: drop(.Call("La_zgesv", a, as.matrix(b), PACKAGE = "base")))
./solve.R- }
./solve.R- if(is.qr(a)) {
./solve.R- warning("solve.default called with a \"qr\" object: use 'qr.solve'")
./solve.R: return(solve.qr(a, b, tol))
./solve.R- }
./solve.R-
./solve.R- if(!LINPACK) {
./solve.R- a <- as.matrix(a)
./solve.R- if(missing(b)) {
./solve.R: b <- diag(1.0, nrow(a))
./solve.R- colnames(b) <- rownames(a)
./solve.R- } else storage.mode(b) <- "double"
./solve.R- storage.mode(a) <- "double"
./solve.R- return (if (is.matrix(b)) {
./solve.R- rownames(b) <- colnames(a)
./solve.R: .Call("La_dgesv", a, b, tol, PACKAGE = "base")
./solve.R- } else
./solve.R: drop(.Call("La_dgesv", a, as.matrix(b), tol, PACKAGE = "base")))
./solve.R- }
./solve.R: a <- qr(a, tol = tol)
./solve.R- nc <- ncol(a$qr)
./solve.R- if( a$rank != nc )
./solve.R- stop("singular matrix 'a' in 'solve'")
./solve.R- if( missing(b) ) {
./solve.R- if( nc != nrow(a$qr) )
./solve.R- stop("only square matrices can be inverted")
./solve.R- ## preserve dimnames
./solve.R: b <- diag(1, nc)
./solve.R- colnames(b) <- rownames(a$qr)
./solve.R- }
./solve.R: qr.coef(a, b)
./solve.R-}
./solve.R-
./solve.R:solve <- function(a, b, ...) UseMethod("solve")
./solve.R-
./solve.R:qr.solve <- function(a, b, tol = 1e-7)
./solve.R-{
./solve.R- if( !is.qr(a) )
./solve.R: a <- qr(a, tol = tol)
./solve.R- nc <- ncol(a$qr)
./solve.R- if( a$rank != nc )
./solve.R- stop("singular matrix 'a' in solve")
./solve.R- if( missing(b) ) {
./solve.R- if( nc != nrow(a$qr) )
./solve.R- stop("only square matrices can be inverted")
./solve.R: b <- diag(1, nc)
./solve.R- }
./solve.R: return(qr.coef(a, b))
./solve.R-}
./solve.R-
--
./sort.R:sort <- function(x, partial = NULL, na.last = NA, decreasing = FALSE,
./sort.R: method = c("shell", "quick"), index.return = FALSE)
./sort.R-{
./sort.R- if(isfact <- is.factor(x)) {
./sort.R- if(index.return) stop("'index.return' only for non-factors")
--
./sort.R- stop("'index.return' only for 'na.last = NA'")
./sort.R- if(!is.null(partial)) {
./sort.R- if(index.return || decreasing || isfact || !missing(method))
./sort.R- stop("unsupported options for partial sorting")
./sort.R- if(!all(is.finite(partial))) stop("non-finite 'partial'")
./sort.R: y <- .Internal(psort(x, partial))
./sort.R- }
./sort.R- else {
./sort.R- nms <- names(x)
./sort.R- method <- if(is.numeric(x)) match.arg(method) else "shell"
./sort.R: switch(method,
./sort.R- "quick" = {
./sort.R- if(!is.null(nms)) {
./sort.R- if(decreasing) x <- -x
./sort.R: y <- .Internal(qsort(x, TRUE))
./sort.R- if(decreasing) y$x <- -y$x
./sort.R- names(y$x) <- nms[y$ix]
./sort.R- if (!index.return) y <- y$x
./sort.R- } else {
./sort.R- if(decreasing) x <- -x
./sort.R: y <- .Internal(qsort(x, index.return))
./sort.R- if(decreasing)
./sort.R- if(index.return) y$x <- -y$x else y <- -y
./sort.R- }
./sort.R: },
./sort.R- "shell" = {
./sort.R- if(index.return || !is.null(nms)) {
./sort.R: o <- sort.list(x, decreasing = decreasing)
./sort.R: y <- if (index.return) list(x = x[o], ix = o) else x[o]
./sort.R- ## names(y) <- nms[o] # pointless!
./sort.R- }
./sort.R- else
./sort.R: y <- .Internal(sort(x, decreasing))
./sort.R- })
./sort.R- }
./sort.R- if(!is.na(na.last) && has.na)
./sort.R: y <- if(!na.last) c(nas, y) else c(y, nas)
./sort.R- if(isfact)
./sort.R: y <- (if (isord) ordered else factor)(y, levels=seq(len=nlev),
./sort.R- labels=lev)
./sort.R- y
./sort.R-}
./sort.R-
./sort.R:order <- function(..., na.last = TRUE, decreasing = FALSE)
./sort.R-{
./sort.R- if(!is.na(na.last))
./sort.R: .Internal(order(na.last, decreasing, ...))
./sort.R- else{ ## remove nas
./sort.R- z <- list(...)
./sort.R: if(any(diff(sapply(z, length)) != 0))
./sort.R- stop("argument lengths differ")
./sort.R: ans <- sapply(z, is.na)
./sort.R: ok <- if(is.matrix(ans)) !apply(ans, 1, any) else !any(ans)
./sort.R- if(all(!ok)) return(integer(0))
./sort.R- z[[1]][!ok] <- NA
./sort.R: ans <- do.call("order", c(z, decreasing=decreasing))
./sort.R- keep <- seq(along=ok)[ok]
./sort.R- ans[ans %in% keep]
./sort.R- }
./sort.R-}
./sort.R-
./sort.R:sort.list <- function(x, partial = NULL, na.last = TRUE, decreasing = FALSE,
./sort.R: method = c("shell", "quick", "radix"))
./sort.R-{
./sort.R- method <- match.arg(method)
./sort.R- if(!is.atomic(x))
--
./sort.R- if(!is.null(partial))
./sort.R- .NotYetUsed("partial != NULL")
./sort.R- if(method == "quick") {
./sort.R- if(is.factor(x)) x <- as.integer(x) # sort the internal codes
./sort.R- if(is.numeric(x))
./sort.R: return(sort(x, na.last = na.last, decreasing = decreasing,
./sort.R: method = "quick", index.return = TRUE)$ix)
./sort.R- else stop("method=\"quick\" is only for numeric 'x'")
./sort.R- }
./sort.R- if(method == "radix") {
./sort.R- if(!is.integer(x)) stop("method=\"radix\" is only for integer 'x'")
./sort.R- if(is.na(na.last))
./sort.R: return(.Internal(radixsort(x[!is.na(x)], TRUE, decreasing)))
./sort.R- else
./sort.R: return(.Internal(radixsort(x, na.last, decreasing)))
./sort.R- }
./sort.R- ## method == "shell"
./sort.R: if(is.na(na.last)) .Internal(order(TRUE, decreasing, x[!is.na(x)]))
./sort.R: else .Internal(order(na.last, decreasing, x))
./sort.R-}
--
./source.R-source <-
./source.R:function(file, local = FALSE, echo = verbose, print.eval = echo,
./source.R: verbose = getOption("verbose"),
./source.R: prompt.echo = getOption("prompt"),
./source.R: max.deparse.length = 150, chdir = FALSE,
./source.R- encoding = getOption("encoding"))
./source.R-{
./source.R- eval.with.vis <-
./source.R: function (expr, envir = parent.frame(),
./source.R- enclos = if (is.list(envir) || is.pairlist(envir))
./source.R- parent.frame())
./source.R: .Internal(eval.with.vis(expr, envir, enclos))
./source.R-
./source.R- envir <- if (local) parent.frame() else .GlobalEnv
./source.R- if (!missing(echo)) {
./source.R- if (!is.logical(echo))
./source.R- stop("'echo' must be logical")
./source.R- if (!echo && verbose) {
./source.R: warning("'verbose' is TRUE, 'echo' not; ... coercing 'echo <- TRUE'")
./source.R- echo <- TRUE
./source.R- }
./source.R- }
--
./source.R- cat("'envir' chosen:")
./source.R- print(envir)
./source.R- }
./source.R- if(is.character(file)) {
./source.R- if(capabilities("iconv")) {
./source.R: if(identical(encoding, "unknown")) {
./source.R- enc <- utils::localeToCharset()
./source.R- encoding <- enc[length(enc)]
./source.R- } else enc <- encoding
./source.R- if(length(enc) > 1) {
./source.R- encoding <- NA
./source.R- owarn <- options("warn"); options(warn = 2)
./source.R- for(e in enc) {
./source.R- if(is.na(e)) next;
./source.R: zz <- file(file, encoding = e)
./source.R: res <- try(readLines(zz), silent = TRUE)
./source.R- close(zz)
./source.R: if(!inherits(res, "try-error")) { encoding <- e; break }
./source.R- }
./source.R- options(owarn)
./source.R- }
./source.R- if(is.na(encoding))
./source.R- stop("unable to find a plausible encoding")
./source.R: if(verbose) cat("encoding =", dQuote(encoding), "chosen\n")
./source.R- }
./source.R- if(file == "") file <- stdin()
./source.R- else {
./source.R: file <- file(file, "r", encoding = encoding)
./source.R- on.exit(close(file))
./source.R- }
./source.R- }
./source.R: Ne <- length(exprs <- .Internal(parse(file, n = -1, NULL, "?")))
./source.R- if (verbose)
./source.R: cat("--> parsed", Ne, "expressions; now eval(.)ing them:\n")
./source.R- if (Ne == 0)
./source.R- return(invisible())
./source.R- if (chdir && is.character(file) && (path <- dirname(file)) != ".") {
--
./source.R- setwd(path)
./source.R- }
./source.R-
./source.R- if (echo) {
./source.R- ## Reg.exps for string delimiter/ NO-string-del /
./source.R: ## odd-number-of-str.del needed, when truncating below
./source.R- sd <- "\""
./source.R- nos <- "[^\"]*"
./source.R: oddsd <- paste("^", nos, sd, "(", nos, sd, nos, sd, ")*",
./source.R: nos, "$", sep = "")
./source.R- }
./source.R- for (i in 1:Ne) {
./source.R- if (verbose)
./source.R: cat("\n>>>> eval(expression_nr.", i, ")\n\t =================\n")
./source.R- ei <- exprs[i]
./source.R- if (echo) {
./source.R- # drop "expression("
./source.R: dep <- substr(paste(deparse(ei, control = c("showAttributes","useSource")),
./source.R: collapse = "\n"), 12, 1e+06)
./source.R- # -1: drop ")"
./source.R- ## We really do want chars here as \n\t may be embedded.
./source.R: nd <- nchar(dep, "chars") - 1
./source.R- do.trunc <- nd > max.deparse.length
./source.R: dep <- substr(dep, 1, if (do.trunc) max.deparse.length else nd)
./source.R: cat("\n", prompt.echo, dep, if (do.trunc)
./source.R: paste(if (length(grep(sd, dep)) && length(grep(oddsd, dep)))
./source.R- " ...\" ..."
./source.R: else " ....", "[TRUNCATED] "), "\n", sep = "")
./source.R- }
./source.R: yy <- eval.with.vis(ei, envir)
./source.R- i.symbol <- mode(ei[[1]]) == "name"
./source.R- if (!i.symbol) {
./source.R- ## ei[[1]] : the function "<-" or other
--
./source.R- cat("curr.fun:")
./source.R- str(curr.fun)
./source.R- }
./source.R- }
./source.R- if (verbose >= 2) {
./source.R: cat(".... mode(ei[[1]])=", mode(ei[[1]]), "; paste(curr.fun)=")
./source.R- str(paste(curr.fun))
./source.R- }
./source.R- if (print.eval && yy$visible)
./source.R- print(yy$value)
./source.R- if (verbose)
./source.R: cat(" .. after ", sQuote(deparse(ei,
./source.R: control = c("showAttributes","useSource"))), "\n", sep = "")
./source.R- }
./source.R- invisible(yy)
./source.R-}
./source.R-
./source.R-sys.source <-
./source.R:function(file, envir = NULL, chdir = FALSE,
./source.R- keep.source = getOption("keep.source.pkgs"))
./source.R-{
./source.R- if(!(is.character(file) && file.exists(file)))
./source.R: stop(gettextf("'%s' is not an existing file", file))
./source.R: oop <- options(keep.source = as.logical(keep.source),
./source.R- topLevelEnvironment = as.environment(envir))
./source.R- on.exit(options(oop))
./source.R: exprs <- parse(n = -1, file = file)
./source.R- if (length(exprs) == 0)
./source.R- return(invisible())
./source.R- if (chdir && (path <- dirname(file)) != ".") {
./source.R- owd <- getwd()
./source.R: on.exit(setwd(owd), add = TRUE)
./source.R- setwd(path)
./source.R- }
./source.R: for (i in exprs) eval(i, envir)
./source.R- invisible()
./source.R-}
--
./split.R:split <- function(x, f) UseMethod("split")
./split.R-
./split.R:split.default <- function(x, f)
./split.R-{
./split.R- if (is.list(f)) f <- interaction(f)
./split.R- f <- factor(f) # drop extraneous levels
./split.R: if (is.null(attr(x, "class")))
./split.R: return(.Internal(split(x, f)))
./split.R- ## else
./split.R- lf <- levels(f)
./split.R: y <- vector("list", length(lf))
./split.R- names(y) <- lf
./split.R- for(k in lf) y[[k]] <- x[f %in% k]
./split.R- y
./split.R-}
./split.R-
./split.R:split.data.frame <- function(x, f)
./split.R: lapply(split(seq(length=nrow(x)), f), function(ind) x[ind, , drop = FALSE ])
./split.R-
./split.R:"split<-" <- function(x, f, value) UseMethod("split<-")
./split.R-
./split.R:#"split<-.default" <- function(x, f, value)
./split.R-#{
./split.R:# x[unlist(plit(seq(along=x), f))] <- unlist(value)
./split.R-# x
./split.R-#}
./split.R-
./split.R:"split<-.default" <- function(x, f, value)
./split.R-{
./split.R: ix <- split(seq(along = x), f)
./split.R- n <- length(value)
./split.R- j <- 0
./split.R- for (i in ix) {
--
./split.R- x
./split.R-}
./split.R-
./split.R-
./split.R-
./split.R:#"split<-.data.frame" <- function(x, f, value)
./split.R-#{
./split.R:# x[unlist(split(seq(length=nrow(x)), f)),] <- do.call("rbind", value)
./split.R-# x
./split.R-#}
./split.R-
./split.R:"split<-.data.frame" <- function(x, f, value)
./split.R-{
./split.R: ix <- split(seq(along = x), f)
./split.R- n <- length(value)
./split.R- j <- 0
./split.R- for (i in ix) {
./split.R- j <- j %% n + 1
./split.R: x[i,] <- value[[j]]
./split.R- }
./split.R- x
./split.R-}
./split.R-
./split.R:unsplit <- function(value, f)
./split.R-{
./split.R- len <- length(if (is.list(f)) f[[1]] else f)
./split.R: x <- vector(mode = typeof(value[[1]]), length = len)
./split.R: split(x, f) <- value
./split.R- x
./split.R-}
--
./stop.R:stop <- function(..., call. = TRUE, domain = NULL)
./stop.R-{
./stop.R- args <- list(...)
./stop.R: if (length(args) == 1 && inherits(args[[1]], "condition")) {
./stop.R- cond <- args[[1]]
./stop.R- message <- conditionMessage(cond)
./stop.R- call = conditionCall(cond)
./stop.R: .Internal(.signalCondition(cond, message, call))
./stop.R: .Internal(.dfltStop(message, call))
./stop.R- }
./stop.R- else {
./stop.R- if (length(args) > 0) {
./stop.R: args <- lapply(list(...), as.character)
./stop.R: ## don't simplify this, as call sequence matters.
./stop.R- if(is.null(domain) || !is.na(domain))
./stop.R: args <- .Internal(gettext(domain, unlist(args)))
./stop.R: message <- paste(args, collapse = "")
./stop.R- }
./stop.R- else message <- ""
./stop.R: .Internal(stop(as.logical(call.), message))
./stop.R- }
./stop.R-}
./stop.R-
--
./stop.R- if(n == 0)
./stop.R- return(invisible())
./stop.R- mc <- match.call()
./stop.R- for(i in 1:n)
./stop.R- if(!(is.logical(r <- eval(ll[[i]])) && all(r)))
./stop.R: stop(paste(deparse(mc[[i+1]]), "is not TRUE"), call. = FALSE)
./stop.R-}
./stop.R-
./stop.R:warning <- function(..., call. = TRUE, immediate. = FALSE, domain = NULL)
./stop.R-{
./stop.R- args <- list(...)
./stop.R: if (length(args) == 1 && inherits(args[[1]], "condition")) {
./stop.R- cond <- args[[1]]
./stop.R- message <- conditionMessage(cond)
./stop.R- call = conditionCall(cond)
./stop.R- withRestarts({
./stop.R: .Internal(.signalCondition(cond, message, call))
./stop.R: .Internal(.dfltStop(message, call))
./stop.R: }, muffleWarning = function() NULL) #**** allow simpler form??
./stop.R- invisible(message)
./stop.R- }
./stop.R- else {
./stop.R- if (length(args) > 0) {
./stop.R: args <- lapply(list(...), as.character)
./stop.R: ## don't simplify this, as call sequence matters.
./stop.R- if(is.null(domain) || !is.na(domain))
./stop.R: args <- .Internal(gettext(domain, unlist(args)))
./stop.R: message <- paste(args, collapse = "")
./stop.R- } else message <- ""
./stop.R: .Internal(warning(as.logical(call.), as.logical(immediate.), message))
./stop.R- }
./stop.R-}
./stop.R-
./stop.R:gettext <- function(..., domain = NULL) {
./stop.R: args <- lapply(list(...), as.character)
./stop.R: .Internal(gettext(domain, unlist(args)))
./stop.R-}
./stop.R-
./stop.R:bindtextdomain <- function(domain, dirname = NULL)
./stop.R: .Internal(bindtextdomain(domain, dirname))
./stop.R-
./stop.R:ngettext <- function(n, msg1, msg2, domain = NULL)
./stop.R: .Internal(ngettext(n, msg1, msg2, domain))
./stop.R-
./stop.R:gettextf <- function(fmt, ..., domain = NULL)
./stop.R: sprintf(gettext(fmt, domain = domain), ...)
--
./structure.R-"structure" <-
./structure.R: function (.Data, ...)
./structure.R-{
./structure.R: specials <- c(".Dim", ".Dimnames", ".Names", ".Tsp", ".Label")
./structure.R: replace <- c("dim", "dimnames", "names", "tsp", "levels")
./structure.R- attrib <- list(...)
./structure.R- if(length(attrib) > 0) {
./structure.R: m <- match(names(attrib), specials)
./structure.R- ok <- (!is.na(m) & m > 0)
./structure.R- names(attrib)[ok] <- replace[m[ok]]
./structure.R- if(any(names(attrib) == "tsp"))
./structure.R: attrib$class <- unique(c("ts", attrib$class))
./structure.R- if(is.numeric(.Data) && any(names(attrib) == "levels"))
./structure.R: .Data <- factor(.Data,levels=seq(along=attrib$levels))
./structure.R: attributes(.Data) <- c(attributes(.Data), attrib)
./structure.R- }
./structure.R- return(.Data)
./structure.R-}
--
./strwrap.R:strtrim <- function(x, width) .Internal(strtrim(x, width))
./strwrap.R-
./strwrap.R-strwrap <-
./strwrap.R:function(x, width = 0.9 * getOption("width"), indent = 0, exdent = 0,
./strwrap.R: prefix = "", simplify = TRUE) {
./strwrap.R-
./strwrap.R- ## Useful variables.
./strwrap.R: indentString <- paste(rep.int(" ", indent), collapse = "")
./strwrap.R: exdentString <- paste(rep.int(" ", exdent), collapse = "")
./strwrap.R- y <- list() # return value
./strwrap.R: z <- lapply(strsplit(x, "\n[ \t\n]*\n"), strsplit, "[ \t\n]")
./strwrap.R- ## Now z[[i]][[j]] is a character vector of all "words" in
./strwrap.R- ## paragraph j of x[i].
./strwrap.R-
./strwrap.R- for(i in seq(along = z)) {
./strwrap.R- yi <- character(0)
./strwrap.R- for(j in seq(along = z[[i]])) {
./strwrap.R- ## Format paragraph j in x[i].
./strwrap.R- words <- z[[i]][[j]]
./strwrap.R: nc <- nchar(words, type="w")
./strwrap.R-
./strwrap.R- ## Remove extra white space unless after a period which
./strwrap.R- ## hopefully ends a sentence.
./strwrap.R- if(any(nc == 0)) {
./strwrap.R- zLenInd <- which(nc == 0)
./strwrap.R- zLenInd <- zLenInd[!(zLenInd %in%
./strwrap.R: (grep("\\.$", words) + 1))]
./strwrap.R- if(length(zLenInd) > 0) {
./strwrap.R- words <- words[-zLenInd]
./strwrap.R- nc <- nc[-zLenInd]
./strwrap.R- }
./strwrap.R- }
./strwrap.R-
./strwrap.R- if(length(words) == 0) {
./strwrap.R: yi <- c(yi, "", prefix)
./strwrap.R- next
./strwrap.R- }
./strwrap.R-
--
./strwrap.R- lowerBlockIndex <- 1
./strwrap.R- upperBlockIndex <- integer(0)
./strwrap.R- lens <- cumsum(nc + 1)
./strwrap.R-
./strwrap.R- first <- TRUE
./strwrap.R: maxLength <- width - nchar(prefix, type="w") - indent
./strwrap.R-
./strwrap.R- ## Recursively build a sequence of lower and upper indices
./strwrap.R- ## such that the words in line k are the ones in the k-th
./strwrap.R- ## index block.
./strwrap.R- while(length(lens) > 0) {
./strwrap.R: k <- max(sum(lens < maxLength), 1)
./strwrap.R- if(first) {
./strwrap.R- first <- FALSE
./strwrap.R- maxLength <- maxLength + indent - exdent
./strwrap.R- }
./strwrap.R- currentIndex <- currentIndex + k
./strwrap.R- if(nc[currentIndex] == 0)
./strwrap.R- ## Are we sitting on a space?
./strwrap.R: upperBlockIndex <- c(upperBlockIndex,
./strwrap.R- currentIndex - 1)
./strwrap.R- else
./strwrap.R: upperBlockIndex <- c(upperBlockIndex,
./strwrap.R- currentIndex)
./strwrap.R- if(length(lens) > k) {
./strwrap.R- ## Are we looking at a space?
./strwrap.R- if(nc[currentIndex + 1] == 0) {
./strwrap.R- currentIndex <- currentIndex + 1
./strwrap.R- k <- k + 1
./strwrap.R- }
./strwrap.R: lowerBlockIndex <- c(lowerBlockIndex,
./strwrap.R- currentIndex + 1)
./strwrap.R- }
./strwrap.R- if(length(lens) > k)
--
./strwrap.R- else
./strwrap.R- lens <- NULL
./strwrap.R- }
./strwrap.R-
./strwrap.R- nBlocks <- length(upperBlockIndex)
./strwrap.R: s <- paste(prefix,
./strwrap.R: c(indentString, rep.int(exdentString, nBlocks - 1)),
./strwrap.R- sep = "")
./strwrap.R- for(k in (1 : nBlocks))
./strwrap.R: s[k] <- paste(s[k], paste(words[lowerBlockIndex[k] :
./strwrap.R: upperBlockIndex[k]],
./strwrap.R: collapse = " "),
./strwrap.R- sep = "")
./strwrap.R: yi <- c(yi, s, prefix)
./strwrap.R- }
./strwrap.R: y <- c(y, list(yi[-length(yi)]))
./strwrap.R- }
./strwrap.R-
./strwrap.R- if(simplify) y <- unlist(y)
./strwrap.R- y
./strwrap.R-}
./strwrap.R-
./strwrap.R-formatDL <-
./strwrap.R:function(x, y, style = c("table", "list"),
./strwrap.R: width = 0.9 * getOption("width"), indent = NULL)
./strwrap.R-{
./strwrap.R- if(is.list(x)) {
./strwrap.R: if((length(x) == 2) && (diff(sapply(x, length)) == 0)) {
./strwrap.R- y <- x[[2]]; x <- x[[1]]
./strwrap.R- }
./strwrap.R- else
./strwrap.R- stop("incorrect value for 'x'")
./strwrap.R- }
./strwrap.R- else if(is.matrix(x)) {
./strwrap.R- if(NCOL(x) == 2) {
./strwrap.R: y <- x[, 2]; x <- x[, 1]
./strwrap.R- }
./strwrap.R- else
./strwrap.R- stop("incorrect value for 'x'")
--
./strwrap.R- y <- as.character(y)
./strwrap.R-
./strwrap.R- style <- match.arg(style)
./strwrap.R-
./strwrap.R- if(is.null(indent))
./strwrap.R: indent <- switch(style, table = width / 3, list = width / 9)
./strwrap.R- if(indent > 0.5 * width)
./strwrap.R- stop("incorrect values of 'indent' and 'width'")
./strwrap.R-
./strwrap.R: indentString <- paste(rep.int(" ", indent), collapse = "")
./strwrap.R-
./strwrap.R- if(style == "table") {
./strwrap.R: i <- (nchar(x, type="w") > indent - 3)
./strwrap.R- if(any(i))
./strwrap.R: x[i] <- paste(x[i], "\n", indentString, sep = "")
./strwrap.R- i <- !i
./strwrap.R- if(any(i))
./strwrap.R: x[i] <- formatC(x[i], width = indent, flag = "-")
./strwrap.R: y <- lapply(strwrap(y, width = width - indent,
./strwrap.R: simplify = FALSE),
./strwrap.R: paste,
./strwrap.R: collapse = paste("\n", indentString, sep = ""))
./strwrap.R: r <- paste(x, unlist(y), sep = "")
./strwrap.R- }
./strwrap.R- else if(style == "list") {
./strwrap.R: y <- strwrap(paste(x, ": ", y, sep = ""), exdent = indent,
./strwrap.R: width = width, simplify = FALSE)
./strwrap.R: r <- unlist(lapply(y, paste, collapse = "\n"))
./strwrap.R- }
./strwrap.R- r
./strwrap.R-}
--
./summaries.R:sum <- function(..., na.rm = FALSE)
./summaries.R: .Internal(sum(..., na.rm = na.rm))
./summaries.R-
./summaries.R:min <- function(..., na.rm = FALSE)
./summaries.R: .Internal(min(..., na.rm = na.rm))
./summaries.R-
./summaries.R:max <- function(..., na.rm = FALSE)
./summaries.R: .Internal(max(..., na.rm = na.rm))
./summaries.R-
./summaries.R:prod <- function(..., na.rm = FALSE)
./summaries.R: .Internal(prod(..., na.rm = na.rm))
./summaries.R-
./summaries.R:all <- function(..., na.rm = FALSE)
./summaries.R: .Internal(all(..., na.rm = na.rm))
./summaries.R-
./summaries.R:any <- function(..., na.rm = FALSE)
./summaries.R: .Internal(any(..., na.rm = na.rm))
--
./summary.R:summary <- function (object, ...) UseMethod("summary")
./summary.R-
./summary.R-summary.default <-
./summary.R: function(object, ..., digits = max(3, getOption("digits") - 3))
./summary.R-{
./summary.R- if(is.factor(object))
./summary.R: return(summary.factor(object, ...))
./summary.R- else if(is.matrix(object))
./summary.R: return(summary.matrix(object, digits = digits, ...))
./summary.R-
./summary.R- value <- if(is.logical(object))# scalar or array!
./summary.R: c(Mode = "logical",
./summary.R: {tb <- table(object, exclude=NULL)# incl. NA s
./summary.R- if(!is.null(n <- dimnames(tb)[[1]]) && any(iN <- is.na(n)))
./summary.R- dimnames(tb)[[1]][iN] <- "NA's"
./summary.R- tb
./summary.R- })
./summary.R- else if(is.numeric(object)) {
./summary.R- nas <- is.na(object)
./summary.R- object <- object[!nas]
./summary.R- qq <- stats::quantile(object)
./summary.R: qq <- signif(c(qq[1:3], mean(object), qq[4:5]), digits)
./summary.R: names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")
./summary.R- if(any(nas))
./summary.R: c(qq, "NA's" = sum(nas))
./summary.R- else qq
./summary.R- } else if(is.recursive(object) && !is.language(object) &&
./summary.R- (n <- length(object))) {
./summary.R: sumry <- array("", c(n, 3), list(names(object),
./summary.R: c("Length", "Class", "Mode")))
./summary.R- ll <- numeric(n)
./summary.R- for(i in 1:n) {
./summary.R- ii <- object[[i]]
./summary.R- ll[i] <- length(ii)
./summary.R- cls <- oldClass(ii)
./summary.R: sumry[i, 2] <- if(length(cls)>0) cls[1] else "-none-"
./summary.R: sumry[i, 3] <- mode(ii)
./summary.R- }
./summary.R: sumry[, 1] <- format(as.integer(ll))
./summary.R- sumry
./summary.R- }
./summary.R: else c(Length= length(object), Class= class(object), Mode= mode(object))
./summary.R- class(value) <- "table"
./summary.R- value
./summary.R-}
./summary.R-
./summary.R:summary.factor <- function(object, maxsum = 100, ...)
./summary.R-{
./summary.R- nas <- is.na(object)
./summary.R- ll <- levels(object)
--
./summary.R- tbl <- table(object)
./summary.R- tt <- c(tbl) # names dropped ...
./summary.R- names(tt) <- dimnames(tbl)[[1]]
./summary.R- if(length(ll) > maxsum) {
./summary.R- drop <- maxsum:length(ll)
./summary.R: o <- sort.list(tt, decreasing = TRUE)
./summary.R: tt <- c(tt[o[ - drop]], "(Other)" = sum(tt[o[drop]]))
./summary.R- }
./summary.R: if(any(nas)) c(tt, "NA's" = sum(nas)) else tt
./summary.R-}
./summary.R-
./summary.R:summary.matrix <- function(object, ...)
./summary.R: summary.data.frame(data.frame(object), ...)
./summary.R-
./summary.R:## use encodeString here, and its justify options
./summary.R-summary.data.frame <-
./summary.R: function(object, maxsum = 7, digits = max(3, getOption("digits") - 3), ...)
./summary.R-{
./summary.R- # compute results to full precision.
./summary.R: z <- lapply(as.list(object), summary, maxsum = maxsum, digits = 12, ...)
./summary.R- nv <- length(object)
./summary.R- nm <- names(object)
./summary.R- lw <- numeric(nv)
./summary.R: nr <- max(unlist(lapply(z, NROW)))
./summary.R- for(i in 1:nv) {
./summary.R- sms <- z[[i]]
./summary.R- if(is.matrix(sms)) {
./summary.R: ## need to produce a single column, so collapse matrix
./summary.R- ## across rows
./summary.R: cn <- paste(nm[i], gsub("^ +", "", colnames(sms)), sep=".")
./summary.R- tmp <- format(sms)
./summary.R- if(nrow(sms) < nr)
./summary.R: tmp <- rbind(tmp, matrix("", nr - nrow(sms), ncol(sms)))
./summary.R: sms <- apply(tmp, 1, function(x) paste(x, collapse=" "))
./summary.R- ## produce a suitable colname: undoing padding
./summary.R: wid <- sapply(tmp[1,], nchar, type="w")
./summary.R: blanks <- paste(character(max(wid)), collapse = " ")
./summary.R: pad0 <- floor((wid-nchar(cn, type="w"))/2);
./summary.R: pad1 <- wid - nchar(cn, type="w") - pad0
./summary.R: cn <- paste(substring(blanks, 1, pad0), cn,
./summary.R: substring(blanks, 1, pad1), sep = "")
./summary.R: nm[i] <- paste(cn, collapse=" ")
./summary.R- z[[i]] <- sms
./summary.R- } else {
./summary.R- lbs <- format(names(sms))
./summary.R: sms <- paste(lbs, ":", format(sms, digits = digits), " ",
./summary.R- sep = "")
./summary.R: lw[i] <- nchar(lbs[1], type="w")
./summary.R- length(sms) <- nr
./summary.R- z[[i]] <- sms
./summary.R- }
./summary.R- }
./summary.R: z <- unlist(z, use.names=TRUE)
./summary.R: dim(z) <- c(nr, nv)
./summary.R: blanks <- paste(character(max(lw) + 2), collapse = " ")
./summary.R: pad <- floor(lw-nchar(nm, type="w")/2)
./summary.R: nm <- paste(substring(blanks, 1, pad), nm, sep = "")
./summary.R: dimnames(z) <- list(rep.int("", nr), nm)
./summary.R: attr(z, "class") <- c("table") #, "matrix")
./summary.R- z
./summary.R-}
--
./svd.R:svd <- function(x, nu = min(n,p), nv = min(n,p), LINPACK = FALSE)
./svd.R-{
./svd.R- x <- as.matrix(x)
./svd.R- if (any(!is.finite(x))) stop("infinite or missing values in 'x'")
./svd.R- dx <- dim(x)
./svd.R- n <- dx[1]
./svd.R- p <- dx[2]
./svd.R- if(!n || !p) stop("0 extent dimensions")
./svd.R- if (is.complex(x)) {
./svd.R: res <- La.svd(x, nu, nv)
./svd.R: return(list(d = res$d, u = if(nu) res$u, v = if(nv) Conj(t(res$vt))))
./svd.R- }
./svd.R- if (!LINPACK) {
./svd.R: res <- La.svd(x, nu, nv)
./svd.R: return(list(d = res$d, u = if(nu) res$u, v = if(nv) t(res$vt)))
./svd.R- }
./svd.R- if(!is.numeric(x))
./svd.R- stop("argument to 'svd' must be numeric")
--
./svd.R- job <- 0
./svd.R- u <- double(0)
./svd.R- }
./svd.R- else if(nu == n) {
./svd.R- job <- 10
./svd.R: u <- matrix(0, n, n)
./svd.R- }
./svd.R- else if(nu == p) {
./svd.R- job <- 20
./svd.R: u <- matrix(0, n, p)
./svd.R- }
./svd.R- else
./svd.R: stop("'nu' must be 0, nrow(x) or ncol(x)")
./svd.R-
./svd.R- job <- job +
./svd.R- if(nv == 0) 0 else if(nv == p || nv == n) 1 else
./svd.R- stop("'nv' must be 0 or ncol(x)")
./svd.R-
./svd.R: v <- if(job == 0) double(0) else matrix(0, p, p)
./svd.R-
./svd.R: mn <- min(n,p)
./svd.R: mm <- min(n+1,p)
./svd.R: z <- .Fortran("dsvdc",
./svd.R: as.double(x),
./svd.R: n,
./svd.R: n,
./svd.R: p,
./svd.R: d=double(mm),
./svd.R: double(p),
./svd.R: u=u,
./svd.R: n,
./svd.R: v=v,
./svd.R: p,
./svd.R: double(n),
./svd.R: as.integer(job),
./svd.R: info=integer(1),
./svd.R: DUP=FALSE, PACKAGE="base")[c("d","u","v","info")]
./svd.R- if(z$info)
./svd.R: stop(gettextf("error %d in 'dsvdc'", z$info), domain = NA)
./svd.R- z$d <- z$d[1:mn]
./svd.R: if(nv && nv < p) z$v <- z$v[, 1:nv, drop = FALSE]
./svd.R: z[c("d", if(nu) "u", if(nv) "v")]
./svd.R-}
--
./sweep.R:sweep <- function(x, MARGIN, STATS, FUN = "-", ...)
./sweep.R-{
./sweep.R- FUN <- match.fun(FUN)
./sweep.R- dims <- dim(x)
./sweep.R: perm <- c(MARGIN, (1:length(dims))[ - MARGIN])
./sweep.R: FUN(x, aperm(array(STATS, dims[perm]), order(perm)), ...)
./sweep.R-}
--
./switch.R:switch <- function(EXPR,...)
./switch.R: .Internal(switch(EXPR,...))
--
./sys.R-
./sys.R-sys.parents <- function()
./sys.R- .Internal(sys.parents())
./sys.R-
./sys.R-sys.status <- function()
./sys.R: list(sys.calls=sys.calls(), sys.parents=sys.parents(),
./sys.R- sys.frames=sys.frames())
./sys.R-
./sys.R-sys.on.exit <- function()
--
./table.R:table <- function (..., exclude = c(NA, NaN),
./table.R: dnn = list.names(...), deparse.level = 1)
./table.R-{
./table.R- list.names <- function(...) {
./table.R- l <- as.list(substitute(list(...)))[-1]
./table.R- nm <- names(l)
./table.R- fixup <- if (is.null(nm)) seq(along = l) else nm == ""
./table.R: dep <- sapply(l[fixup], function(x)
./table.R: switch (deparse.level + 1,
./table.R: "", ## 0
./table.R: if (is.symbol(x)) as.character(x) else "", ## 1
./table.R- deparse(x)[1]) ## 2
./table.R- )
./table.R- if (is.null(nm))
--
./table.R- args <- args[[1]]
./table.R- if (length(dnn) != length(args))
./table.R- dnn <- if (!is.null(argn <- names(args)))
./table.R- argn
./table.R- else
./table.R: paste(dnn[1], 1:length(args), sep = '.')
./table.R- }
./table.R- bin <- 0
./table.R- lens <- NULL
--
./table.R- stop("all arguments must have the same length")
./table.R- cat <-
./table.R- if (is.factor(a)) {
./table.R- if (!missing(exclude)) {
./table.R- ll <- levels(a)
./table.R: factor(a, levels = ll[!(ll %in% exclude)],
./table.R- exclude = if(is.null(exclude)) NULL else NA)
./table.R- } else a
./table.R: } else factor(a, exclude = exclude)
./table.R-
./table.R- nl <- length(ll <- levels(cat))
./table.R: dims <- c(dims, nl)
./table.R: dn <- c(dn, list(ll))
./table.R- ## requiring all(unique(as.integer(cat)) == 1:nlevels(cat)) :
./table.R- bin <- bin + pd * (as.integer(cat) - 1)
./table.R- pd <- pd * nl
./table.R- }
./table.R- names(dn) <- dnn
./table.R- bin <- bin[!is.na(bin)]
./table.R: if (length(bin)) bin <- bin + 1 # otherwise, that makes bin NA
./table.R: y <- array(tabulate(bin, pd), dims, dimnames = dn)
./table.R- class(y) <- "table"
./table.R- y
./table.R-}
./table.R-
./table.R-## From 1999-12-19 till 2003-03-27:
./table.R-## print.table <-
./table.R:## function(x, digits = getOption("digits"), quote = FALSE, na.print = "", ...)
./table.R-## {
./table.R:## print.default(unclass(x), digits = digits, quote = quote,
./table.R:## na.print = na.print, ...)
./table.R-## ## this does *not* return x !
./table.R-## }
./table.R-
./table.R-## Better (NA in dimnames *should* be printed):
./table.R-print.table <-
./table.R:function (x, digits = getOption("digits"), quote = FALSE, na.print = "",
./table.R: zero.print = "0",
./table.R: justify = "none", ...)
./table.R-{
./table.R: xx <- format(unclass(x), digits = digits, justify = justify)
./table.R- ## na.print handled here
./table.R- if(any(ina <- is.na(x)))
./table.R- xx[ina] <- na.print
./table.R- if(is.integer(x) && zero.print != "0" && any(i0 <- !ina & x == 0))
./table.R- ## MM thinks this should be an option for many more print methods...
./table.R: xx[i0] <- sub("0", zero.print, xx[i0])
./table.R: ## Numbers get right-justified by format(), irrespective of 'justify'.
./table.R- ## We need to keep column headers aligned.
./table.R- if (is.numeric(x) || is.complex(x))
./table.R: print(xx, quote = quote, right = TRUE, ...)
./table.R- else
./table.R: print(xx, quote = quote, ...)
./table.R- invisible(x)
./table.R-}
./table.R-
./table.R:summary.table <- function(object, ...)
./table.R-{
./table.R: if(!inherits(object, "table"))
./table.R- stop("'object' must inherit from class \"table\"")
./table.R- n.cases <- sum(object)
./table.R- n.vars <- length(dim(object))
./table.R: y <- list(n.vars = n.vars,
./table.R- n.cases = n.cases)
./table.R- if(n.vars > 1) {
./table.R: m <- vector("list", length = n.vars)
./table.R- relFreqs <- object / n.cases
./table.R- for(k in 1:n.vars)
./table.R: m[[k]] <- apply(relFreqs, k, sum)
./table.R: expected <- apply(do.call("expand.grid", m), 1, prod) * n.cases
./table.R- statistic <- sum((c(object) - expected)^2 / expected)
./table.R- parameter <-
./table.R: prod(sapply(m, length)) - 1 - sum(sapply(m, length) - 1)
./table.R: y <- c(y, list(statistic = statistic,
./table.R: parameter = parameter,
./table.R: approx.ok = all(expected >= 5),
./table.R: p.value = pchisq(statistic, parameter, lower.tail=FALSE),
./table.R: call = attr(object, "call")))
./table.R- }
./table.R- class(y) <- "summary.table"
./table.R- y
./table.R-}
./table.R-
./table.R-print.summary.table <-
./table.R:function(x, digits = max(1, getOption("digits") - 3), ...)
./table.R-{
./table.R: if(!inherits(x, "summary.table"))
./table.R- stop("'x' must inherit from class \"summary.table\"")
./table.R- if(!is.null(x$call)) {
./table.R- cat("Call: "); print(x$call)
./table.R- }
./table.R: cat("Number of cases in table:", x$n.cases, "\n")
./table.R: cat("Number of factors:", x$n.vars, "\n")
./table.R- if(x$n.vars > 1) {
./table.R- cat("Test for independence of all factors:\n")
./table.R- ch <- x$statistic
./table.R: cat("\tChisq = ", format(round(ch, max(0, digits - log10(ch)))),
./table.R: ", df = ", x$parameter,
./table.R: ", p-value = ", format.pval(x$p.value, digits, eps = 0),
./table.R: "\n", sep = "")
./table.R- if(!x$approx.ok)
./table.R- cat("\tChi-squared approximation may be incorrect\n")
./table.R- }
./table.R- invisible(x)
./table.R-}
./table.R-
./table.R:as.data.frame.table <- function(x, row.names = NULL, optional = FALSE,
./table.R: responseName = "Freq", ...)
./table.R-{
./table.R- x <- as.table(x)
./table.R: ex <- quote(data.frame(do.call("expand.grid", dimnames(x)),
./table.R: Freq = c(x),
./table.R- row.names = row.names))
./table.R- names(ex)[3] <- responseName
./table.R- eval(ex)
./table.R-}
./table.R-
./table.R:is.table <- function(x) inherits(x, "table")
./table.R:as.table <- function(x, ...) UseMethod("as.table")
./table.R:as.table.default <- function(x, ...)
./table.R-{
./table.R- if(is.table(x))
./table.R- return(x)
--
./table.R- if(any(dim(x) == 0))
./table.R- stop("cannot coerce into a table")
./table.R- ## Try providing dimnames where missing.
./table.R- dnx <- dimnames(x)
./table.R- if(is.null(dnx))
./table.R: dnx <- vector("list", length(dim(x)))
./table.R: for(i in which(sapply(dnx, is.null)))
./table.R- dnx[[i]] <- LETTERS[seq(length = dim(x)[i])]
./table.R- dimnames(x) <- dnx
./table.R: class(x) <- c("table", oldClass(x))
./table.R- return(x)
./table.R- }
./table.R- else
./table.R- stop("cannot coerce into a table")
./table.R-}
./table.R-
./table.R:prop.table <- function(x, margin = NULL)
./table.R-{
./table.R- if(length(margin))
./table.R: sweep(x, margin, margin.table(x, margin), "/")
./table.R- else
./table.R- x / sum(x)
./table.R-}
./table.R-
./table.R:margin.table <- function(x, margin = NULL)
./table.R-{
./table.R- if(!is.array(x)) stop("'x' is not an array")
./table.R- if (length(margin)) {
./table.R: z <- apply(x, margin, sum)
./table.R- dim(z) <- dim(x)[margin]
./table.R- dimnames(z) <- dimnames(x)[margin]
./table.R- }
./table.R- else return(sum(x))
./table.R- class(z) <- oldClass(x) # avoid adding "matrix"
./table.R- z
./table.R-}
./table.R-
./table.R:r2dtable <- function(n, r, c) {
./table.R- if(length(n) == 0 || (n < 0) || is.na(n))
./table.R- stop("invalid argument 'n'")
./table.R- if((length(r) <= 1) || any(r < 0) || any(is.na(r)))
./table.R- stop("invalid argument 'r'")
./table.R- if((length(c) <= 1) || any(c < 0) || any(is.na(c)))
./table.R- stop("invalid argument 'c'")
./table.R- if(sum(r) != sum(c))
./table.R- stop("arguments 'r' and 'c' must have the same sums")
./table.R: .Call("R_r2dtable",
./table.R: as.integer(n),
./table.R: as.integer(r),
./table.R: as.integer(c),
./table.R- PACKAGE = "base")
./table.R-}
--
./tabulate.R:tabulate <- function(bin, nbins = max(1,bin))
./tabulate.R-{
./tabulate.R- if(!is.numeric(bin) && !is.factor(bin))
./tabulate.R- stop("'bin' must be numeric or a factor")
./tabulate.R: .C("R_tabulate",
./tabulate.R: as.integer(bin),
./tabulate.R: as.integer(length(bin)),
./tabulate.R: as.integer(nbins),
./tabulate.R: ans = integer(nbins),
./tabulate.R- PACKAGE="base")$ans
./tabulate.R-}
--
./tapply.R:tapply <- function (X, INDEX, FUN=NULL, ..., simplify=TRUE)
./tapply.R-{
./tapply.R- FUN <- if (!is.null(FUN)) match.fun(FUN)
./tapply.R- if (!is.list(INDEX)) INDEX <- list(INDEX)
./tapply.R- nI <- length(INDEX)
./tapply.R: namelist <- vector("list", nI)
./tapply.R- names(namelist) <- names(INDEX)
./tapply.R- extent <- integer(nI)
./tapply.R- nx <- length(X)
./tapply.R- one <- as.integer(1)
./tapply.R: group <- rep.int(one, nx)#- to contain the splitting vector
./tapply.R- ngroup <- one
./tapply.R- for (i in seq(INDEX)) {
./tapply.R- index <- as.factor(INDEX[[i]])
./tapply.R- if (length(index) != nx)
./tapply.R- stop("arguments must have same length")
./tapply.R: namelist[[i]] <- levels(index)#- all of them, yes !
./tapply.R- extent[i] <- nlevels(index)
./tapply.R- group <- group + ngroup * (as.integer(index) - one)
./tapply.R- ngroup <- ngroup * nlevels(index)
./tapply.R- }
./tapply.R- if (is.null(FUN)) return(group)
./tapply.R: ans <- lapply(split(X, group), FUN, ...)
./tapply.R- index <- as.numeric(names(ans))
./tapply.R: if (simplify && all(unlist(lapply(ans, length)) == 1)) {
./tapply.R: ansmat <- array(dim=extent, dimnames=namelist)
./tapply.R: ans <- unlist(ans, recursive = FALSE)
./tapply.R- }
./tapply.R- else {
./tapply.R: ansmat <- array(vector("list", prod(extent)),
./tapply.R: dim=extent, dimnames=namelist)
./tapply.R- }
./tapply.R- ## old : ansmat[as.numeric(names(ans))] <- ans
./tapply.R- names(ans) <- NULL
--
./taskCallback.R:addTaskCallback <- function(f, data = NULL, name = character(0))
./taskCallback.R-{
./taskCallback.R- if(!is.function(f))
./taskCallback.R- stop("handler must be a function")
./taskCallback.R: val <- .Call("R_addTaskCallback", f, data, !missing(data),
./taskCallback.R: as.character(name), PACKAGE="base")
./taskCallback.R-
./taskCallback.R- val + 1
./taskCallback.R-}
--
./taskCallback.R-removeTaskCallback <- function(id)
./taskCallback.R-{
./taskCallback.R- if(!is.character(id))
./taskCallback.R- id <- as.integer(id)
./taskCallback.R-
./taskCallback.R: .Call("R_removeTaskCallback", id, PACKAGE="base")
./taskCallback.R-}
./taskCallback.R-
./taskCallback.R-getTaskCallbackNames <-
./taskCallback.R-function()
./taskCallback.R-{
./taskCallback.R: .Call("R_getTaskCallbackNames", PACKAGE="base")
./taskCallback.R-}
./taskCallback.R-
./taskCallback.R-
./taskCallback.R-taskCallbackManager <-
./taskCallback.R- #
./taskCallback.R- #
./taskCallback.R- #
./taskCallback.R:function(handlers = list(), registered = FALSE, verbose = FALSE)
./taskCallback.R-{
./taskCallback.R- suspended <- FALSE
./taskCallback.R- .verbose <- verbose
--
./taskCallback.R- # list.
./taskCallback.R- # The result is stored in the `handlers' list using the
./taskCallback.R- # name.
./taskCallback.R- #
./taskCallback.R- # The element in the list contains the function
./taskCallback.R: # in the `f' slot, and optionally a data field
./taskCallback.R- # to store the `data' argument.
./taskCallback.R- #
./taskCallback.R- # This could arrange to register itself using
./taskCallback.R- # addTaskCallback() if the size of the handlers list
./taskCallback.R- # becomes 1.
./taskCallback.R: function(f, data = NULL, name = NULL, register = TRUE)
./taskCallback.R- {
./taskCallback.R-
./taskCallback.R- # generate default name if none supplied
./taskCallback.R- if(is.null(name))
./taskCallback.R- name <- as.character(length(handlers) + 1)
./taskCallback.R-
./taskCallback.R: # Add to handlers, replacing any element with that name
./taskCallback.R- # if needed.
./taskCallback.R- handlers[[name]] <<- list(f = f)
./taskCallback.R-
./taskCallback.R: # If data was specified, add this to the new element
./taskCallback.R- # so that it will be included in the call for this function
./taskCallback.R- if(!missing(data))
./taskCallback.R- handlers[[name]][["data"]] <<- data
./taskCallback.R-
./taskCallback.R- # We could arrange to register the evaluate function
./taskCallback.R: # so that the handlers list would be active. However,
./taskCallback.R- # we would have to unregister it in the remove()
./taskCallback.R- # function when there were no handlers.
./taskCallback.R- if(!registered && register) {
--
./taskCallback.R- }
./taskCallback.R-
./taskCallback.R- remove <- function(which)
./taskCallback.R- {
./taskCallback.R- if(is.character(which)) {
./taskCallback.R: tmp <- (1:length(handlers))[!is.na(match(which, names(handlers)))]
./taskCallback.R- if(length(tmp))
./taskCallback.R: stop(gettextf("no such element '%s'", which), domain = NA)
./taskCallback.R- which <- tmp
./taskCallback.R- } else
./taskCallback.R- which <- as.integer(which)
--
./taskCallback.R- # It then calls each of the functions in the handlers list
./taskCallback.R- # passing these functions the arguments it received and any
./taskCallback.R- # user-level data for those functions registered in the call to
./taskCallback.R- # add() via the `data' argument.
./taskCallback.R- #
./taskCallback.R: # At the end of the evaluation, any function that returned FALSE
./taskCallback.R- # is discarded.
./taskCallback.R: function(expr, value, ok, visible)
./taskCallback.R- {
./taskCallback.R- if(suspended)
./taskCallback.R- return(TRUE)
./taskCallback.R- discard <- character(0)
./taskCallback.R- for(i in names(handlers)) {
./taskCallback.R- h <- handlers[[i]]
./taskCallback.R- if(length(h) > 1) {
./taskCallback.R: val <- h[["f"]](expr, value, ok, visible, i[["data"]])
./taskCallback.R- } else {
./taskCallback.R: val <- h[["f"]](expr, value, ok, visible)
./taskCallback.R- }
./taskCallback.R- if(!val) {
./taskCallback.R: discard <- c(discard, i)
./taskCallback.R- }
./taskCallback.R- }
./taskCallback.R- if(length(discard) > 0) {
./taskCallback.R- if(.verbose)
./taskCallback.R: cat(gettext("Removing"), paste(discard, collapse=", "), "\n")
./taskCallback.R: idx <- is.na(match(names(handlers), discard))
./taskCallback.R- if(length(idx))
./taskCallback.R- handlers <<- handlers[idx]
./taskCallback.R- else
--
./taskCallback.R- function(status = TRUE) {
./taskCallback.R- suspended <<- status
./taskCallback.R- }
./taskCallback.R-
./taskCallback.R- register <-
./taskCallback.R: function(name = "R-taskCallbackManager", verbose = .verbose)
./taskCallback.R- {
./taskCallback.R- if(verbose)
./taskCallback.R- cat(gettext("Registering evaluate as low-level callback\n"))
./taskCallback.R: id <- addTaskCallback(evaluate, name = name)
./taskCallback.R- registered <<- TRUE
./taskCallback.R- id
./taskCallback.R- }
./taskCallback.R-
./taskCallback.R: list(add = add,
./taskCallback.R: evaluate = evaluate,
./taskCallback.R: remove = remove,
./taskCallback.R: register = register,
./taskCallback.R: suspend = suspend,
./taskCallback.R- callbacks = function()
./taskCallback.R- handlers
./taskCallback.R- )
--
./temp.R:tempfile <- function(pattern = "file", tmpdir = tempdir()) .Internal(tempfile(pattern, tmpdir))
./temp.R-
./temp.R-tempdir <- function() .Internal(tempdir())
--
./time.R:system.time <- function(expr, gcFirst = FALSE) {
./time.R: if(!exists("proc.time")) return(rep(as.numeric(NA), 5))
./time.R- loc.frame <- parent.frame()
./time.R- if(gcFirst) gc(FALSE)
./time.R: on.exit(cat("Timing stopped at:", proc.time() - time, "\n"))
./time.R- expr <- substitute(expr)
./time.R- time <- proc.time()
./time.R: eval(expr, envir = loc.frame)
./time.R- new.time <- proc.time()
./time.R- on.exit()
./time.R: if(length(new.time) == 3) new.time <- c(new.time, 0, 0)
./time.R: if(length(time) == 3) time <- c( time, 0, 0)
./time.R- new.time - time
./time.R-}
./time.R-unix.time <- system.time
--
./toString.R-#functions to convert their first argument to strings
./toString.R:toString <- function(x, ...)
./toString.R- UseMethod("toString")
./toString.R-
./toString.R:toString.default <- function(x, width, ...)
./toString.R-{
./toString.R: string <- paste(x, collapse=", ")
./toString.R- if( missing(width) )
./toString.R- return( string )
./toString.R- if( width <= 0 )
./toString.R- stop("'width' must be positive")
./toString.R: if(nchar(string, type="c") > width) {
./toString.R: width <- max(6, width) ## Leave something!
./toString.R: string <- paste(strtrim(string, width-4), "....", sep = "")
./toString.R- }
./toString.R- string
./toString.R-}
--
./traceback.R-traceback <-
./traceback.R-function(x = NULL)
./traceback.R-{
./traceback.R: if(is.null(x) && (exists(".Traceback", env = .GlobalEnv)))
./traceback.R: x <- get(".Traceback", env = .GlobalEnv)
./traceback.R- if(is.null(x) || length(x) == 0)
./traceback.R: cat(gettext("No traceback available"), "\n")
./traceback.R- else {
./traceback.R- n <- length(x)
./traceback.R- for(i in 1:n) {
./traceback.R: label <- paste(n-i+1, ": ", sep="")
./traceback.R- if((m <- length(x[[i]])) > 1)
./traceback.R: label <- c(label, rep(substr(" ", 1,
./traceback.R: nchar(label, type="w")),
./traceback.R- m - 1))
./traceback.R: cat(paste(label, x[[i]], sep=""), sep="\n")
./traceback.R- }
./traceback.R- }
./traceback.R- invisible()
--
./trunc.R-## Commented by KH on 1999/01/30.
./trunc.R-## trunc() should really be in the `Math' group.
./trunc.R-
./trunc.R:##trunc <- function(x, ...) UseMethod("trunc")
./trunc.R-##trunc.default <- function(x) {
./trunc.R-## a <- attributes(x)
./trunc.R:## x <- ifelse(x < 0, ceiling(x), floor(x))
./trunc.R-## attributes(x) <- a
./trunc.R-## x
./trunc.R-##}
--
./unlist.R:unlist <- function(x, recursive=TRUE, use.names=TRUE)
./unlist.R: .Internal(unlist(x, recursive, use.names))
--
./unname.R:unname <- function (obj, force= FALSE) {
./unname.R- if (length(names(obj)))
./unname.R- names(obj) <- NULL
./unname.R- if (length(dimnames(obj)) && (force || !is.data.frame(obj)))
--
./upper.tri.R:upper.tri <- function(x, diag = FALSE)
./upper.tri.R-{
./upper.tri.R- x <- as.matrix(x)
./upper.tri.R- if(diag) row(x) <= col(x)
--
./userhooks.R:.userHooksEnv <- new.env(hash = FALSE, parent = NULL)
./userhooks.R-
./userhooks.R-packageEvent <-
./userhooks.R: function(pkgname, event=c("onLoad", "attach", "detach", "onUnload"))
./userhooks.R-{
./userhooks.R- event <- match.arg(event)
./userhooks.R: pkgname <- strsplit(pkgname, "_", fixed=TRUE)[[1]][1]
./userhooks.R: paste("UserHook", pkgname, event, sep = "::")
./userhooks.R-}
./userhooks.R-
./userhooks.R-getHook <- function(hookName)
./userhooks.R-{
./userhooks.R: if (exists(hookName, envir = .userHooksEnv, inherits = FALSE))
./userhooks.R: get(hookName, envir = .userHooksEnv, inherits = FALSE)
./userhooks.R- else list()
./userhooks.R-}
./userhooks.R-
./userhooks.R:setHook <- function(hookName, value,
./userhooks.R: action = c("append", "prepend", "replace"))
./userhooks.R-{
./userhooks.R- action <- match.arg(action)
./userhooks.R- old <- getHook(hookName)
./userhooks.R: new <- switch(action,
./userhooks.R: "append" = c(old, value),
./userhooks.R: "prepend" = c(value, old),
./userhooks.R- "replace" = value)
./userhooks.R- if (length(new))
./userhooks.R: assign(hookName, new, envir = .userHooksEnv, inherits = FALSE)
./userhooks.R: else if(exists(hookName, envir = .userHooksEnv, inherits = FALSE))
./userhooks.R: remove(list=hookName, envir = .userHooksEnv, inherits = FALSE)
./userhooks.R- invisible()
./userhooks.R-}
--
./utilities.R:mat.or.vec <- function(nr,nc)
./utilities.R: if(nc==1) numeric(nr) else matrix(0,nr,nc)
./utilities.R-
./utilities.R-## Use 'version' since that exists in all S dialects :
./utilities.R-is.R <-
--
./utils.R:shQuote <- function(string, type = c("sh", "csh", "cmd"))
./utils.R-{
./utils.R- cshquote <- function(x) {
./utils.R: xx <- strsplit(x, "'", fixed = TRUE)[[1]]
./utils.R: paste(paste("'", xx, "'", sep = ""), collapse="\"'\"")
./utils.R- }
./utils.R- if(missing(type) && .Platform$OS.type == "windows") type <- "cmd"
./utils.R- type <- match.arg(type)
./utils.R- if(type == "cmd") {
./utils.R: paste('"', gsub('"', '\\\\"', string), '"', sep = "")
./utils.R- } else {
./utils.R- if(!length(string)) return('')
./utils.R: has_single_quote <- grep("'", string)
./utils.R- if(!length(has_single_quote))
./utils.R: return(paste("'", string, "'", sep = ""))
./utils.R- if(type == "sh")
./utils.R: paste('"', gsub('(["$`\\])', "\\\\\\1", string), '"', sep="")
./utils.R- else {
./utils.R: if(!length(grep('([$`])', string))) {
./utils.R: paste('"', gsub('(["!\\])', "\\\\\\1", string), '"', sep="")
./utils.R: } else sapply(string, cshquote)
./utils.R- }
./utils.R- }
./utils.R-}
./utils.R-
./utils.R-.standard_regexps <-
./utils.R-function()
./utils.R-{
./utils.R: list(valid_package_name = "[[:alpha:]][[:alnum:].]*",
./utils.R: valid_package_version = "([[:digit:]]+[.-]){1,}[[:digit:]]+")
./utils.R-}
--
./vector.R:vector <- function(mode = "logical", length = 0).Internal(vector(mode,length))
./vector.R:logical <- function(length = 0) vector("logical", length)
./vector.R:character <- function(length = 0) vector("character", length)
./vector.R:integer <- function(length = 0) vector("integer", length)
./vector.R:double <- function(length = 0) vector("double", length)
./vector.R-real <- double
./vector.R-numeric <- double
./vector.R:complex <- function(length.out = 0,
./vector.R: real = numeric(), imaginary = numeric(),
./vector.R: modulus = 1, argument = 0) {
./vector.R- if(missing(modulus) && missing(argument)) {
./vector.R- ## assume 'real' and 'imaginary'
./vector.R: .Internal(complex(length.out, real, imaginary))
./vector.R- } else {
./vector.R: n <- max(length.out, length(argument), length(modulus))
./vector.R: rep(modulus,length.out=n) *
./vector.R: exp(1i * rep(argument, length.out=n))
./vector.R- }
./vector.R-}
./vector.R-
./vector.R-single <- function(length = 0)
./vector.R: structure(vector("double", length), Csingle=TRUE)
--
./warnings.R-warnings <- function(...)
./warnings.R-{
./warnings.R: if(!exists("last.warning", envir=.GlobalEnv)) return()
./warnings.R: last.warning <- get("last.warning", envir=.GlobalEnv)
./warnings.R- if(!(n <- length(last.warning))) return()
./warnings.R- names <- names(last.warning)
./warnings.R: cat(ngettext(n, "Warning message:\n", "Warning messages:\n"))
./warnings.R- for(i in 1:n) {
./warnings.R: out <- if(n == 1) names[i] else paste(i,": ", names[i], sep="")
./warnings.R- if(length(last.warning[[i]])) {
./warnings.R- temp <- deparse(last.warning[[i]])
./warnings.R: out <- paste(out, "in:", temp[1], if(length(temp) > 1) " ...")
./warnings.R- }
./warnings.R: cat(out, ..., fill = TRUE)
./warnings.R- }
./warnings.R-}
--
./which.R:which <- function(x, arr.ind = FALSE)
./which.R-{
./which.R- if(!is.logical(x))
./which.R- stop("argument to 'which' is not logical")
--
./which.R- }
./which.R- else { ##-- return a matrix length(wh) x rank
./which.R- rank <- length(dl)
./which.R- wh1 <- wh - 1
./which.R- wh <- 1 + wh1 %% dl[1]
./which.R: wh <- matrix(wh, nrow = m, ncol = rank,
./which.R- dimnames =
./which.R: list(dimnames(x)[[1]][wh],
./which.R: if(rank == 2) c("row", "col")# for matrices
./which.R: else paste("dim", 1:rank, sep="")))
./which.R- if(rank >= 2) {
./which.R- denom <- 1
./which.R- for (i in 2:rank) {
./which.R- denom <- denom * dl[i-1]
./which.R- nextd1 <- wh1 %/% denom# (next dim of elements) - 1
./which.R: wh[,i] <- 1 + nextd1 %% dl[i]
./which.R- }
./which.R- }
./which.R- storage.mode(wh) <- "integer"
--
./write.R:write <- function(x, file="data",ncolumns=if(is.character(x)) 1 else 5, append=FALSE)
./write.R: cat(x, file=file, sep=c(rep.int(" ",ncolumns-1), "\n"), append=append)
--
./write.table.R-write.table0 <-
./write.table.R:function (x, file = "", append = FALSE, quote = TRUE, sep = " ",
./write.table.R: eol = "\n", na = "NA", dec = ".", row.names = TRUE,
./write.table.R: col.names = TRUE, qmethod = c("escape", "double"))
./write.table.R-{
./write.table.R- qmethod <- match.arg(qmethod)
./write.table.R-
./write.table.R- if(!is.data.frame(x) && !is.matrix(x)) x <- data.frame(x)
./write.table.R-
./write.table.R- if(is.data.frame(x)) {
./write.table.R- if(is.logical(quote) && quote)
./write.table.R: quote <- if(length(x)) which(unlist(lapply(x, function(x) is.character(x) || is.factor(x)))) else numeric(0)
./write.table.R- if(dec != ".") {
./write.table.R- ## only need to consider numeric non-integer columns
./write.table.R: num <- which(unlist(lapply(x, function(x) is.double(x)
./write.table.R- || is.complex(x))))
./write.table.R- if(length(num))
./write.table.R: x[num] <- lapply(x[num],
./write.table.R: function(z) gsub("\\.", dec, as.character(z)))
./write.table.R- }
./write.table.R- ## as.matrix might turn integer or numeric columns into a complex matrix
./write.table.R: cmplx <- sapply(x, is.complex)
./write.table.R- if(length(cmplx) && any(cmplx) && !all(cmplx))
./write.table.R: x[cmplx] <- lapply(x[cmplx], as.character)
./write.table.R- x <- as.matrix(x)
./write.table.R: ## we may have gained some columns here, as embedded matrices/dfs
./write.table.R- ## are split up into columns.
./write.table.R- d <- dimnames(x)
./write.table.R- } else { # a matrix
./write.table.R- if(is.logical(quote) && quote)
./write.table.R- quote <- if(is.character(x)) seq(length=p) else numeric(0)
./write.table.R: if(dec != "." && typeof(x) %in% c("double", "complex"))
./write.table.R: x[] <- gsub("\\.", dec, as.character(x))
./write.table.R- ## fix up dimnames as as.data.frame would
./write.table.R- p <- ncol(x)
./write.table.R- d <- dimnames(x)
./write.table.R: if(is.null(d)) d <- list(NULL, NULL)
./write.table.R- if(is.null(d[[1]])) d[[1]] <- seq(length=nrow(x))
./write.table.R: if(is.null(d[[2]]) && p > 0) d[[2]] <- paste("V", 1:p, sep="")
./write.table.R- }
./write.table.R: ## from this point on we have a matrix, possibly even a matrix list.
./write.table.R-
./write.table.R- p <- ncol(x)
./write.table.R- nocols <- NCOL(x)==0
--
./write.table.R- stop("invalid 'quote' specification")
./write.table.R-
./write.table.R- rn <- FALSE
./write.table.R- if(is.logical(row.names)) {
./write.table.R- if(row.names) {
./write.table.R: x <- cbind(d[[1]], x)
./write.table.R- rn <- TRUE
./write.table.R- }
./write.table.R- } else {
./write.table.R- rnames <- as.character(row.names)
./write.table.R- rn <- TRUE
./write.table.R- if(length(rnames) == nrow(x))
./write.table.R: x <- cbind(rnames, x)
./write.table.R- else
./write.table.R- stop("invalid 'row.names' specification")
./write.table.R- }
./write.table.R- if(!is.null(quote) && rn) # quote the row names
./write.table.R: quote <- c(0, quote) + 1
./write.table.R-
./write.table.R- if(is.logical(col.names))
./write.table.R: col.names <- if(is.na(col.names) && rn) c("", d[[2]])
./write.table.R- else if(col.names) d[[2]] else NULL
./write.table.R- else {
./write.table.R- col.names <- as.character(col.names)
--
./write.table.R- }
./write.table.R-
./write.table.R- if(file == "")
./write.table.R- file <- stdout()
./write.table.R- else if(is.character(file)) {
./write.table.R: file <- file(file, ifelse(append, "a", "w"))
./write.table.R- on.exit(close(file))
./write.table.R- }
./write.table.R: if(!inherits(file, "connection"))
./write.table.R- stop("'file' must be a character string or connection")
./write.table.R-
./write.table.R- qstring <- # quoted embedded quote string
./write.table.R: switch(qmethod,
./write.table.R: "escape" = '\\\\"',
./write.table.R- "double" = '""')
./write.table.R- if(!is.null(col.names)) {
./write.table.R- if(append)
./write.table.R- warning("appending column names to file")
./write.table.R- if(length(quote))
./write.table.R: col.names <- paste("\"", gsub('"', qstring, col.names),
./write.table.R: "\"", sep = "")
./write.table.R: writeLines(paste(col.names, collapse = sep), file, sep = eol)
./write.table.R- }
./write.table.R-
./write.table.R- if (NROW(x) == 0) return(invisible())
./write.table.R: if (nocols && !rn) return(cat(rep.int(eol, NROW(x)), file=file, sep=""))
./write.table.R-
./write.table.R- for(i in quote)
./write.table.R: x[, i] <- paste('"', gsub('"', qstring, as.character(x[, i])),
./write.table.R: '"', sep = "")
./write.table.R: writeLines(paste(c(t(x)), c(rep.int(sep, ncol(x) - 1), eol),
./write.table.R: sep = "", collapse = ""),
./write.table.R: file, sep = "")
./write.table.R-}
./write.table.R-
./write.table.R-write.table <-
./write.table.R:function (x, file = "", append = FALSE, quote = TRUE, sep = " ",
./write.table.R: eol = "\n", na = "NA", dec = ".", row.names = TRUE,
./write.table.R: col.names = TRUE, qmethod = c("escape", "double"))
./write.table.R-{
./write.table.R- qmethod <- match.arg(qmethod)
./write.table.R-
--
./write.table.R-
./write.table.R- if(is.matrix(x)) {
./write.table.R- ## fix up dimnames as as.data.frame would
./write.table.R- p <- ncol(x)
./write.table.R- d <- dimnames(x)
./write.table.R: if(is.null(d)) d <- list(NULL, NULL)
./write.table.R- if(is.null(d[[1]])) d[[1]] <- seq(length=nrow(x))
./write.table.R: if(is.null(d[[2]]) && p > 0) d[[2]] <- paste("V", 1:p, sep="")
./write.table.R- if(is.logical(quote) && quote)
./write.table.R- quote <- if(is.character(x)) seq(length=p) else numeric(0)
./write.table.R- } else {
./write.table.R- qset <- FALSE
./write.table.R- if(is.logical(quote) && quote) {
./write.table.R: quote <- if(length(x)) which(unlist(lapply(x, function(x) is.character(x) || is.factor(x)))) else numeric(0)
./write.table.R- qset <- TRUE
./write.table.R- }
./write.table.R- ## fix up embedded matrix columns into separate cols
./write.table.R: ismat <- sapply(x, function(z) length(dim(z)) == 2 && dim(z)[2] > 1)
./write.table.R- if(any(ismat)) {
./write.table.R- c1 <- names(x)
./write.table.R- x <- as.matrix(x)
./write.table.R- if(qset) {
./write.table.R- c2 <- colnames(x)
./write.table.R: ord <- match(c1, c2, 0)
./write.table.R- quote <- ord[quote]; quote <- quote[quote > 0]
./write.table.R- }
./write.table.R- }
--
./write.table.R- rn <- TRUE
./write.table.R- if(length(rnames) != nrow(x))
./write.table.R- stop("invalid 'row.names' specification")
./write.table.R- }
./write.table.R- if(!is.null(quote) && rn) # quote the row names
./write.table.R: quote <- c(0, quote)
./write.table.R-
./write.table.R- if(is.logical(col.names))
./write.table.R: col.names <- if(is.na(col.names) && rn) c("", d[[2]])
./write.table.R- else if(col.names) d[[2]] else NULL
./write.table.R- else {
./write.table.R- col.names <- as.character(col.names)
--
./write.table.R- }
./write.table.R-
./write.table.R- if(file == "")
./write.table.R- file <- stdout()
./write.table.R- else if(is.character(file)) {
./write.table.R: file <- file(file, ifelse(append, "a", "w"))
./write.table.R- on.exit(close(file))
./write.table.R- }
./write.table.R: if(!inherits(file, "connection"))
./write.table.R- stop("'file' must be a character string or connection")
./write.table.R-
./write.table.R- qstring <- # quoted embedded quote string
./write.table.R: switch(qmethod,
./write.table.R: "escape" = '\\\\"',
./write.table.R- "double" = '""')
./write.table.R- if(!is.null(col.names)) {
./write.table.R- if(append)
./write.table.R- warning("appending column names to file")
./write.table.R- if(length(quote))
./write.table.R: col.names <- paste("\"", gsub('"', qstring, col.names),
./write.table.R: "\"", sep = "")
./write.table.R: writeLines(paste(col.names, collapse = sep), file, sep = eol)
./write.table.R- }
./write.table.R-
./write.table.R- if (nrow(x) == 0) return(invisible())
./write.table.R: if (nocols && !rn) return(cat(rep.int(eol, NROW(x)), file=file, sep=""))
./write.table.R-
./write.table.R- ## convert list matrices to character - maybe not much use?
./write.table.R- if(is.matrix(x) && !is.atomic(x)) mode(x) <- "character"
./write.table.R- if(is.data.frame(x)) {
./write.table.R- ## convert columns we can't handle in C code
./write.table.R: x[] <- lapply(x, function(z) {
./write.table.R- if(is.object(z) && !is.factor(z)) as.character(z) else z
./write.table.R- })
./write.table.R- }
./write.table.R-
./write.table.R: .Internal(write.table(x, file, nrow(x), p, rnames, sep, eol, na, dec,
./write.table.R: as.integer(quote), qmethod != "double"))
./write.table.R-}
./write.table.R-
./write.table.R:write.csv <- function(..., col.names=NA, sep=",", qmethod="double")
./write.table.R: write.table(..., col.names=NA, sep=",", qmethod="double")
./write.table.R:write.csv2 <- function(..., col.names=NA, dec=",", sep=";", qmethod="double")
./write.table.R: write.table(..., col.names=NA, dec=",", sep=";", qmethod="double")
--
./xor.R:xor <- function(x, y) { (x | y) & !(x & y) }
--
./zapsmall.R:zapsmall <- function(x, digits = getOption("digits"))
./zapsmall.R-{
./zapsmall.R- if (length(digits) == 0)
./zapsmall.R- stop("invalid 'digits'")
./zapsmall.R- if (all(ina <- is.na(x)))
./zapsmall.R- return(x)
./zapsmall.R- mx <- max(abs(x[!ina]))
./zapsmall.R: round(x, digits = if(mx > 0) max(0, digits - log10(mx)) else digits)
./zapsmall.R-}
--
./zdatetime.R-## needs to run after paste()
./zdatetime.R-.leap.seconds <- local({
./zdatetime.R- .leap.seconds <-
./zdatetime.R: c("1972-6-30", "1972-12-31", "1973-12-31", "1974-12-31",
./zdatetime.R: "1975-12-31", "1976-12-31", "1977-12-31", "1978-12-31",
./zdatetime.R: "1979-12-31", "1981-6-30", "1983-6-30", "1985-6-30",
./zdatetime.R: "1986-6-30", "1987-12-31", "1989-12-31", "1990-12-31",
./zdatetime.R: "1992-6-30", "1993-6-30", "1994-6-30","1995-12-31",
./zdatetime.R: "1997-6-30", "1998-12-31")
./zdatetime.R: .leap.seconds <- strptime(paste(.leap.seconds , "23:59:60"),
./zdatetime.R- "%Y-%m-%d %H:%M:%S")
./zdatetime.R: c(as.POSIXct(.leap.seconds, "GMT")) # lose the timezone
./zdatetime.R-})
--
./zdynvars.R-
./zdynvars.R-.dynLibs <- local({
./zdynvars.R- ##
./zdynvars.R- ## Versions of R prior to 1.4.0 had .Dyn.libs in .AutoloadEnv
./zdynvars.R- ## (and did not always ensure getting it from there).
./zdynvars.R: ## Until 1.6.0, we consistently used the base environment.
./zdynvars.R- ## Now we have a dynamic variable instead.
./zdynvars.R- ##
./zdynvars.R: .Dyn.libs <- structure(list(), class = "DLLInfoList")
./zdynvars.R- function(new) {
./zdynvars.R- if(!missing(new)) {
./zdynvars.R- class(new) <- "DLLInfoList"
--
./zdynvars.R-
./zdynvars.R-.libPaths <- local({
./zdynvars.R- .lib.loc <- character(0) # Profiles need to set this.
./zdynvars.R- function(new) {
./zdynvars.R- if(!missing(new)) {
./zdynvars.R: paths <- unique(c(new, .Library))
./zdynvars.R- .lib.loc <<- paths[file.exists(paths)]
./zdynvars.R- }
./zdynvars.R- else
--
./zzz.R-## extracted from existing NAMESPACE files in Dec 2003
./zzz.R-.knownS3Generics <- local({
./zzz.R-
./zzz.R- ## include the S3 group generics here
./zzz.R: baseGenerics <- c("Math", "Ops", "Summary", "Complex",
./zzz.R: "as.character", "as.data.frame", "as.matrix", "as.vector",
./zzz.R: "labels", "print", "solve", "summary", "t")
./zzz.R-
./zzz.R: utilsGenerics <- c("edit", "str")
./zzz.R-
./zzz.R: graphicsGenerics <- c("contour", "hist", "identify", "image",
./zzz.R: "lines", "pairs", "plot", "points", "text")
./zzz.R-
./zzz.R: statsGenerics <- c( "add1", "AIC", "anova", "biplot", "coef",
./zzz.R: "confint", "deviance", "df.residual", "drop1", "extractAIC",
./zzz.R: "fitted", "formula", "logLik", "model.frame", "model.matrix",
./zzz.R: "predict", "profile", "qqnorm", "residuals", "se.contrast",
./zzz.R: "terms", "update", "vcov")
./zzz.R-
./zzz.R: tmp <- rep.int(c("base", "utils", "graphics", "stats"),
./zzz.R: c(length(baseGenerics), length(utilsGenerics),
./zzz.R: length(graphicsGenerics), length(statsGenerics)))
./zzz.R- names(tmp) <-
./zzz.R: c(baseGenerics, utilsGenerics, graphicsGenerics, statsGenerics)
./zzz.R- tmp
./zzz.R-})
./dataframe.R- cl <- class(xi1) # `methods' adds a class -- Eh?
./dataframe.R- vlist[[i]] <- list(structure(rep(xi1, length.out = nr), class=cl))
./dataframe.R- next
./dataframe.R- }
./dataframe.R- }
./dataframe.R: stop("arguments imply differing number of rows: ",
./dataframe.R- paste(unique(nrows), collapse = ", "))
./dataframe.R- }
./dataframe.R- value <- unlist(vlist, recursive=FALSE, use.names=FALSE)
./dataframe.R- if(length(row.names) == 1 && nr != 1) { # one of the variables
./dataframe.R- if(is.character(row.names))
./dataframe.R- row.names <- match(row.names, vnames, 0)
./dataframe.R- if(length(row.names)!=1 ||
./dataframe.R- row.names < 1 || row.names > length(vnames))
./dataframe.R: stop("row.names should specify one of the variables")
./dataframe.R- i <- row.names
./dataframe.R- row.names <- value[[i]]
./dataframe.R- value <- value[ - i]
./dataframe.R- stop("row.names should specify one of the variables")
./dataframe.R- i <- row.names
./dataframe.R- row.names <- value[[i]]
./dataframe.R- value <- value[ - i]
./dataframe.R- } else if (length(row.names) > 0 && length(row.names) != nr)
./dataframe.R: stop("row names supplied are of the wrong length")
./dataframe.R- } else if(length(row.names) > 0 && length(row.names) != nr) {
./dataframe.R- warning("row names were found from a short variable and have been discarded")
./dataframe.R- row.names <- NULL
./dataframe.R- row.names <- value[[i]]
./dataframe.R- value <- value[ - i]
./dataframe.R- } else if (length(row.names) > 0 && length(row.names) != nr)
./dataframe.R- stop("row names supplied are of the wrong length")
./dataframe.R- } else if(length(row.names) > 0 && length(row.names) != nr) {
./dataframe.R: warning("row names were found from a short variable and have been discarded")
./dataframe.R- row.names <- NULL
./dataframe.R- }
./dataframe.R- if(length(row.names) == 0) row.names <- seq(length = nr)
./dataframe.R- row.names <- NULL
./dataframe.R- }
./dataframe.R- if(length(row.names) == 0) row.names <- seq(length = nr)
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(any(is.na(row.names)))
./dataframe.R: stop("row names contain missing values")
./dataframe.R- if(any(duplicated(row.names)))
./dataframe.R- stop("duplicate row.names: ",
./dataframe.R- paste(unique(row.names[duplicated(row.names)]), collapse = ", "))
./dataframe.R- if(length(row.names) == 0) row.names <- seq(length = nr)
./dataframe.R- row.names <- as.character(row.names)
./dataframe.R- if(any(is.na(row.names)))
./dataframe.R- stop("row names contain missing values")
./dataframe.R- if(any(duplicated(row.names)))
./dataframe.R: stop("duplicate row.names: ",
./dataframe.R- paste(unique(row.names[duplicated(row.names)]), collapse = ", "))
./dataframe.R- attr(value, "row.names") <- row.names
./dataframe.R- attr(value, "class") <- "data.frame"
./dataframe.R-{
./dataframe.R- mdrop <- missing(drop)
./dataframe.R- Narg <- nargs() - !mdrop # number of arg from x,i,j that were specified
./dataframe.R-
./dataframe.R- if(Narg < 3) { # list-like indexing or matrix indexing
./dataframe.R: if(!mdrop) warning("drop argument will be ignored")
./dataframe.R- if(missing(i))
./dataframe.R- return(x)
./dataframe.R- if(is.matrix(i))
./dataframe.R- return(x)
./dataframe.R- if(is.matrix(i))
./dataframe.R- return(as.matrix(x)[i]) # desperate measures
./dataframe.R- y <- NextMethod("[")
./dataframe.R- nm <- names(y)
./dataframe.R: if(any(is.na(nm))) stop("undefined columns selected")
./dataframe.R- ## added in 1.8.0
./dataframe.R- if(any(duplicated(nm))) names(y) <- make.unique(nm)
./dataframe.R- return(structure(y, class = oldClass(x), row.names = row.names(x)))
--
./dataframe.R-
./dataframe.R- if(missing(i)) { # df[, j] or df[ , ]
./dataframe.R- ## handle the column only subsetting ...
./dataframe.R- if(!missing(j)) x <- x[j]
./dataframe.R- cols <- names(x)
./dataframe.R: if(any(is.na(cols))) stop("undefined columns selected")
./dataframe.R- }
./dataframe.R- else { # df[i, j] or df[i , ]
./dataframe.R- if(is.character(i))
./dataframe.R- i <- pmatch(i, rows, duplicates.ok = TRUE)
./dataframe.R- rows <- rows[i]
./dataframe.R- if(!missing(j)) { # df[i, j]
./dataframe.R- x <- x[j]
./dataframe.R- cols <- names(x)
./dataframe.R: if(any(is.na(cols))) stop("undefined columns selected")
./dataframe.R- }
./dataframe.R- for(j in seq(along = x)) {
./dataframe.R- xj <- x[[j]]
./dataframe.R- ## allow replication of length(value) > 1 in 1.8.0
./dataframe.R- N <- length(value)
./dataframe.R- if(N > 0 && N < nreplace && (nreplace %% N) == 0)
./dataframe.R- value <- rep(value, length.out = nreplace)
./dataframe.R- if(length(value) != nreplace)
./dataframe.R: stop("rhs is the wrong length for indexing by a logical matrix")
./dataframe.R- n <- 0
./dataframe.R- nv <- nrow(x)
./dataframe.R- for(v in seq(len = dim(i)[2])) {
./dataframe.R- n <- n+nv
./dataframe.R- }
./dataframe.R- return(x)
./dataframe.R- } # end of logical matrix
./dataframe.R- if(is.matrix(i))
./dataframe.R: stop("only logical matrix subscripts are allowed in replacement")
./dataframe.R- j <- i
./dataframe.R- i <- NULL
./dataframe.R- has.i <- FALSE
./dataframe.R- has.i <- FALSE
./dataframe.R- has.j <- TRUE
./dataframe.R- }
./dataframe.R- }
./dataframe.R- else {
./dataframe.R: stop("need 0, 1, or 2 subscripts")
./dataframe.R- }
./dataframe.R- ## no columns specified
./dataframe.R- if(has.j && length(j) ==0) return(x)
./dataframe.R- new.cols <- NULL
./dataframe.R- nvars <- length(x)
./dataframe.R- nrows <- length(rows)
./dataframe.R- if(has.i) { # df[i, ] or df[i, j]
./dataframe.R- if(any(is.na(i)))
./dataframe.R: stop("missing values are not allowed in subscripted assignments of data frames")
./dataframe.R- if(char.i <- is.character(i)) {
./dataframe.R- ii <- match(i, rows)
./dataframe.R- nextra <- sum(new.rows <- is.na(ii))
--
./dataframe.R- stop("non-existent rows not allowed")
./dataframe.R- }
./dataframe.R- else iseq <- NULL
./dataframe.R- if(has.j) {
./dataframe.R- if(any(is.na(j)))
./dataframe.R: stop("missing values are not allowed in subscripted assignments of data frames")
./dataframe.R- if(is.character(j)) {
./dataframe.R- jj <- match(j, names(x))
./dataframe.R- nnew <- sum(is.na(jj))
./dataframe.R- rows <- attr(x, "row.names")
./dataframe.R- nrows <- length(rows)
./dataframe.R- }
./dataframe.R- iseq <- seq(along = rows)[i]
./dataframe.R- if(any(is.na(iseq)))
./dataframe.R: stop("non-existent rows not allowed")
./dataframe.R- }
./dataframe.R- else iseq <- NULL
./dataframe.R- if(has.j) {
--
./dataframe.R- rows <- attr(x, "row.names")
./dataframe.R- nrows <- length(rows)
./dataframe.R- }
./dataframe.R- iseq <- seq(along = rows)[i]
./dataframe.R- if(any(is.na(iseq)))
./dataframe.R: stop("non-existent rows not allowed")
./dataframe.R- if(is.character(j)) {
./dataframe.R- jseq <- match(j, names(x))
./dataframe.R- if(any(is.na(jseq)))
./dataframe.R- jseq <- j
./dataframe.R- if(max(jseq) > nvars) {
./dataframe.R- new.cols <- paste("V", seq(from = nvars + 1, to = max(jseq)),
./dataframe.R- sep = "")
./dataframe.R- if(length(new.cols) != sum(jseq > nvars))
./dataframe.R: stop("new columns would leave holes after existing columns")
./dataframe.R- ## try to use the names of a list `value'
./dataframe.R- if(is.list(value) && !is.null(vnm <- names(value))) {
./dataframe.R- p <- length(jseq)
./dataframe.R- }
./dataframe.R- }
./dataframe.R- else jseq <- seq(along = x)
./dataframe.R- ## addition in 1.8.0
./dataframe.R- if(any(duplicated(jseq)))
./dataframe.R: stop("duplicate subscripts for columns")
./dataframe.R- n <- length(iseq)
./dataframe.R- if(n == 0) n <- nrows
./dataframe.R- p <- length(jseq)
./dataframe.R- m <- length(value)
./dataframe.R- if(!is.list(value)) {
./dataframe.R- if(p == 1) {
./dataframe.R- N <- NROW(value)
./dataframe.R- if(N > n)
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, n),
./dataframe.R- domain = NA)
./dataframe.R- if(N < n && N > 0)
./dataframe.R- if(n %% N == 0 && length(dim(value)) <= 1)
./dataframe.R- value <- rep(value, length.out = n)
./dataframe.R- else
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, n),
./dataframe.R- domain = NA)
./dataframe.R- names(value) <- NULL
./dataframe.R- value <- list(value)
--
./dataframe.R- ## really ambiguous, but follow common use as if list
./dataframe.R- nc <- length(x)
./dataframe.R- if(!is.null(value)) {
./dataframe.R- N <- NROW(value)
./dataframe.R- if(N > nrows)
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, nrows),
./dataframe.R- domain = NA)
./dataframe.R- if(N < nrows && N > 0)
./dataframe.R- if(nrows %% N == 0 && length(dim(value)) <= 1)
./dataframe.R- value <- rep(value, length.out = nrows)
./dataframe.R- else
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d",
./dataframe.R- N, nrows), domain = NA)
./dataframe.R- }
./dataframe.R- x[[i]] <- value
--
./dataframe.R- class(x) <- NULL
./dataframe.R- nrows <- length(attr(x, "row.names"))
./dataframe.R- if(!is.null(value)) {
./dataframe.R- N <- NROW(value)
./dataframe.R- if(N > nrows)
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, nrows),
./dataframe.R- domain = NA)
./dataframe.R- if(N < nrows && N > 0)
./dataframe.R- if(nrows %% N == 0 && length(dim(value)) <= 1)
./dataframe.R- value <- rep(value, length.out = nrows)
./dataframe.R- else
./dataframe.R: stop(gettextf("replacement has %d rows, data has %d", N, nrows),
./dataframe.R- domain = NA)
./dataframe.R- if(is.atomic(value)) names(value) <- NULL
./dataframe.R- }
./dataframe.R- domain = NA)
./dataframe.R- names(value) <- NULL
./dataframe.R- value <- list(value)
./dataframe.R- } else {
./dataframe.R- if(m < n*p && (n*p) %% m)
./dataframe.R: stop(gettextf("replacement has %d items, need %d", m, n*p),
./dataframe.R- domain = NA)
./dataframe.R- value <- matrix(value, n, p) ## will recycle
./dataframe.R- value <- split(value, col(value))
./dataframe.R- value <- unclass(value) # to avoid data frame indexing
./dataframe.R- lens <- sapply(value, NROW)
./dataframe.R- for(k in seq(along=lens)) {
./dataframe.R- N <- lens[k]
./dataframe.R- if(n != N && length(dim(value[[k]])) == 2)
./dataframe.R: stop(gettextf("replacement element %d is a matrix/data frame of %d rows, need %d", k, N, n),
./dataframe.R- domain = NA)
./dataframe.R- if(N > 0 && N < n && n %% N)
./dataframe.R- stop(gettextf("replacement element %d has %d rows, need %d",
./dataframe.R- N <- lens[k]
./dataframe.R- if(n != N && length(dim(value[[k]])) == 2)
./dataframe.R- stop(gettextf("replacement element %d is a matrix/data frame of %d rows, need %d", k, N, n),
./dataframe.R- domain = NA)
./dataframe.R- if(N > 0 && N < n && n %% N)
./dataframe.R: stop(gettextf("replacement element %d has %d rows, need %d",
./dataframe.R- k, N, n), domain = NA)
./dataframe.R- ## these fixing-ups will not work for matrices
./dataframe.R- if(N > 0 && N < n) value[[k]] <- rep(value[[k]], length.out = n)
./dataframe.R- stop(gettextf("replacement element %d has %d rows, need %d",
./dataframe.R- k, N, n), domain = NA)
./dataframe.R- ## these fixing-ups will not work for matrices
./dataframe.R- if(N > 0 && N < n) value[[k]] <- rep(value[[k]], length.out = n)
./dataframe.R- if(N > n) {
./dataframe.R: warning(gettextf("replacement element %d has %d rows to replace %d rows",
./dataframe.R- k, N, n), domain = NA)
./dataframe.R- value[[k]] <- value[[k]][1:n]
./dataframe.R- }
./dataframe.R- }
./dataframe.R- nrowv <- dimv[1]
./dataframe.R- if(nrowv < n && nrowv > 0) {
./dataframe.R- if(n %% nrowv == 0)
./dataframe.R- value <- value[rep(1:nrowv, length.out = n),,drop = FALSE]
./dataframe.R: else stop(gettextf("%d rows in value to replace %d rows", nrowv, n),
./dataframe.R- domain = NA)
./dataframe.R- }
./dataframe.R- else if(nrowv > n)
./dataframe.R- value <- value[rep(1:nrowv, length.out = n),,drop = FALSE]
./dataframe.R- else stop(gettextf("%d rows in value to replace %d rows", nrowv, n),
./dataframe.R- domain = NA)
./dataframe.R- }
./dataframe.R- else if(nrowv > n)
./dataframe.R: warning(gettextf("replacement data has %d rows to replace %d rows",
./dataframe.R- nrowv, n), domain = NA)
./dataframe.R- ncolv <- dimv[2]
./dataframe.R- jvseq <- seq(len=p)
./dataframe.R- nrowv, n), domain = NA)
./dataframe.R- ncolv <- dimv[2]
./dataframe.R- jvseq <- seq(len=p)
./dataframe.R- if(ncolv < p) jvseq <- rep(1:ncolv, length.out = p)
./dataframe.R- else if(ncolv > p)
./dataframe.R: warning(gettextf("provided %d variables to replace %d variables",
./dataframe.R- ncolv, p), domain = NA)
./dataframe.R- if(length(new.cols)) {
./dataframe.R- ## extend and name now, as assignment of NULL may delete cols later.
./dataframe.R- if(any(is.na(iseq)))
./dataframe.R- stop("non-existent rows not allowed")
./dataframe.R- if(is.character(j)) {
./dataframe.R- jseq <- match(j, names(x))
./dataframe.R- if(any(is.na(jseq)))
./dataframe.R: stop("replacing element in non-existent column: ", j[is.na(jseq)])
./dataframe.R- }
./dataframe.R- else if(is.logical(j) || min(j) < 0)
./dataframe.R- jseq <- seq(along = x)[j]
./dataframe.R- else {
./dataframe.R- jseq <- j
./dataframe.R- if(max(jseq) > nvars)
./dataframe.R: stop("replacing element in non-existent column: ", jseq[jseq>nvars])
./dataframe.R- }
./dataframe.R- if(length(iseq) > 1 || length(jseq) > 1)
./dataframe.R- stop("only a single element should be replaced")
./dataframe.R- jseq <- j
./dataframe.R- if(max(jseq) > nvars)
./dataframe.R- stop("replacing element in non-existent column: ", jseq[jseq>nvars])
./dataframe.R- }
./dataframe.R- if(length(iseq) > 1 || length(jseq) > 1)
./dataframe.R: stop("only a single element should be replaced")
./dataframe.R- x[[jseq]][[iseq]] <- value
./dataframe.R- class(x) <- cl
./dataframe.R- x
./dataframe.R- {
./dataframe.R- if(all(clabs == nmi))
./dataframe.R- NULL
./dataframe.R- else if(all(nii <- match(nmi, clabs, 0)))
./dataframe.R- nii
./dataframe.R: else stop("names don't match previous names:\n\t",
./dataframe.R- paste(nmi[nii == 0], collapse = ", "))
./dataframe.R- }
./dataframe.R- Make.row.names <- function(nmi, ri, ni, nrow)
./dataframe.R- }
./dataframe.R- else if(is.list(xi)) {
./dataframe.R- ni <- range(sapply(xi, length))
./dataframe.R- if(ni[1] == ni[2])
./dataframe.R- ni <- ni[1]
./dataframe.R: else stop("invalid list argument: all variables should have the same length")
./dataframe.R- rows[[i]] <- ri <- seq(from = nrow + 1, length = ni)
./dataframe.R- nrow <- nrow + ni
./dataframe.R- rlabs[[i]] <- Make.row.names(nmi, ri, ni, nrow)
./dataframe.R- return(r)
./dataframe.R- }
./dataframe.R- else {
./dataframe.R- vnames <- names(x)
./dataframe.R- if (is.null(vnames)) vnames <- seq(along=x)
./dataframe.R: stop("non-numeric variable in data frame: ", vnames[!mode.ok])
./dataframe.R- }
./dataframe.R-}
./dataframe.R-
./dataframe.R- lscalar <- rscalar <- FALSE
./dataframe.R- if(lclass && rclass) {
./dataframe.R- rn <- row.names(e1)
./dataframe.R- cn <- names(e1)
./dataframe.R- if(any(dim(e2) != dim(e1)))
./dataframe.R: stop(.Generic, " only defined for equally-sized data frames")
./dataframe.R- } else if(lclass) {
./dataframe.R- ## e2 is not a data frame, but e1 is.
./dataframe.R- rn <- row.names(e1)
./dataframe.R- cn <- names(e1)
./dataframe.R- rscalar <- length(e2) <= 1 # e2 might be null
./dataframe.R- if(isList(e2)) {
./dataframe.R- if(rscalar) e2 <- e2[[1]]
./dataframe.R- else if(length(e2) != ncol(e1))
./dataframe.R: stop(gettextf("list of length %d not meaningful", length(e2)),
./dataframe.R- domain = NA)
./dataframe.R- } else {
./dataframe.R- if(!rscalar)
--
./dataframe.R- cn <- names(e2)
./dataframe.R- lscalar <- length(e1) <= 1
./dataframe.R- if(isList(e1)) {
./dataframe.R- if(lscalar) e1 <- e1[[1]]
./dataframe.R- else if(length(e1) != ncol(e2))
./dataframe.R: stop(gettextf("list of length %d not meaningful", length(e1)),
./dataframe.R- domain = NA)
./dataframe.R- } else {
./dataframe.R- if(!lscalar)
./dataframe.R-
./dataframe.R-Summary.data.frame <- function(x, ...)
./dataframe.R-{
./dataframe.R- x <- as.matrix(x)
./dataframe.R- if(!is.numeric(x) && !is.complex(x))
./dataframe.R: stop("only defined on a data frame with all numeric or complex variables")
./dataframe.R- NextMethod(.Generic)
./dataframe.R-}
./dates.R- }
./dates.R- if(is.na(xx) ||
./dates.R- !is.na(strptime(xx, f <- "%Y-%m-%d")) ||
./dates.R- !is.na(strptime(xx, f <- "%Y/%m/%d"))
./dates.R- ) return(strptime(x, f))
./dates.R: stop("character string is not in a standard unambiguous format")
./dates.R- }
./dates.R- res <- if(missing(format)) fromchar(x) else strptime(x, format)
./dates.R- .Internal(POSIXlt2Date(res))
--
./datetime.R- {
./datetime.R- res <- strptime(x, f)
./datetime.R- if(nchar(tz)) attr(res, "tzone") <- tz
./datetime.R- return(res)
./datetime.R- }
./datetime.R: stop("character string is not in a standard unambiguous format")
./datetime.R- }
./datetime.R-
./datetime.R- if(inherits(x, "POSIXlt")) return(x)
./dates.R- }
./dates.R-
./dates.R- if (nargs() == 1) return(e1)
./dates.R- # only valid if one of e1 and e2 is a scalar.
./dates.R- if(inherits(e1, "Date") && inherits(e2, "Date"))
./dates.R: stop("binary + is not defined for Date objects")
./dates.R- if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
./dates.R- if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
./dates.R- structure(unclass(e1) + unclass(e2), class = "Date")
./dates.R- round(switch(attr(x,"units"),
./dates.R- secs = x/86400, mins = x/1440, hours = x/24,
./dates.R- days = x, weeks = 7*x))
./dates.R- }
./dates.R- if(!inherits(e1, "Date"))
./dates.R: stop("Can only subtract from Date objects")
./dates.R- if (nargs() == 1) stop("unary - is not defined for Date objects")
./dates.R- if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
./dates.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./dates.R- secs = x/86400, mins = x/1440, hours = x/24,
./dates.R- days = x, weeks = 7*x))
./dates.R- }
./dates.R- if(!inherits(e1, "Date"))
./dates.R- stop("Can only subtract from Date objects")
./dates.R: if (nargs() == 1) stop("unary - is not defined for Date objects")
./dates.R- if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
./dates.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./dates.R- if(!is.null(attr(e2, "class")))
./dates.R- stop("Can only subtract from Date objects")
./dates.R- if (nargs() == 1) stop("unary - is not defined for Date objects")
./dates.R- if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
./dates.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./dates.R- if(!is.null(attr(e2, "class")))
./dates.R: stop("can only subtract numbers from Date objects")
./dates.R- structure(unclass(as.Date(e1)) - e2, class = "Date")
./dates.R-}
./dates.R-
./dataframe.R-}
./dataframe.R-
./dataframe.R-Ops.data.frame <- function(e1, e2 = NULL)
./dataframe.R-{
./dataframe.R- isList <- function(x) !is.null(x) && is.list(x)
./dataframe.R: unary <- nargs() == 1
./dataframe.R- lclass <- nchar(.Method[1]) > 0
./dataframe.R: rclass <- !unary && (nchar(.Method[2]) > 0)
./dataframe.R- value <- list()
./dataframe.R- ## set up call as op(left, right)
./dataframe.R- FUN <- get(.Generic, envir = parent.frame(), mode="function")
./dataframe.R: f <- if (unary)
./dataframe.R- quote(FUN(left))
./dataframe.R- else quote(FUN(left, right))
./dataframe.R- lscalar <- rscalar <- FALSE
--
./dates.R- secs = x/86400, mins = x/1440, hours = x/24,
./dates.R- days = x, weeks = 7*x))
./dates.R- }
./dates.R- if(!inherits(e1, "Date"))
./dates.R- stop("Can only subtract from Date objects")
./dates.R: if (nargs() == 1) stop("unary - is not defined for Date objects")
./dates.R- if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
./dates.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./dates.R- if(!is.null(attr(e2, "class")))
--
./dates.R-}
./dates.R-
./dates.R-Ops.Date <- function(e1, e2)
./dates.R-{
./dates.R- if (nargs() == 1)
./dates.R: stop("unary ", .Generic, " not defined for Date objects")
./dates.R- boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./dates.R- "!=" = , "<=" = , ">=" = TRUE, FALSE)
./dates.R- if (!boolean) stop(.Generic, " not defined for Date objects")
--
./datetime.R- secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R- days = 60*60*24*x, weeks = 60*60*24*7*x)
./datetime.R- }
./datetime.R- if(!inherits(e1, "POSIXt"))
./datetime.R- stop("Can only subtract from POSIXt objects")
./datetime.R: if (nargs() == 1) stop("unary - is not defined for \"POSIXt\" objects")
./datetime.R- if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
./datetime.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./datetime.R- if(!is.null(attr(e2, "class")))
--
./datetime.R-}
./datetime.R-
./datetime.R-Ops.POSIXt <- function(e1, e2)
./datetime.R-{
./datetime.R- if (nargs() == 1)
./datetime.R: stop("unary", .Generic, " not defined for \"POSIXt\" objects")
./datetime.R- boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./datetime.R- "!=" = , "<=" = , ">=" = TRUE, FALSE)
./datetime.R- if (!boolean) stop(.Generic, " not defined for \"POSIXt\" objects")
--
./datetime.R- switch(attr(x,"units"),
./datetime.R- secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R- days = 60*60*24*x, weeks = 60*60*24*7*x)
./datetime.R- }
./datetime.R- if (nargs() == 1)
./datetime.R: stop("unary", .Generic, " not defined for \"difftime\" objects")
./datetime.R- boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./datetime.R- "!=" = , "<=" = , ">=" = TRUE, FALSE)
./datetime.R- if (boolean) {
--
./packages.R-}
./packages.R-Ops.package_version <-
./packages.R-function(e1, e2)
./packages.R-{
./packages.R- if(nargs() == 1)
./packages.R: stop("unary ", .Generic, " not defined for package_version objects")
./packages.R- boolean <- switch(.Generic, "<" = , ">" = , "==" = , "!=" = ,
./packages.R- "<=" = , ">=" = TRUE, FALSE)
./packages.R- if(!boolean)
./dates.R- }
./dates.R-
./dates.R- if (nargs() == 1) return(e1)
./dates.R- # only valid if one of e1 and e2 is a scalar.
./dates.R- if(inherits(e1, "Date") && inherits(e2, "Date"))
./dates.R: stop("binary + is not defined for Date objects")
./dates.R- if (inherits(e1, "difftime")) e1 <- coerceTimeUnit(e1)
./dates.R- if (inherits(e2, "difftime")) e2 <- coerceTimeUnit(e2)
./dates.R- structure(unclass(e1) + unclass(e2), class = "Date")
--
./dates.R- secs = x/86400, mins = x/1440, hours = x/24,
./dates.R- days = x, weeks = 7*x))
./dates.R- }
./dates.R- if(!inherits(e1, "Date"))
./dates.R- stop("Can only subtract from Date objects")
./dates.R: if (nargs() == 1) stop("unary - is not defined for Date objects")
./dates.R- if(inherits(e2, "Date")) return(difftime(e1, e2, units="days"))
./dates.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./dates.R- if(!is.null(attr(e2, "class")))
--
./dates.R-}
./dates.R-
./dates.R-Ops.Date <- function(e1, e2)
./dates.R-{
./dates.R- if (nargs() == 1)
./dates.R: stop("unary ", .Generic, " not defined for Date objects")
./dates.R- boolean <- switch(.Generic, "<" = , ">" = , "==" = ,
./dates.R- "!=" = , "<=" = , ">=" = TRUE, FALSE)
./dates.R: if (!boolean) stop(.Generic, " not defined for Date objects")
./dates.R- NextMethod(.Generic)
./dates.R-}
./dates.R-
./dates.R-Math.Date <- function (x, ...)
./dates.R: stop(.Generic, " not defined for Date objects")
./dates.R-
./dates.R-Summary.Date <- function (x, ...)
./dates.R-{
./dates.R- ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
./dates.R: if (!ok) stop(.Generic, " not defined for Date objects")
./dates.R- val <- NextMethod(.Generic)
./dates.R- class(val) <- oldClass(x)
./dates.R- val
./dates.R-mean.Date <- function (x, ...)
./dates.R- structure(mean(unclass(x), ...), class = "Date")
./dates.R-
./dates.R-seq.Date <- function(from, to, by, length.out=NULL, along.with=NULL, ...)
./dates.R-{
./dates.R: if (missing(from)) stop("'from' must be specified")
./dates.R- if (!inherits(from, "Date")) stop("'from' must be a Date object")
./dates.R- if(length(as.Date(from)) != 1) stop("'from' must be of length 1")
./dates.R- if (!missing(to)) {
--
./datetime.R-## ----- convenience functions -----
./datetime.R-
./datetime.R-seq.POSIXt <-
./datetime.R- function(from, to, by, length.out = NULL, along.with = NULL, ...)
./datetime.R-{
./datetime.R: if (missing(from)) stop("'from' must be specified")
./datetime.R- if (!inherits(from, "POSIXt")) stop("'from' must be a POSIXt object")
./datetime.R- if(length(as.POSIXct(from)) != 1) stop("'from' must be of length 1")
./datetime.R- if (!missing(to)) {
./dates.R- structure(mean(unclass(x), ...), class = "Date")
./dates.R-
./dates.R-seq.Date <- function(from, to, by, length.out=NULL, along.with=NULL, ...)
./dates.R-{
./dates.R- if (missing(from)) stop("'from' must be specified")
./dates.R: if (!inherits(from, "Date")) stop("'from' must be a Date object")
./dates.R- if(length(as.Date(from)) != 1) stop("'from' must be of length 1")
./dates.R- if (!missing(to)) {
./dates.R- if (!inherits(to, "Date")) stop("'to' must be a Date object")
./dates.R-
./dates.R-seq.Date <- function(from, to, by, length.out=NULL, along.with=NULL, ...)
./dates.R-{
./dates.R- if (missing(from)) stop("'from' must be specified")
./dates.R- if (!inherits(from, "Date")) stop("'from' must be a Date object")
./dates.R: if(length(as.Date(from)) != 1) stop("'from' must be of length 1")
./dates.R- if (!missing(to)) {
./dates.R- if (!inherits(to, "Date")) stop("'to' must be a Date object")
./dates.R- if (length(as.Date(to)) != 1) stop("'to' must be of length 1")
--
./datetime.R-seq.POSIXt <-
./datetime.R- function(from, to, by, length.out = NULL, along.with = NULL, ...)
./datetime.R-{
./datetime.R- if (missing(from)) stop("'from' must be specified")
./datetime.R- if (!inherits(from, "POSIXt")) stop("'from' must be a POSIXt object")
./datetime.R: if(length(as.POSIXct(from)) != 1) stop("'from' must be of length 1")
./datetime.R- if (!missing(to)) {
./datetime.R- if (!inherits(to, "POSIXt")) stop("'to' must be a POSIXt object")
./datetime.R- if (length(as.POSIXct(to)) != 1) stop("'to' must be of length 1")
./dates.R-{
./dates.R- if (missing(from)) stop("'from' must be specified")
./dates.R- if (!inherits(from, "Date")) stop("'from' must be a Date object")
./dates.R- if(length(as.Date(from)) != 1) stop("'from' must be of length 1")
./dates.R- if (!missing(to)) {
./dates.R: if (!inherits(to, "Date")) stop("'to' must be a Date object")
./dates.R- if (length(as.Date(to)) != 1) stop("'to' must be of length 1")
./dates.R- }
./dates.R- if (!missing(along.with)) {
./dates.R- if (missing(from)) stop("'from' must be specified")
./dates.R- if (!inherits(from, "Date")) stop("'from' must be a Date object")
./dates.R- if(length(as.Date(from)) != 1) stop("'from' must be of length 1")
./dates.R- if (!missing(to)) {
./dates.R- if (!inherits(to, "Date")) stop("'to' must be a Date object")
./dates.R: if (length(as.Date(to)) != 1) stop("'to' must be of length 1")
./dates.R- }
./dates.R- if (!missing(along.with)) {
./dates.R- length.out <- length(along.with)
--
./datetime.R- if (missing(from)) stop("'from' must be specified")
./datetime.R- if (!inherits(from, "POSIXt")) stop("'from' must be a POSIXt object")
./datetime.R- if(length(as.POSIXct(from)) != 1) stop("'from' must be of length 1")
./datetime.R- if (!missing(to)) {
./datetime.R- if (!inherits(to, "POSIXt")) stop("'to' must be a POSIXt object")
./datetime.R: if (length(as.POSIXct(to)) != 1) stop("'to' must be of length 1")
./datetime.R- }
./datetime.R- if (!missing(along.with)) {
./datetime.R- length.out <- length(along.with)
./dates.R- if (length(as.Date(to)) != 1) stop("'to' must be of length 1")
./dates.R- }
./dates.R- if (!missing(along.with)) {
./dates.R- length.out <- length(along.with)
./dates.R- } else if (!missing(length.out)) {
./dates.R: if (length(length.out) != 1) stop("'length.out' must be of length 1")
./dates.R- length.out <- ceiling(length.out)
./dates.R- }
./dates.R- status <- c(!missing(to), !missing(by), !is.null(length.out))
--
./datetime.R- if (length(as.POSIXct(to)) != 1) stop("'to' must be of length 1")
./datetime.R- }
./datetime.R- if (!missing(along.with)) {
./datetime.R- length.out <- length(along.with)
./datetime.R- } else if (!missing(length.out)) {
./datetime.R: if (length(length.out) != 1) stop("'length.out' must be of length 1")
./datetime.R- length.out <- ceiling(length.out)
./datetime.R- }
./datetime.R- status <- c(!missing(to), !missing(by), !is.null(length.out))
./dates.R- if (length(length.out) != 1) stop("'length.out' must be of length 1")
./dates.R- length.out <- ceiling(length.out)
./dates.R- }
./dates.R- status <- c(!missing(to), !missing(by), !is.null(length.out))
./dates.R- if(sum(status) != 2)
./dates.R: stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
./dates.R- if (missing(by)) {
./dates.R- from <- unclass(as.Date(from))
./dates.R- to <- unclass(as.Date(to))
--
./datetime.R- if (length(length.out) != 1) stop("'length.out' must be of length 1")
./datetime.R- length.out <- ceiling(length.out)
./datetime.R- }
./datetime.R- status <- c(!missing(to), !missing(by), !is.null(length.out))
./datetime.R- if(sum(status) != 2)
./datetime.R: stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")
./datetime.R- if (missing(by)) {
./datetime.R- from <- unclass(as.POSIXct(from))
./datetime.R- to <- unclass(as.POSIXct(to))
./dates.R- to <- unclass(as.Date(to))
./dates.R- res <- seq.default(from, to, length.out = length.out)
./dates.R- return(structure(res, class = "Date"))
./dates.R- }
./dates.R-
./dates.R: if (length(by) != 1) stop("'by' must be of length 1")
./dates.R- valid <- 0
./dates.R- if (inherits(by, "difftime")) {
./dates.R- by <- switch(attr(by,"units"), secs = 1/86400, mins = 1/1440,
--
./datetime.R- ##- res <- seq.default(from, to, incr)
./datetime.R- res <- seq.default(from, to, length.out = length.out)
./datetime.R- return(structure(res, class = c("POSIXt", "POSIXct")))
./datetime.R- }
./datetime.R-
./datetime.R: if (length(by) != 1) stop("'by' must be of length 1")
./datetime.R- valid <- 0
./datetime.R- if (inherits(by, "difftime")) {
./datetime.R- by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600,
./dates.R- by <- switch(attr(by,"units"), secs = 1/86400, mins = 1/1440,
./dates.R- hours = 1/24, days = 1, weeks = 7) * unclass(by)
./dates.R- } else if(is.character(by)) {
./dates.R- by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
./dates.R- if(length(by2) > 2 || length(by2) < 1)
./dates.R: stop("invalid 'by' string")
./dates.R- valid <- pmatch(by2[length(by2)],
./dates.R- c("days", "weeks", "months", "years"))
./dates.R- if(is.na(valid)) stop("invalid string for 'by'")
--
./datetime.R- by <- switch(attr(by,"units"), secs = 1, mins = 60, hours = 3600,
./datetime.R- days = 86400, weeks = 7*86400) * unclass(by)
./datetime.R- } else if(is.character(by)) {
./datetime.R- by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
./datetime.R- if(length(by2) > 2 || length(by2) < 1)
./datetime.R: stop("invalid 'by' string")
./datetime.R- valid <- pmatch(by2[length(by2)],
./datetime.R- c("secs", "mins", "hours", "days", "weeks",
./datetime.R- "months", "years", "DSTdays"))
./dates.R- by2 <- strsplit(by, " ", fixed=TRUE)[[1]]
./dates.R- if(length(by2) > 2 || length(by2) < 1)
./dates.R- stop("invalid 'by' string")
./dates.R- valid <- pmatch(by2[length(by2)],
./dates.R- c("days", "weeks", "months", "years"))
./dates.R: if(is.na(valid)) stop("invalid string for 'by'")
./dates.R- if(valid <= 2) {
./dates.R- by <- c(1, 7)[valid]
./dates.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
--
./datetime.R- if(length(by2) > 2 || length(by2) < 1)
./datetime.R- stop("invalid 'by' string")
./datetime.R- valid <- pmatch(by2[length(by2)],
./datetime.R- c("secs", "mins", "hours", "days", "weeks",
./datetime.R- "months", "years", "DSTdays"))
./datetime.R: if(is.na(valid)) stop("invalid string for 'by'")
./datetime.R- if(valid <= 5) {
./datetime.R- by <- c(1, 60, 3600, 86400, 7*86400)[valid]
./datetime.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./dates.R- if(valid <= 2) {
./dates.R- by <- c(1, 7)[valid]
./dates.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./dates.R- } else
./dates.R- by <- if(length(by2) == 2) as.integer(by2[1]) else 1
./dates.R: } else if(!is.numeric(by)) stop("invalid mode for 'by'")
./dates.R- if(is.na(by)) stop("'by' is NA")
./dates.R-
./dates.R- if(valid <= 2) {
--
./datetime.R- if(valid <= 5) {
./datetime.R- by <- c(1, 60, 3600, 86400, 7*86400)[valid]
./datetime.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./datetime.R- } else
./datetime.R- by <- if(length(by2) == 2) as.integer(by2[1]) else 1
./datetime.R: } else if(!is.numeric(by)) stop("invalid mode for 'by'")
./datetime.R- if(is.na(by)) stop("'by' is NA")
./datetime.R-
./datetime.R- if(valid <= 5) {
./dates.R- by <- c(1, 7)[valid]
./dates.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./dates.R- } else
./dates.R- by <- if(length(by2) == 2) as.integer(by2[1]) else 1
./dates.R- } else if(!is.numeric(by)) stop("invalid mode for 'by'")
./dates.R: if(is.na(by)) stop("'by' is NA")
./dates.R-
./dates.R- if(valid <= 2) {
./dates.R- from <- unclass(as.Date(from))
--
./datetime.R- by <- c(1, 60, 3600, 86400, 7*86400)[valid]
./datetime.R- if (length(by2) == 2) by <- by * as.integer(by2[1])
./datetime.R- } else
./datetime.R- by <- if(length(by2) == 2) as.integer(by2[1]) else 1
./datetime.R- } else if(!is.numeric(by)) stop("invalid mode for 'by'")
./datetime.R: if(is.na(by)) stop("'by' is NA")
./datetime.R-
./datetime.R- if(valid <= 5) {
./datetime.R- from <- unclass(as.POSIXct(from))
./dates.R-
./dates.R-cut.Date <-
./dates.R- function (x, breaks, labels = NULL, start.on.monday = TRUE,
./dates.R- right = FALSE, ...)
./dates.R-{
./dates.R: if(!inherits(x, "Date")) stop("'x' must be a date-time object")
./dates.R- x <- as.Date(x)
./dates.R-
./dates.R- if (inherits(breaks, "Date")) {
--
./datetime.R-
./datetime.R-cut.POSIXt <-
./datetime.R- function (x, breaks, labels = NULL, start.on.monday = TRUE,
./datetime.R- right = FALSE, ...)
./datetime.R-{
./datetime.R: if(!inherits(x, "POSIXt")) stop("'x' must be a date-time object")
./datetime.R- x <- as.POSIXct(x)
./datetime.R-
./datetime.R- if (inherits(breaks, "POSIXt")) {
./dates.R- } else if(is.numeric(breaks) && length(breaks) == 1) {
./dates.R- ## specified number of breaks
./dates.R- } else if(is.character(breaks) && length(breaks) == 1) {
./dates.R- by2 <- strsplit(breaks, " ", fixed=TRUE)[[1]]
./dates.R- if(length(by2) > 2 || length(by2) < 1)
./dates.R: stop("invalid specification of 'breaks'")
./dates.R- valid <-
./dates.R- pmatch(by2[length(by2)], c("days", "weeks", "months", "years"))
./dates.R: if(is.na(valid)) stop("invalid specification of 'breaks'")
./dates.R- start <- as.POSIXlt(min(x, na.rm=TRUE))
./dates.R- if(valid == 1) incr <- 1
./dates.R- if(valid == 2) {
--
./dates.R- start <- .Internal(POSIXlt2Date(start))
./dates.R- if (length(by2) == 2) incr <- incr * as.integer(by2[1])
./dates.R- maxx <- max(x, na.rm = TRUE)
./dates.R- breaks <- seq(start, maxx + incr, breaks)
./dates.R- breaks <- breaks[1:(1+max(which(breaks < maxx)))]
./dates.R: } else stop("invalid specification of 'breaks'")
./dates.R- res <- cut(unclass(x), unclass(breaks), labels = labels,
./dates.R- right = right, ...)
./dates.R- if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
--
./datetime.R- } else if(is.numeric(breaks) && length(breaks) == 1) {
./datetime.R- ## specified number of breaks
./datetime.R- } else if(is.character(breaks) && length(breaks) == 1) {
./datetime.R- by2 <- strsplit(breaks, " ", fixed=TRUE)[[1]]
./datetime.R- if(length(by2) > 2 || length(by2) < 1)
./datetime.R: stop("invalid specification of 'breaks'")
./datetime.R- valid <-
./datetime.R- pmatch(by2[length(by2)],
./datetime.R- c("secs", "mins", "hours", "days", "weeks",
./datetime.R- "months", "years", "DSTdays"))
./datetime.R: if(is.na(valid)) stop("invalid specification of 'breaks'")
./datetime.R- start <- as.POSIXlt(min(x, na.rm=TRUE))
./datetime.R- incr <- 1
./datetime.R- if(valid > 1) { start$sec <- 0; incr <- 59.99 }
--
./datetime.R- if(valid == 8) incr <- 25*3600
./datetime.R- if (length(by2) == 2) incr <- incr * as.integer(by2[1])
./datetime.R- maxx <- max(x, na.rm = TRUE)
./datetime.R- breaks <- seq(start, maxx + incr, breaks)
./datetime.R- breaks <- breaks[1:(1+max(which(breaks < maxx)))]
./datetime.R: } else stop("invalid specification of 'breaks'")
./datetime.R- res <- cut(unclass(x), unclass(breaks), labels = labels,
./datetime.R- right = right, ...)
./datetime.R- if(is.null(labels)) levels(res) <- as.character(breaks[-length(breaks)])
./dates.R- res
./dates.R-}
./dates.R-
./dates.R-julian.Date <- function(x, origin = as.Date("1970-01-01"), ...)
./dates.R-{
./dates.R: if(length(origin) != 1) stop("'origin' must be of length one")
./dates.R- structure(unclass(x) - unclass(origin), "origin" = origin)
./dates.R-}
./dates.R-
--
./datetime.R-
./datetime.R-julian <- function(x, ...) UseMethod("julian")
./datetime.R-
./datetime.R-julian.POSIXt <- function(x, origin = as.POSIXct("1970-01-01", tz="GMT"), ...)
./datetime.R-{
./datetime.R: if(length(origin) != 1) stop("'origin' must be of length one")
./datetime.R- res <- difftime(as.POSIXct(x), origin, units = "days")
./datetime.R- structure(res, "origin" = origin)
./datetime.R-}
./dates.R-diff.Date <- function (x, lag = 1, differences = 1, ...)
./dates.R-{
./dates.R- ismat <- is.matrix(x)
./dates.R- xlen <- if (ismat) dim(x)[1] else length(x)
./dates.R- if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
./dates.R: stop("'lag' and 'differences' must be integers >= 1")
./dates.R- if (lag * differences >= xlen)
./dates.R- return(structure(numeric(0), class="difftime", units="days"))
./dates.R- r <- x
--
./datetime.R-diff.POSIXt <- function (x, lag = 1, differences = 1, ...)
./datetime.R-{
./datetime.R- ismat <- is.matrix(x)
./datetime.R- xlen <- if (ismat) dim(x)[1] else length(x)
./datetime.R- if (length(lag) > 1 || length(differences) > 1 || lag < 1 || differences < 1)
./datetime.R: stop("'lag' and 'differences' must be integers >= 1")
./datetime.R- if (lag * differences >= xlen)
./datetime.R- return(structure(numeric(0), class="difftime", units="secs"))
./datetime.R- r <- x
--
./diff.R-{
./diff.R- ismat <- is.matrix(x)
./diff.R- xlen <- if(ismat) dim(x)[1] else length(x)
./diff.R- if (length(lag) > 1 || length(differences) > 1 ||
./diff.R- lag < 1 || differences < 1)
./diff.R: stop("'lag' and 'differences' must be integers >= 1")
./diff.R- if (lag * differences >= xlen)
./diff.R- return(x[0]) # empty of proper mode
./diff.R- r <- unclass(x) # don't want class-specific subset methods
./datetime.R- deparse(substitute(x))))
./datetime.R-}
./datetime.R-
./datetime.R-format.POSIXlt <- function(x, format = "", usetz = FALSE, ...)
./datetime.R-{
./datetime.R: if(!inherits(x, "POSIXlt")) stop("wrong class")
./datetime.R- if(format == "") {
./datetime.R- ## need list [ method here.
./datetime.R- times <- unlist(unclass(x)[1:3])
--
./datetime.R- .Internal(strptime(as.character(x), format))
./datetime.R-
./datetime.R-
./datetime.R-format.POSIXct <- function(x, format = "", tz = "", usetz = FALSE, ...)
./datetime.R-{
./datetime.R: if(!inherits(x, "POSIXct")) stop("wrong class")
./datetime.R- if(missing(tz) && !is.null(tzone <- attr(x, "tzone"))) tz <- tzone
./datetime.R- structure(format.POSIXlt(as.POSIXlt(x, tz), format, usetz, ...),
./datetime.R- names=names(x))
--
./library.R- out
./library.R-}
./library.R-
./library.R-print.packageInfo <- function(x, ...)
./library.R-{
./library.R: if(!inherits(x, "packageInfo")) stop("wrong class")
./library.R- outFile <- tempfile("RpackageInfo")
./library.R- outConn <- file(outFile, open = "w")
./library.R- vignetteMsg <-
--
./packages.R- if(is.package_version(x)) x else package_version(x)
./packages.R-
./packages.R-.encode_package_version <-
./packages.R-function(x, base = NULL)
./packages.R-{
./packages.R: if(!is.package_version(x)) stop("wrong class")
./packages.R- if(is.null(base)) base <- max(unlist(x), 0) + 1
./packages.R- lens <- as.numeric(sapply(x, length))
./packages.R- ## We store the lengths so that we know when to stop when decoding.
./datetime.R- switch(attr(x,"units"),
./datetime.R- secs = x, mins = 60*x, hours = 60*60*x,
./datetime.R- days = 60*60*24*x, weeks = 60*60*24*7*x)
./datetime.R- }
./datetime.R- if(!inherits(e1, "POSIXt"))
./datetime.R: stop("Can only subtract from POSIXt objects")
./datetime.R- if (nargs() == 1) stop("unary - is not defined for \"POSIXt\" objects")
./datetime.R- if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
./datetime.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./datetime.R- stop("Can only subtract from POSIXt objects")
./datetime.R- if (nargs() == 1) stop("unary - is not defined for \"POSIXt\" objects")
./datetime.R- if(inherits(e2, "POSIXt")) return(difftime(e1, e2))
./datetime.R- if (inherits(e2, "difftime")) e2 <- unclass(coerceTimeUnit(e2))
./datetime.R- if(!is.null(attr(e2, "class")))
./datetime.R: stop("can only subtract numbers from POSIXt objects")
./datetime.R- structure(unclass(as.POSIXct(e1)) - e2, class = c("POSIXt", "POSIXct"))
./datetime.R-}
./datetime.R-
./datetime.R- NextMethod(.Generic)
./datetime.R-}
./datetime.R-
./datetime.R-Math.POSIXt <- function (x, ...)
./datetime.R-{
./datetime.R: stop(.Generic, " not defined for POSIXt objects")
./datetime.R-}
./datetime.R-
./datetime.R-Summary.POSIXct <- function (x, ...)
./datetime.R-
./datetime.R-seq.POSIXt <-
./datetime.R- function(from, to, by, length.out = NULL, along.with = NULL, ...)
./datetime.R-{
./datetime.R- if (missing(from)) stop("'from' must be specified")
./datetime.R: if (!inherits(from, "POSIXt")) stop("'from' must be a POSIXt object")
./datetime.R- if(length(as.POSIXct(from)) != 1) stop("'from' must be of length 1")
./datetime.R- if (!missing(to)) {
./datetime.R- if (!inherits(to, "POSIXt")) stop("'to' must be a POSIXt object")
./datetime.R-{
./datetime.R- if (missing(from)) stop("'from' must be specified")
./datetime.R- if (!inherits(from, "POSIXt")) stop("'from' must be a POSIXt object")
./datetime.R- if(length(as.POSIXct(from)) != 1) stop("'from' must be of length 1")
./datetime.R- if (!missing(to)) {
./datetime.R: if (!inherits(to, "POSIXt")) stop("'to' must be a POSIXt object")
./datetime.R- if (length(as.POSIXct(to)) != 1) stop("'to' must be of length 1")
./datetime.R- }
./datetime.R- if (!missing(along.with)) {
./dcf.R- if(is.character(file)){
./dcf.R- file <- file(file, "r")
./dcf.R- on.exit(close(file))
./dcf.R- }
./dcf.R- if(!inherits(file, "connection"))
./dcf.R: stop("'file' must be a character string or connection")
./dcf.R- .Internal(readDCF(file, fields))
./dcf.R-}
./dcf.R-
--
./dcf.R- else if(is.character(file)) {
./dcf.R- file <- file(file, ifelse(append, "a", "w"))
./dcf.R- on.exit(close(file))
./dcf.R- }
./dcf.R- if(!inherits(file, "connection"))
./dcf.R: stop("'file' must be a character string or connection")
./dcf.R-
./dcf.R- nr <- nrow(x)
./dcf.R- nc <- ncol(x)
--
./readtable.R- if(is.character(file)) {
./readtable.R- file <- file(file)
./readtable.R- on.exit(close(file))
./readtable.R- }
./readtable.R- if(!inherits(file, "connection"))
./readtable.R: stop("'file' must be a character string or connection")
./readtable.R- .Internal(count.fields(file, sep, quote, skip, blank.lines.skip,
./readtable.R- comment.char))
./readtable.R-}
--
./readtable.R- if(is.character(file)) {
./readtable.R- file <- file(file, "r")
./readtable.R- on.exit(close(file))
./readtable.R- }
./readtable.R- if(!inherits(file, "connection"))
./readtable.R: stop("'file' must be a character string or connection")
./readtable.R- if(!isOpen(file)) {
./readtable.R- open(file, "r")
./readtable.R- on.exit(close(file))
--
./scan.R- else {
./scan.R- file <- file(file, "r")
./scan.R- on.exit(close(file))
./scan.R- }
./scan.R- if(!inherits(file, "connection"))
./scan.R: stop("'file' must be a character string or connection")
./scan.R- .Internal(scan(file, what, nmax, sep, dec, quote, skip, nlines,
./scan.R- na.strings, flush, fill, strip.white, quiet,
./scan.R- blank.lines.skip, multi.line, comment.char,
--
./write.table.R- else if(is.character(file)) {
./write.table.R- file <- file(file, ifelse(append, "a", "w"))
./write.table.R- on.exit(close(file))
./write.table.R- }
./write.table.R- if(!inherits(file, "connection"))
./write.table.R: stop("'file' must be a character string or connection")
./write.table.R-
./write.table.R- qstring <- # quoted embedded quote string
./write.table.R- switch(qmethod,
--
./write.table.R- else if(is.character(file)) {
./write.table.R- file <- file(file, ifelse(append, "a", "w"))
./write.table.R- on.exit(close(file))
./write.table.R- }
./write.table.R- if(!inherits(file, "connection"))
./write.table.R: stop("'file' must be a character string or connection")
./write.table.R-
./write.table.R- qstring <- # quoted embedded quote string
./write.table.R- switch(qmethod,
./det.R-determinant = function(x, logarithm = TRUE, ...) UseMethod("determinant")
./det.R-
./det.R-determinant.matrix = function(x, logarithm = TRUE, ...)
./det.R-{
./det.R- if ((n <- ncol(x)) != nrow(x))
./det.R: stop("'x' must be a square matrix")
./det.R- if (n < 1)
./det.R- return(list(modulus = double(0), sign = as.integer(1),
./det.R- logarithm = logarithm))
./det.R- stop("'x' must be a square matrix")
./det.R- if (n < 1)
./det.R- return(list(modulus = double(0), sign = as.integer(1),
./det.R- logarithm = logarithm))
./det.R- if (is.complex(x))
./det.R: stop("determinant not currently defined for complex matrices")
./det.R- storage.mode(x) = "double"
./det.R- .Call("det_ge_real", x, logarithm, PACKAGE = "base")
./det.R-}
./diag.R- all((nm <- nms[[1]][1:m]) == nms[[2]][1:m]))
./diag.R- names(y) <- nm
./diag.R- return(y)
./diag.R- }
./diag.R- if(is.array(x) && length(dim(x)) != 1)
./diag.R: stop("first argument is array, but not matrix.")
./diag.R-
./diag.R- if(missing(x))
./diag.R- n <- nrow
./diag.R-
./diag.R-"diag<-" <- function(x, value)
./diag.R-{
./diag.R- dx <- dim(x)
./diag.R- if(length(dx) != 2 || prod(dx) != length(x))
./diag.R: stop("only matrix diagonals can be replaced")
./diag.R- i <- seq(length=min(dx))
./diag.R- if(length(value) != 1 && length(value) != length(i))
./diag.R- stop("replacement diagonal has wrong length")
./diag.R- dx <- dim(x)
./diag.R- if(length(dx) != 2 || prod(dx) != length(x))
./diag.R- stop("only matrix diagonals can be replaced")
./diag.R- i <- seq(length=min(dx))
./diag.R- if(length(value) != 1 && length(value) != length(i))
./diag.R: stop("replacement diagonal has wrong length")
./diag.R- if(length(i) > 0) x[cbind(i, i)] <- value
./diag.R- x
./diag.R-}
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- duplicated(do.call("paste", c(x, sep="\r")))
./duplicated.R-}
./duplicated.R-
./duplicated.R-duplicated.matrix <- duplicated.array <-
./duplicated.R: function(x, incomparables = FALSE , MARGIN = 1, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- ndim <- length(dim(x))
./duplicated.R- if (length(MARGIN) > ndim || any(MARGIN > ndim))
./duplicated.R: stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
./duplicated.R- temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
./duplicated.R- res <- duplicated(as.vector(temp))
./duplicated.R- dim(res) <- dim(temp)
--
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- x[!duplicated(x), , drop = FALSE]
./duplicated.R-}
./duplicated.R-
./duplicated.R-unique.matrix <- unique.array <-
./duplicated.R: function(x, incomparables = FALSE , MARGIN = 1, ...)
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- ndim <- length(dim(x))
./duplicated.R- if (length(MARGIN) > 1 || any(MARGIN > ndim))
./duplicated.R: stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
./duplicated.R- temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
./duplicated.R- args <- rep(alist(a=), ndim)
./duplicated.R- names(args) <- NULL
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- ndim <- length(dim(x))
./duplicated.R- if (length(MARGIN) > ndim || any(MARGIN > ndim))
./duplicated.R: stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
./duplicated.R- temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
./duplicated.R- res <- duplicated(as.vector(temp))
./duplicated.R- dim(res) <- dim(temp)
--
./duplicated.R-{
./duplicated.R- if(!is.logical(incomparables) || incomparables)
./duplicated.R- .NotYetUsed("incomparables != FALSE")
./duplicated.R- ndim <- length(dim(x))
./duplicated.R- if (length(MARGIN) > 1 || any(MARGIN > ndim))
./duplicated.R: stop("MARGIN = ", MARGIN, " is invalid for dim = ", dim(x))
./duplicated.R- temp <- apply(x, MARGIN, function(x) paste(x, collapse = "\r"))
./duplicated.R- args <- rep(alist(a=), ndim)
./duplicated.R- names(args) <- NULL
./dynload.R- pkgName <- PACKAGE$path
./dynload.R- PACKAGE <- PACKAGE$info
./dynload.R- } else if(inherits(PACKAGE, "DLLInfoReference")) {
./dynload.R- pkgName <- character()
./dynload.R- } else
./dynload.R: stop("must pass a package name, DLLInfo or DllInfoReference object")
./dynload.R-
./dynload.R- v <- .Call("R_getSymbolInfo", as.character(name), PACKAGE,
./dynload.R- PACKAGE = "base")
./dynload.R-{
./dynload.R- dlls <- getLoadedDLLs()
./dynload.R- w <- sapply(dlls, function(x) x$name == dll || x$path == dll)
./dynload.R-
./dynload.R- if(!any(w))
./dynload.R: stop("No DLL currently loaded with name or path ", dll)
./dynload.R-
./dynload.R- dll <- which(w)[1]
./dynload.R- if(sum(w) > 1)
./dynload.R- if(!any(w))
./dynload.R- stop("No DLL currently loaded with name or path ", dll)
./dynload.R-
./dynload.R- dll <- which(w)[1]
./dynload.R- if(sum(w) > 1)
./dynload.R: warning(gettextf("multiple DLLs match '%s'. Using '%s'",
./dynload.R- dll, dll$path), domain = NA)
./dynload.R-
./dynload.R- getDLLRegisteredRoutines(dlls[[dll]])
./dynload.R-
./dynload.R-getDLLRegisteredRoutines.DLLInfo <- function(dll)
./dynload.R-{
./dynload.R- ## Provide methods for the different types.
./dynload.R- if(!inherits(dll, "DLLInfo"))
./dynload.R: stop("must specify DLL via a DLLInfo object. See getLoadedDLLs()")
./dynload.R-
./dynload.R- info <- dll$info
./dynload.R- els <- .Call("R_getRegisteredRoutines", info, PACKAGE = "base")
./dynload.R-{
./dynload.R- e <- environment(f)
./dynload.R-
./dynload.R- if(!isNamespace(e)) {
./dynload.R- if(doStop)
./dynload.R: stop("function is not in a namespace, so cannot locate associated DLL")
./dynload.R- else
./dynload.R- return(NULL)
./dynload.R- }
./dynload.R- # Please feel free to replace with a more encapsulated way to do this.
./dynload.R- if(exists("DLLs", envir = e$".__NAMESPACE__.") && length(e$".__NAMESPACE__."$DLLs))
./dynload.R- return(e$".__NAMESPACE__."$DLLs[[1]])
./dynload.R- else {
./dynload.R- if(doStop)
./dynload.R: stop("looking for DLL for native routine call, but no DLLs in namespace of call")
./dynload.R- else
./dynload.R- NULL
./dynload.R- }
./eigen.R-eigen <- function(x, symmetric, only.values = FALSE, EISPACK = FALSE)
./eigen.R-{
./eigen.R- x <- as.matrix(x)
./eigen.R- dimnames(x) <- list(NULL, NULL) # or they appear on eigenvectors
./eigen.R- n <- nrow(x)
./eigen.R: if (!n) stop("0 x 0 matrix")
./eigen.R- if (n != ncol(x)) stop("non-square matrix in 'eigen'")
./eigen.R-
./eigen.R- complex.x <- is.complex(x)
./eigen.R-{
./eigen.R- x <- as.matrix(x)
./eigen.R- dimnames(x) <- list(NULL, NULL) # or they appear on eigenvectors
./eigen.R- n <- nrow(x)
./eigen.R- if (!n) stop("0 x 0 matrix")
./eigen.R: if (n != ncol(x)) stop("non-square matrix in 'eigen'")
./eigen.R-
./eigen.R- complex.x <- is.complex(x)
./eigen.R-
./eigen.R- if(missing(symmetric)) {
./eigen.R- test <- all.equal.numeric(x, t(x), 100*.Machine$double.eps)
./eigen.R- symmetric <- is.logical(test) && test
./eigen.R- }
./eigen.R- }
./eigen.R: else stop("numeric or complex values required in 'eigen'")
./eigen.R- if (!EISPACK) {
./eigen.R- if (symmetric) {
./eigen.R- z <- if(!complex.x)
./eigen.R- dbl.n,
./eigen.R- double(2*n),
./eigen.R- ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'ch' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- if(!only.values)
./eigen.R- z$vectors <- matrix(complex(re=z$vectors,
./eigen.R- dbl.n,
./eigen.R- dbl.n,
./eigen.R- ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'rs' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- }
./eigen.R- ord <- sort.list(z$values, decreasing = TRUE)
./eigen.R- dbl.n,
./eigen.R- dbl.n,
./eigen.R- ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'cg' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- z$values <- complex(re=z$values,im=z$ivalues)
./eigen.R- if(!only.values)
./eigen.R- integer(n),
./eigen.R- dbl.n,
./eigen.R- ierr = integer(1),
./eigen.R- PACKAGE="base")
./eigen.R- if (z$ierr)
./eigen.R: stop(gettextf("'rg' returned code %d in 'eigen'", z$ierr),
./eigen.R- domain = NA)
./eigen.R- ind <- z$ivalues > 0
./eigen.R- if(any(ind)) {#- have complex (conjugated) values
./factor.R- if (nl == length(levels))
./factor.R- as.character(labels)
./factor.R- else if(nl == 1)
./factor.R- paste(labels, seq(along = levels), sep = "")
./factor.R- else
./factor.R: stop(gettextf("invalid labels; length %d should be 1 or %d",
./factor.R- nl, length(levels)), domain = NA)
./factor.R- class(f) <- c(if(ordered)"ordered", "factor")
./factor.R- f
./factor.R- value <- unlist(value)
./factor.R- m <- match(value, xlevs, nomatch=0)
./factor.R- xlevs[m] <- nlevs[m > 0]
./factor.R- } else {
./factor.R- if (length(xlevs) > length(value))
./factor.R: stop("number of levels differs")
./factor.R- nlevs <- xlevs <- as.character(value)
./factor.R- }
./factor.R- factor(xlevs[x], levels = unique(nlevs))
./factor.R- invisible(x)
./factor.R-}
./factor.R-
./factor.R-
./factor.R-Math.factor <- function(x, ...) {
./factor.R: stop(.Generic, " not meaningful for factors")
./factor.R-}
./factor.R-Summary.factor <- function(x, ...) {
./factor.R: stop(.Generic, " not meaningful for factors")
./factor.R-}
./factor.R-Ops.factor <- function(e1, e2)
./factor.R-{
./factor.R- ok <- switch(.Generic, "=="=, "!="=TRUE, FALSE)
./factor.R- if(!ok) {
./factor.R: warning(.Generic, " not meaningful for factors")
./factor.R- return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
./factor.R- }
./factor.R- nas <- is.na(e1) | is.na(e2)
./factor.R- l2 <- levels(e2)
./factor.R- e2 <- l2[e2]
./factor.R- }
./factor.R- if (all(nchar(.Method)) && (length(l1) != length(l2) ||
./factor.R- !all(sort(l2) == sort(l1))))
./factor.R: stop("level sets of factors are different")
./factor.R- value <- NextMethod(.Generic)
./factor.R- value[nas] <- NA
./factor.R- value
--
./factor.R- if (nchar(.Method[2])) {
./factor.R- l2 <- levels(e2)
./factor.R- ord2 <- TRUE
./factor.R- }
./factor.R- if (all(nchar(.Method)) && (length(l1) != length(l2) || !all(l2 == l1)))
./factor.R: stop("level sets of factors are different")
./factor.R- if (ord1 && ord2) {
./factor.R- e1 <- as.integer(e1) # was codes, but same thing for ordered factor.
./factor.R- e2 <- as.integer(e2)
./factor.R-# nas <- is.na(x) # unused
./factor.R- if (is.factor(value))
./factor.R- value <- levels(value)[value]
./factor.R- m <- match(value, lx)
./factor.R- if (any(is.na(m) & !is.na(value)))
./factor.R: warning("invalid factor level, NAs generated")
./factor.R- class(x) <- NULL
./factor.R- if (missing(i))
./factor.R- x[] <- m
./factor.R-{
./factor.R- ok <- switch(.Generic,
./factor.R- "<" = , ">" = , "<=" = , ">=" = ,"=="=, "!=" =TRUE,
./factor.R- FALSE)
./factor.R- if(!ok) {
./factor.R: warning(sprintf("'%s' is not meaningful for ordered factors",
./factor.R- .Generic))
./factor.R- return(rep.int(NA, max(length(e1), if(!missing(e2))length(e2))))
./factor.R- }
./files.R-file.choose <- function(new=FALSE)
./files.R-.Internal(file.choose(new))
./files.R-
./files.R-file.copy <- function(from, to, overwrite=FALSE)
./files.R-{
./files.R: if (!(nf <- length(from))) stop("no files to copy from")
./files.R- if (!(nt <- length(to))) stop("no files to copy to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R- to <- file.path(to, basename(from))
./files.R-.Internal(file.choose(new))
./files.R-
./files.R-file.copy <- function(from, to, overwrite=FALSE)
./files.R-{
./files.R- if (!(nf <- length(from))) stop("no files to copy from")
./files.R: if (!(nt <- length(to))) stop("no files to copy to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R- to <- file.path(to, basename(from))
./files.R- else if (nf > nt) stop("more 'from' files than 'to' files")
./files.R-{
./files.R- if (!(nf <- length(from))) stop("no files to copy from")
./files.R- if (!(nt <- length(to))) stop("no files to copy to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R- to <- file.path(to, basename(from))
./files.R: else if (nf > nt) stop("more 'from' files than 'to' files")
./files.R- if(nt > nf) from <- rep(from, length.out = nt)
./files.R- if (!overwrite) okay <- !file.exists(to)
./files.R- else okay <- rep.int(TRUE, length(to))
./files.R- else if (nf > nt) stop("more 'from' files than 'to' files")
./files.R- if(nt > nf) from <- rep(from, length.out = nt)
./files.R- if (!overwrite) okay <- !file.exists(to)
./files.R- else okay <- rep.int(TRUE, length(to))
./files.R- if (any(from[okay] %in% to[okay]))
./files.R: stop("file can not be copied both 'from' and 'to'")
./files.R- if (any(okay)) { ## care: create could fail but append work.
./files.R- okay[okay] <- file.create(to[okay])
./files.R- if(any(okay)) okay[okay] <- file.append(to[okay], from[okay])
./files.R- }
./files.R- okay
./files.R-}
./files.R-
./files.R-file.symlink <- function(from, to) {
./files.R: if (!(length(from))) stop("no files to link from")
./files.R- if (!(nt <- length(to))) stop("no files/directory to link to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R- to <- file.path(to, basename(from))
./files.R- okay
./files.R-}
./files.R-
./files.R-file.symlink <- function(from, to) {
./files.R- if (!(length(from))) stop("no files to link from")
./files.R: if (!(nt <- length(to))) stop("no files/directory to link to")
./files.R- if (nt == 1 && file.exists(to) && file.info(to)$isdir)
./files.R- to <- file.path(to, basename(from))
./files.R- .Internal(file.symlink(from, to))
./files.R-dir.create <- function(path, showWarnings = TRUE, recursive = FALSE)
./files.R- invisible(.Internal(dir.create(path, showWarnings, recursive)))
./files.R-
./files.R-format.octmode <- function(x, ...)
./files.R-{
./files.R: if(!inherits(x, "octmode")) stop("calling wrong method")
./files.R- isna <- is.na(x)
./files.R- y <- x[!isna]
./files.R- class(y) <- NULL
./files.R-function(..., package = "base", lib.loc = NULL)
./files.R-{
./files.R- if(nargs() == 0)
./files.R- return(file.path(.Library, "base"))
./files.R- if(length(package) != 1)
./files.R: stop("'package' must be of length 1")
./files.R- packagePath <- .find.package(package, lib.loc, quiet = TRUE)
./files.R- if(length(packagePath) == 0)
./files.R- return("")
--
./library.R- }
./library.R-
./library.R- ## NB from this point on `package' is either the original name or
./library.R- ## something like ash_1.0-8
./library.R- if(length(package) != 1)
./library.R: stop("'package' must be of length 1")
./library.R- pkgname <- paste("package", package, sep = ":")
./library.R- newpackage <- is.na(match(pkgname, search()))
./library.R- if(newpackage) {
./findInt.R- ## Purpose: gives back the indices of x in vec; vec[] sorted
./findInt.R- ## -------------------------------------------------------------------------
./findInt.R- ## Author: Martin Maechler, Date: 4 Jan 2002, 10:16
./findInt.R-
./findInt.R- if(any(is.na(vec)))
./findInt.R: stop("'vec' contains NAs")
./findInt.R- if(is.unsorted(vec))
./findInt.R- stop("'vec' must be sorted non-decreasingly")
./findInt.R- ## deal with NA's in x:
./findInt.R- ## Author: Martin Maechler, Date: 4 Jan 2002, 10:16
./findInt.R-
./findInt.R- if(any(is.na(vec)))
./findInt.R- stop("'vec' contains NAs")
./findInt.R- if(is.unsorted(vec))
./findInt.R: stop("'vec' must be sorted non-decreasingly")
./findInt.R- ## deal with NA's in x:
./findInt.R- if(has.na <- any(ix <- is.na(x)))
./findInt.R- x <- x[!ix]
./format.R-format.char <- function(x, width = NULL, flag = "-")
./format.R-{
./format.R- ## Character formatting, flag: if "-" LEFT-justify
./format.R- if (is.null(x)) return("")
./format.R- if(!is.character(x)) {
./format.R: warning("format.char: coercing 'x' to 'character'")
./format.R- x <- as.character(x)
./format.R- }
./format.R- if(is.null(width) && flag == "-")
./format.R- storage.mode(x) <- mode
./format.R- }
./format.R- else stop("'mode\' must be \"double\" (\"real\") or \"integer\"")
./format.R- if (mode == "character" || (!is.null(format) && format == "s")) {
./format.R- if (mode != "character") {
./format.R: warning('coercing argument to "character" for format="s"')
./format.R- x <- as.character(x)
./format.R- }
./format.R- return(format.char(x, width=width, flag=flag))
./format.R- )
./format.R- ## sanity check for flags added 2.1.0
./format.R- flag <- as.character(flag)
./format.R- nf <- strsplit(flag, "")[[1]]
./format.R- if(!all(nf %in% c("0", "+", "-", " ", "#")))
./format.R: stop("'flag' can contain only '0+- #'")
./format.R- r <- .C("str_signif",
./format.R- x = x,
./format.R- n = n,
./frametools.R- if(missing(subset))
./frametools.R- r <- TRUE
./frametools.R- else {
./frametools.R- e <- substitute(subset)
./frametools.R- r <- eval(e, x, parent.frame())
./frametools.R: if(!is.logical(r)) stop("'subset' must evaluate to logical")
./frametools.R- r <- r & !is.na(r)
./frametools.R- }
./frametools.R- if(missing(select))
./frametools.R-}
./frametools.R-
./frametools.R-subset <- function(x, ...) UseMethod("subset")
./frametools.R-
./frametools.R-subset.default <- function(x, subset, ...) {
./frametools.R: if(!is.logical(subset)) stop("'subset' must be logical")
./frametools.R- x[subset & !is.na(subset)]
./frametools.R-}
./frametools.R-
--
./frametools.R- nl <- as.list(1:ncol(x))
./frametools.R- names(nl) <- colnames(x)
./frametools.R- vars <- eval(substitute(select), nl, parent.frame())
./frametools.R- }
./frametools.R- if(missing(subset)) subset <- TRUE
./frametools.R: else if(!is.logical(subset)) stop("'subset' must be logical")
./frametools.R- x[subset & !is.na(subset), vars, drop = drop]
./frametools.R-}
./frametools.R-
./frametools.R-
./frametools.R-unstack.data.frame <- function(x, form = formula(x), ...)
./frametools.R-{
./frametools.R- form <- as.formula(form)
./frametools.R- if (length(form) < 3)
./frametools.R: stop("'form' must be a two-sided formula")
./frametools.R- res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
./frametools.R- if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
./frametools.R- return(res)
--
./frametools.R-unstack.default <- function(x, form, ...)
./frametools.R-{
./frametools.R- x <- as.list(x)
./frametools.R- form <- as.formula(form)
./frametools.R- if (length(form) < 3)
./frametools.R: stop("'form' must be a two-sided formula")
./frametools.R- res <- c(tapply(eval(form[[2]], x), eval(form[[3]], x), as.vector))
./frametools.R- if (length(res) < 2 || any(diff(unlist(lapply(res, length))) != 0))
./frametools.R- return(res)
./array.R- if(is.null(d))
./array.R- d <- length(x)
./array.R- n <- length(d)
./array.R-
./array.R- if((length(MARGIN) > 1) || (MARGIN < 1) || (MARGIN > n))
./array.R: stop("incorrect value for 'MARGIN'")
./array.R-
./array.R- if(any(d == 0)) return(array(integer(0), d))
./array.R-
--
./get.R- inherits = TRUE)
./get.R- .Internal(get(x, envir, mode, inherits))
./get.R-
./get.R-mget <- function(x, envir, mode = "any",
./get.R- ifnotfound= list(function(x)
./get.R: stop(paste("value for '", x, "' not found", sep=""),
./get.R- call.=FALSE)),
./get.R- inherits = FALSE)
./get.R- .Internal(mget(x, envir, mode, ifnotfound, inherits))
--
./strwrap.R- if(is.list(x)) {
./strwrap.R- if((length(x) == 2) && (diff(sapply(x, length)) == 0)) {
./strwrap.R- y <- x[[2]]; x <- x[[1]]
./strwrap.R- }
./strwrap.R- else
./strwrap.R: stop("incorrect value for 'x'")
./strwrap.R- }
./strwrap.R- else if(is.matrix(x)) {
./strwrap.R- if(NCOL(x) == 2) {
./strwrap.R- y <- x[, 2]; x <- x[, 1]
./strwrap.R- }
./strwrap.R- else
./strwrap.R: stop("incorrect value for 'x'")
./strwrap.R- }
./strwrap.R- else if(length(x) != length(y))
./strwrap.R- stop("'x' and 'y' must have the same length")
./attach.R- "*** Note that 'pos=1' will give an error in the future")
./attach.R- pos <- 2
./attach.R- }
./attach.R- if (is.character(what) && (length(what)==1)){
./attach.R- if (!file.exists(what))
./attach.R: stop(gettextf("file '%s' not found", what), domain = NA)
./attach.R- name <- paste("file:", what, sep="")
./attach.R- value <- .Internal(attach(NULL, pos, name))
./attach.R- load(what, envir=as.environment(pos))
--
./get.R- inherits = TRUE)
./get.R- .Internal(get(x, envir, mode, inherits))
./get.R-
./get.R-mget <- function(x, envir, mode = "any",
./get.R- ifnotfound= list(function(x)
./get.R: stop(paste("value for '", x, "' not found", sep=""),
./get.R- call.=FALSE)),
./get.R- inherits = FALSE)
./get.R- .Internal(mget(x, envir, mode, ifnotfound, inherits))
--
./library.R- ## The check for inconsistent naming is now in .find.package
./library.R-
./library.R- if(is.character(pos)) {
./library.R- npos <- match(pos, search())
./library.R- if(is.na(npos)) {
./library.R: warning(gettextf("'%s' not found on search path, using pos = 2", pos), domain = NA)
./library.R- pos <- 2
./library.R- } else pos <- npos
./library.R- }
--
./library.R- file <- file.path(pkg, "libs",
./library.R- paste(chname, file.ext, sep = ""))
./library.R- if(file.exists(file)) break else file <- ""
./library.R- }
./library.R- if(file == "")
./library.R: stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R- ind <- sapply(dll_list, function(x) x$path == file)
./library.R- if(any(ind)) {
./library.R- if(verbose)
--
./library.R- if(!length(pos))
./library.R- stop(gettextf("shared library '%s' was not loaded", chname),
./library.R- domain = NA)
./library.R-
./library.R- if(!file.exists(file))
./library.R: stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R- if(verbose)
./library.R- message(gettextf("now dyn.unload(\"%s\") ...", file), domain = NA)
./library.R- dyn.unload(file)
--
./namespace.R- ## look up where some commonly used generics are (including the
./namespace.R- ## group generics).
./namespace.R- defenv <- if(!is.na(w <- .knownS3Generics[genname])) asNamespace(w)
./namespace.R- else {
./namespace.R- if(!exists(genname, envir = parent.env(envir)))
./namespace.R: stop(gettextf("object '%s' not found whilst loading namespace '%s'",
./namespace.R- genname, package), call. = FALSE, domain = NA)
./namespace.R- genfun <- get(genname, envir = parent.env(envir))
./namespace.R- if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction")) {
./grep.R- }
./grep.R-
./grep.R- if(!is.character(pattern)
./grep.R- || (length(pattern) < 1)
./grep.R- || ((n <- nchar(pattern)) == 0))
./grep.R: stop("'pattern' must be a non-empty character string")
./grep.R-
./grep.R- if(!is.list(max.distance)) {
./grep.R- if(!is.numeric(max.distance) || (max.distance < 0))
./grep.R- || ((n <- nchar(pattern)) == 0))
./grep.R- stop("'pattern' must be a non-empty character string")
./grep.R-
./grep.R- if(!is.list(max.distance)) {
./grep.R- if(!is.numeric(max.distance) || (max.distance < 0))
./grep.R: stop("'max.distance' must be non-negative")
./grep.R- if(max.distance < 1) # transform percentages
./grep.R- max.distance <- ceiling(n * max.distance)
./grep.R- max.insertions <- max.deletions <- max.substitutions <-
./grep.R- else {
./grep.R- ## partial matching
./grep.R- table <- c("all", "deletions", "insertions", "substitutions")
./grep.R- ind <- pmatch(names(max.distance), table)
./grep.R- if(any(is.na(ind)))
./grep.R: warning("unknown match distance components ignored")
./grep.R- max.distance <- max.distance[!is.na(ind)]
./grep.R- names(max.distance) <- table[ind]
./grep.R- ## sanity checks
./grep.R- max.distance <- max.distance[!is.na(ind)]
./grep.R- names(max.distance) <- table[ind]
./grep.R- ## sanity checks
./grep.R- comps <- unlist(max.distance)
./grep.R- if(!all(is.numeric(comps)) || any(comps < 0))
./grep.R: stop("'max.distance' components must be non-negative")
./grep.R- ## extract restrictions
./grep.R- if(is.null(max.distance$all))
./grep.R- max.distance$all <- 0.1
./kappa.R-kappa.tri <- function(z, exact = FALSE, ...)
./kappa.R-{
./kappa.R- if(exact) kappa.default(z)
./kappa.R- else {
./kappa.R- p <- nrow(z)
./kappa.R: if(p != ncol(z)) stop("matrix should be square")
./kappa.R- 1 / .Fortran("dtrco",
./kappa.R- as.double(z),
./kappa.R- p,
./library.R- ## depends on R version?
./library.R- if(length(Rdeps <- pkgInfo$Rdepends) > 1) {
./library.R- target <- Rdeps$version
./library.R- res <- eval(parse(text=paste("current", Rdeps$op, "target")))
./library.R- if(!res)
./library.R: stop(gettextf("This is R %s, package '%s' needs %s %s",
./library.R- current, pkgname, Rdeps$op, target),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R- }
./library.R- ## which version was this package built under?
./library.R- if(!is.null(built <- pkgInfo$Built)) {
./library.R- ## must be >= 2.0.0
./library.R- if(built$R < "2.0.0")
./library.R: stop(gettextf("package '%s' was built before R 2.0.0: please re-install it",
./library.R- pkgname), call. = FALSE, domain = NA)
./library.R- ## warn if later than this version
./library.R- if(built$R > current)
./library.R- if(built$R < "2.0.0")
./library.R- stop(gettextf("package '%s' was built before R 2.0.0: please re-install it",
./library.R- pkgname), call. = FALSE, domain = NA)
./library.R- ## warn if later than this version
./library.R- if(built$R > current)
./library.R: warning(gettextf("package '%s' was built under R version %s",
./library.R- pkgname, as.character(built$R)),
./library.R- call. = FALSE, domain = NA)
./library.R- if(.Platform$OS.type == "unix") {
./library.R- call. = FALSE, domain = NA)
./library.R- if(.Platform$OS.type == "unix") {
./library.R- platform <- built$Platform
./library.R- if(length(grep("\\w", platform)) &&
./library.R- !testPlatformEquivalence(platform, R.version$platform))
./library.R: stop(gettextf("package '%s' was built for %s",
./library.R- pkgname, platform),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R- pkgname, platform),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R- }
./library.R- else
./library.R: stop(gettextf("package '%s' has not been installed properly\n",
./library.R- pkgname),
./library.R- gettext("See the Note in ?library"),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R- }
./library.R- else
./library.R- stop(gettextf("package '%s' has not been installed properly\n",
./library.R- pkgname),
./library.R: gettext("See the Note in ?library"),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R-
./library.R- Classobjs <- grep("^\\.__", same)
./library.R- if(length(Classobjs)) same <- same[-Classobjs]
./library.R- if(length(same)) {
./library.R- if (fst) {
./library.R- fst <- FALSE
./library.R: cat(gettextf("\nAttaching package: '%s'\n\n", package))
./library.R- }
./library.R- cat("\n\tThe following object(s) are masked",
./library.R- if (i < lib.pos) "_by_" else "from", sp[i],
./library.R- if(package %in% c("ctest", "eda", "modreg", "mva", "nls",
./library.R- "stepfun", "ts")) {
./library.R- have.stats <- "package:stats" %in% search()
./library.R- if(!have.stats) require("stats")
./library.R- old <- "stats"
./library.R: warning(gettextf("package '%s' has been merged into '%s'",
./library.R- package, old),
./library.R- call. = FALSE, domain = NA)
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
./library.R- }
./library.R- if(package == "mle") {
./library.R- have.stats4 <- "package:stats4" %in% search()
./library.R- if(!have.stats4) require("stats4")
./library.R- old <- "stats4"
./library.R: warning(gettextf("package '%s' has been merged into '%s'",
./library.R- package, old),
./library.R- call. = FALSE, domain = NA)
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
--
./namespace.R- # serialization code
./namespace.R- name <- name[1]
./namespace.R- if (name %in% c("ctest","eda","modreg","mva","nls",
./namespace.R- "stepfun","ts")) {
./namespace.R- old <- "stats"
./namespace.R: warning(gettextf("package '%s' has been merged into '%s'",
./namespace.R- name, old),
./namespace.R- call. = FALSE, domain = NA)
./namespace.R- return(getNamespace("stats"))
./library.R- package, old),
./library.R- call. = FALSE, domain = NA)
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
./library.R- }
./library.R- if(package == "lqs") {
./library.R: warning("package 'lqs' has been moved back to package 'MASS'",
./library.R- call. = FALSE, immediate. = TRUE)
./library.R- have.VR <- "package:MASS" %in% search()
./library.R- if(!have.VR) {
./library.R- warning("package 'lqs' has been moved back to package 'MASS'",
./library.R- call. = FALSE, immediate. = TRUE)
./library.R- have.VR <- "package:MASS" %in% search()
./library.R- if(!have.VR) {
./library.R- if(require("MASS", quietly=TRUE))
./library.R: warning("package 'MASS' has now been loaded",
./library.R- call. = FALSE, immediate. = TRUE)
./library.R- else {
./library.R- if(logical.return) return(FALSE)
./library.R- warning("package 'MASS' has now been loaded",
./library.R- call. = FALSE, immediate. = TRUE)
./library.R- else {
./library.R- if(logical.return) return(FALSE)
./library.R- else
./library.R: stop("package 'MASS' seems to be missing from this R installation")
./library.R- }
./library.R- }
./library.R- return(if (logical.return) TRUE else invisible(.packages()))
./library.R- pkgpath <- .find.package(package, lib.loc, quiet = TRUE,
./library.R- verbose = verbose)
./library.R- if(length(pkgpath) == 0) {
./library.R- vers <- libraryPkgVersion(package)
./library.R- txt <- if (!is.null(vers))
./library.R: gettextf("there is no package called '%s', version %s",
./library.R- libraryPkgName(package), vers)
./library.R- else
./library.R- gettextf("there is no package called '%s'",
./library.R- pkgpath <- .find.package(package, lib.loc, quiet = TRUE,
./library.R- verbose = verbose)
./library.R- if(length(pkgpath) == 0) {
./library.R- vers <- libraryPkgVersion(package)
./library.R- txt <- if (!is.null(vers))
./library.R: gettextf("there is no package called '%s', version %s",
./library.R- libraryPkgName(package), vers)
./library.R- else
./library.R: gettextf("there is no package called '%s'",
./library.R- libraryPkgName(package))
./library.R- if(logical.return) {
./library.R- warning(txt, domain = NA)
--
./library.R-
./library.R- if(!quiet && (length(bad) > 0)) {
./library.R- if(length(out) == 0)
./library.R- stop("none of the packages were found")
./library.R- for(pkg in bad)
./library.R: warning(gettextf("there is no package called '%s'", pkg),
./library.R- domain = NA)
./library.R- }
./library.R-
--
./namespace.R- bindtextdomain(paste("R", pkgname, sep="-"), popath)
./namespace.R- }
./namespace.R- # find package and check it has a name space
./namespace.R- pkgpath <- .find.package(package, lib.loc, quiet = TRUE)
./namespace.R- if (length(pkgpath) == 0)
./namespace.R: stop(gettextf("there is no package called '%s'", package),
./namespace.R- domain = NA)
./namespace.R- bindTranslations(package, pkgpath)
./namespace.R- package.lib <- dirname(pkgpath)
./library.R- }
./library.R- which.lib.loc <- dirname(pkgpath)
./library.R- pfile <- system.file("Meta", "package.rds", package = package,
./library.R- lib.loc = which.lib.loc)
./library.R- if(!nchar(pfile))
./library.R: stop(gettextf("'%s' is not a valid package -- installed < 2.0.0?",
./library.R- libraryPkgName(package)), domain = NA)
./library.R- pkgInfo <- .readRDS(pfile)
./library.R- testRversion(pkgInfo, package)
./library.R- ## The check for inconsistent naming is now in .find.package
./library.R-
./library.R- if(is.character(pos)) {
./library.R- npos <- match(pos, search())
./library.R- if(is.na(npos)) {
./library.R: warning(gettextf("'%s' not found on search path, using pos = 2", pos), domain = NA)
./library.R- pos <- 2
./library.R- } else pos <- npos
./library.R- }
./library.R- dataPath = dataPath)
./library.R- })
./library.R- if (inherits(tt, "try-error"))
./library.R- if (logical.return)
./library.R- return(FALSE)
./library.R: else stop(gettextf("package/namespace load failed for '%s'",
./library.R- libraryPkgName(package)),
./library.R- call. = FALSE, domain = NA)
./library.R- else {
./library.R- ## source file into loadenv
./library.R- if(file.exists(codeFile)) {
./library.R- res <- try(sys.source(codeFile, loadenv,
./library.R- keep.source = keep.source))
./library.R- if(inherits(res, "try-error"))
./library.R: stop(gettextf("unable to load R code in package '%s'",
./library.R- libraryPkgName(package)),
./library.R- call. = FALSE, domain = NA)
./library.R- } else if(verbose)
--
./namespace.R- codename <- strsplit(package, "_", fixed=TRUE)[[1]][1]
./namespace.R- codeFile <- file.path(pkgpath, "R", codename)
./namespace.R- if (file.exists(codeFile)) {
./namespace.R- res <- try(sys.source(codeFile, env, keep.source = keep.source))
./namespace.R- if(inherits(res, "try-error"))
./namespace.R: stop(gettextf("unable to load R code in package '%s'", package),
./namespace.R- call. = FALSE, domain = NA)
./namespace.R- } else warning(gettextf("package '%s' contains no R code", package),
./namespace.R- domain = NA)
./library.R- if(inherits(res, "try-error"))
./library.R- stop(gettextf("unable to load R code in package '%s'",
./library.R- libraryPkgName(package)),
./library.R- call. = FALSE, domain = NA)
./library.R- } else if(verbose)
./library.R: warning(gettextf("package '%s' contains no R code",
./library.R- libraryPkgName(package)), domain = NA)
./library.R- ## lazy-load data sets if required
./library.R- dbbase <- file.path(which.lib.loc, package, "data", "Rdata")
--
./namespace.R- if (file.exists(codeFile)) {
./namespace.R- res <- try(sys.source(codeFile, env, keep.source = keep.source))
./namespace.R- if(inherits(res, "try-error"))
./namespace.R- stop(gettextf("unable to load R code in package '%s'", package),
./namespace.R- call. = FALSE, domain = NA)
./namespace.R: } else warning(gettextf("package '%s' contains no R code", package),
./namespace.R- domain = NA)
./namespace.R-
./namespace.R- ## partial loading stops at this point
./library.R- firstlib <- get(".First.lib", mode = "function",
./library.R- envir = env, inherits = FALSE)
./library.R- tt<- try(firstlib(which.lib.loc, package))
./library.R- if(inherits(tt, "try-error"))
./library.R- if (logical.return) return(FALSE)
./library.R: else stop(gettextf(".First.lib failed for '%s'",
./library.R- libraryPkgName(package)), domain = NA)
./library.R- }
./library.R- if(!is.null(firstlib <- getOption(".First.lib")[[package]])){
./library.R- tt<- try(firstlib(which.lib.loc, package))
./library.R- if(inherits(tt, "try-error"))
./library.R- if (logical.return) return(FALSE)
./library.R: else stop(gettextf(".First.lib failed for '%s'",
./library.R- libraryPkgName(package)), domain = NA)
./library.R- }
./library.R- nogenerics <- checkNoGenerics(env, package)
./library.R- methods::cacheMetaData(env, TRUE, searchWhere = .GlobalEnv)
./library.R- runUserHook(package, pkgpath)
./library.R- on.exit()
./library.R- }
./library.R- if (verbose && !newpackage)
./library.R: warning(gettextf("package '%s' already present in search()",
./library.R- libraryPkgName(package)), domain = NA)
./library.R-
./library.R- }
./library.R- drop = FALSE])
./library.R- outFile <- tempfile("RlibraryIQR")
./library.R- outConn <- file(outFile, open = "w")
./library.R- first <- TRUE
./library.R- for(lib in names(out)) {
./library.R: writeLines(gettextf("%sPackages in library '%s':\n",
./library.R- ifelse(first, "", "\n"),
./library.R- lib),
./library.R- outConn)
./library.R- first <- FALSE
./library.R- }
./library.R- if(first) {
./library.R- close(outConn)
./library.R- unlink(outFile)
./library.R: message("no packages found")
./library.R- }
./library.R- else {
./library.R- if(!is.null(x$footer))
./library.R- else {
./library.R- if(!is.null(x$footer))
./library.R- writeLines(c("\n", x$footer), outConn)
./library.R- close(outConn)
./library.R- file.show(outFile, delete.file = TRUE,
./library.R: title = gettext("R packages available"))
./library.R- }
./library.R- invisible(x)
./library.R-}
./library.R- file <- file.path(pkg, "libs",
./library.R- paste(chname, file.ext, sep = ""))
./library.R- if(file.exists(file)) break else file <- ""
./library.R- }
./library.R- if(file == "")
./library.R: stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R- ind <- sapply(dll_list, function(x) x$path == file)
./library.R- if(any(ind)) {
./library.R- if(verbose)
--
./library.R- if(!length(pos))
./library.R- stop(gettextf("shared library '%s' was not loaded", chname),
./library.R- domain = NA)
./library.R-
./library.R- if(!file.exists(file))
./library.R: stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R- if(verbose)
./library.R- message(gettextf("now dyn.unload(\"%s\") ...", file), domain = NA)
./library.R- dyn.unload(file)
./library.R- if(file == "")
./library.R- stop(gettextf("shared library '%s' not found", chname), domain = NA)
./library.R- ind <- sapply(dll_list, function(x) x$path == file)
./library.R- if(any(ind)) {
./library.R- if(verbose)
./library.R: message(gettextf("shared library '%s' already loaded", chname),
./library.R- domain = NA)
./library.R- return(invisible(dll_list[[ seq(along = dll_list)[ind] ]]))
./library.R- }
./library.R- file.ext = .Platform$dynlib.ext)
./library.R-{
./library.R- dll_list <- .dynLibs()
./library.R-
./library.R- if(missing(chname) || (nc_chname <- nchar(chname)) == 0)
./library.R: stop("no shared library was specified")
./library.R-
./library.R- ## Be defensive about possible system-specific extension for shared
./library.R- ## libraries, although the docs clearly say they should not be
./library.R-
./library.R- file <- file.path(libpath, "libs",
./library.R- paste(chname, file.ext, sep = ""))
./library.R- pos <- which(sapply(dll_list, function(x) x$path == file))
./library.R- if(!length(pos))
./library.R: stop(gettextf("shared library '%s' was not loaded", chname),
./library.R- domain = NA)
./library.R-
./library.R- if(!file.exists(file))
./library.R- loaded <- paste("package", pkgName, sep = ":") %in% search()
./library.R- }
./library.R-
./library.R- if (!loaded) {
./library.R- if (!quietly)
./library.R: cat(gettextf("Loading required package: %s\n", package))
./library.R- value <- library(package, character.only = TRUE, logical = TRUE,
./library.R- warn.conflicts = warn.conflicts, keep.source = keep.source,
./library.R- version = version)
--
./library.R- pkg, current, z$op, z$version, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R-
./library.R- if (!quietly)
./library.R: cat(gettextf("Loading required package: %s\n", pkg))
./library.R- library(pkg, character.only = TRUE, logical = TRUE,
./library.R- lib.loc = lib.loc) ||
./library.R- stop(gettextf("package '%s' could not be loaded", pkg),
./library.R- pkgs <- paste("package", package, sep = ":")
./library.R- pos <- match(pkgs, s)
./library.R- if(any(m <- is.na(pos))) {
./library.R- if(!quiet) {
./library.R- if(all(m))
./library.R: stop("none of the packages are loaded")
./library.R- else
./library.R- warning(sprintf(ngettext(as.integer(sum(m)),
./library.R- "package %s is not loaded",
./library.R- out <- c(out, paths)
./library.R- }
./library.R-
./library.R- if(!quiet && (length(bad) > 0)) {
./library.R- if(length(out) == 0)
./library.R: stop("none of the packages were found")
./library.R- for(pkg in bad)
./library.R- warning(gettextf("there is no package called '%s'", pkg),
./library.R- domain = NA)
./library.R-{
./library.R- if(!inherits(x, "packageInfo")) stop("wrong class")
./library.R- outFile <- tempfile("RpackageInfo")
./library.R- outConn <- file(outFile, open = "w")
./library.R- vignetteMsg <-
./library.R: gettextf("Further information is available in the following vignettes in directory '%s':",
./library.R- file.path(x$path, "doc"))
./library.R- headers <- c(gettext("Description:\n\n"),
./library.R- gettext("Index:\n\n"),
./conditions.R- else args <- r$interactive()
./conditions.R- .Internal(.invokeRestart(r, args))
./conditions.R-}
./conditions.R-
./conditions.R-withRestarts <- function(expr, ...) {
./conditions.R: docall <- function(fun, args) {
./conditions.R- enquote <- function(x) as.call(list(as.name("quote"), x))
./conditions.R- if ((is.character(fun) && length(fun) == 1) || is.name(fun))
./conditions.R- fun <- get(as.character(fun), env = parent.frame(),
--
./conditions.R- if (is.function(spec))
./conditions.R- restarts[[i]] <- makeRestart(handler = spec)
./conditions.R- else if (is.character(spec))
./conditions.R- restarts[[i]] <- makeRestart(description = spec)
./conditions.R- else if (is.list(spec))
./conditions.R: restarts[[i]] <- docall("makeRestart", spec)
./conditions.R- else
./conditions.R- stop("not a valid restart specification")
./conditions.R- restarts[[i]]$name <- name
--
./conditions.R- restartArgs <- doWithOneRestart(return(expr), restart)
./conditions.R- # The return in the call above will exit withOneRestart unless
./conditions.R- # the restart is invoked; we only get to this point if the restart
./conditions.R- # is invoked. If we get here then the restart will have been
./conditions.R- # popped off the internal restart stack.
./conditions.R: docall(restart$handler, restartArgs)
./conditions.R- }
./conditions.R- withRestartList <- function(expr, restarts) {
./conditions.R- nr <- length(restarts)
--
./library.R- else if(!missing(help)) {
./library.R- if(!character.only)
./library.R- help <- as.character(substitute(help))
./library.R- pkgName <- help[1] # only give help on one package
./library.R- pkgPath <- .find.package(pkgName, lib.loc, verbose = verbose)
./library.R: docFiles <- c(file.path(pkgPath, "Meta", "package.rds"),
./library.R- file.path(pkgPath, "INDEX"))
./library.R- if(file.exists(vignetteIndexRDS <-
./library.R- file.path(pkgPath, "Meta", "vignette.rds")))
./library.R: docFiles <- c(docFiles, vignetteIndexRDS)
./library.R- pkgInfo <- vector(length = 3, mode = "list")
./library.R- readDocFile <- function(f) {
./library.R- if(basename(f) %in% "package.rds") {
--
./library.R- ")", sep = "")))
./library.R- else NULL
./library.R- } else
./library.R- readLines(f)
./library.R- }
./library.R: for(i in which(file.exists(docFiles)))
./library.R: pkgInfo[[i]] <- readDocFile(docFiles[i])
./library.R- y <- list(name = pkgName, path = pkgPath, info = pkgInfo)
./library.R- class(y) <- "packageInfo"
./library.R- return(y)
--
./library.R-
./library.R- if(missing(chname) || (nc_chname <- nchar(chname)) == 0)
./library.R- return(dll_list)
./library.R-
./library.R- ## Be defensive about possible system-specific extension for shared
./library.R: ## libraries, although the docs clearly say they should not be
./library.R- ## added.
./library.R- nc_file_ext <- nchar(file.ext)
./library.R- if(substr(chname, nc_chname - nc_file_ext + 1, nc_chname)
--
./library.R-
./library.R- if(missing(chname) || (nc_chname <- nchar(chname)) == 0)
./library.R- stop("no shared library was specified")
./library.R-
./library.R- ## Be defensive about possible system-specific extension for shared
./library.R: ## libraries, although the docs clearly say they should not be
./library.R- ## added.
./library.R- nc_file_ext <- nchar(file.ext)
./library.R- if(substr(chname, nc_chname - nc_file_ext + 1, nc_chname)
--
./library.R- ## (a package namespace, topLevelEnvironment option or
./library.R- ## .GlobalEnv)
./library.R- if(identical(save, .GlobalEnv)) {
./library.R- ## try to detect call from .First.lib in a package
./library.R- ##
./library.R: ## Although the docs have long and perhaps always had
./library.R- ## .First.lib(libname, pkgname)
./library.R- ## the majority of CRAN packages seems to use arguments
./library.R- ## 'lib' and 'pkg'.
--
./library.R- out <- character(0)
./library.R-
./library.R- for(pkg in package) {
./library.R- if(any(grep("_", pkg))) {
./library.R- ## The package "name" contains the version info.
./library.R: ## Note that .packages() is documented to return the "base
./library.R- ## names" of all currently attached packages. In the case
./library.R- ## of versioned installs, this seems to contain both the
./library.R- ## package name *and* the version number (not sure if this
--
./library.R- if(!inherits(x, "packageInfo")) stop("wrong class")
./library.R- outFile <- tempfile("RpackageInfo")
./library.R- outConn <- file(outFile, open = "w")
./library.R- vignetteMsg <-
./library.R- gettextf("Further information is available in the following vignettes in directory '%s':",
./library.R: file.path(x$path, "doc"))
./library.R- headers <- c(gettext("Description:\n\n"),
./library.R- gettext("Index:\n\n"),
./library.R- paste(paste(strwrap(vignetteMsg), collapse = "\n"),
./library.R- outFile <- tempfile("RpackageInfo")
./library.R- outConn <- file(outFile, open = "w")
./library.R- vignetteMsg <-
./library.R- gettextf("Further information is available in the following vignettes in directory '%s':",
./library.R- file.path(x$path, "doc"))
./library.R: headers <- c(gettext("Description:\n\n"),
./library.R- gettext("Index:\n\n"),
./library.R- paste(paste(strwrap(vignetteMsg), collapse = "\n"),
./library.R- "\n\n", sep = ""))
./library.R- outConn <- file(outFile, open = "w")
./library.R- vignetteMsg <-
./library.R- gettextf("Further information is available in the following vignettes in directory '%s':",
./library.R- file.path(x$path, "doc"))
./library.R- headers <- c(gettext("Description:\n\n"),
./library.R: gettext("Index:\n\n"),
./library.R- paste(paste(strwrap(vignetteMsg), collapse = "\n"),
./library.R- "\n\n", sep = ""))
./library.R- footers <- c("\n", "\n", "")
./library.R- if(is.list(entry) || is.matrix(entry))
./library.R- formatDL(entry, style = "list")
./library.R- else
./library.R- entry
./library.R- }
./library.R: writeLines(gettextf("\n\t\tInformation on package '%s'\n", x$name),
./library.R- outConn)
./library.R- for(i in which(!sapply(x$info, is.null))) {
./library.R- writeLines(headers[i], outConn, sep = "")
./library.R- writeLines(formatDocEntry(x$info[[i]]), outConn)
./library.R- writeLines(footers[i], outConn, sep = "")
./library.R- }
./library.R- close(outConn)
./library.R- file.show(outFile, delete.file = TRUE,
./library.R: title = gettextf("Documentation for package '%s'", x$name))
./library.R- invisible(x)
./library.R-}
./library.R-
./library.R- if ( !paste("package", pkg, sep = ":") %in% sch ) {
./library.R- if (length(z) > 1) {
./library.R- pfile <- system.file("Meta", "package.rds",
./library.R- package = pkg, lib.loc = lib.loc)
./library.R- if(nchar(pfile) == 0)
./library.R: stop(gettext("package '%s' required by '%s' could not be found",
./library.R- pkg, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R- stop(gettext("package '%s' required by '%s' could not be found",
./library.R- pkg, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R- if (!eval(parse(text=paste("current", z$op, "z$version"))))
./library.R: stop(gettextf("package '%s' %s was found, but %s %s is required by '%s'",
./library.R- pkg, current, z$op, z$version, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./library.R-
./library.R- if (!quietly)
./library.R- cat(gettextf("Loading required package: %s\n", pkg))
./library.R- library(pkg, character.only = TRUE, logical = TRUE,
./library.R- lib.loc = lib.loc) ||
./library.R: stop(gettextf("package '%s' could not be loaded", pkg),
./library.R- call. = FALSE, domain = NA)
./library.R- } else {
./library.R- ## check the required version number, if any
./library.R- if (length(z) > 1) {
./library.R- pfile <- system.file("Meta", "package.rds",
./library.R- package = pkg, lib.loc = lib.loc)
./library.R- current <- .readRDS(pfile)$DESCRIPTION["Version"]
./library.R- if (!eval(parse(text=paste("current", z$op, "z$version"))))
./library.R: stop(gettextf("package '%s' %s is loaded, but %s %s is required by '%s'",
./library.R- pkg, current, z$op, z$version, pkgname),
./library.R- call. = FALSE, domain = NA)
./library.R- }
./load.R- ## is compressed or not; zlib works either way.
./load.R- con <- gzfile(file)
./load.R- on.exit(close(con))
./load.R- }
./load.R- else if (inherits(file, "connection")) con <- gzcon(file)
./load.R: else stop("bad file argument")
./load.R- if(!isOpen(con)) {
./load.R- ## code below assumes that the connection is open ...
./load.R- open(con, "rb")
--
./load.R- else con <- file(file, "wb")
./load.R- on.exit(close(con))
./load.R- }
./load.R- else if (inherits(file, "connection"))
./load.R- con <- file
./load.R: else stop("bad file argument")
./load.R- if(isOpen(con) && summary(con)$text != "binary")
./load.R- stop("can only save to a binary connection")
./load.R- invisible(.Internal(saveToConn(list, con, ascii, version, envir)))
./load.R- open(con, "rb")
./load.R- }
./load.R-
./load.R- magic <- readChar(con, 5)
./load.R- if(nchar(magic) == 0) {
./load.R: warning("no input is available")
./load.R- return(character(0))
./load.R- }
./load.R- if (regexpr("RD[AX]2\n", magic) == -1) {
./load.R- return(character(0))
./load.R- }
./load.R- if (regexpr("RD[AX]2\n", magic) == -1) {
./load.R- ## a check while we still know the args
./load.R- if(regexpr("RD[ABX][12]\r", magic) == 1)
./load.R: stop("input has been corrupted, with LF replaced by CR")
./load.R- ## Not a version 2 magic number, so try the old way.
./load.R- if (is.character(file)) {
./load.R- close(con)
./load.R- ## Not a version 2 magic number, so try the old way.
./load.R- if (is.character(file)) {
./load.R- close(con)
./load.R- on.exit()
./load.R- }
./load.R: else stop("the input does not start with a magic number compatible with loading from a connection")
./load.R- .Internal(load(file, envir))
./load.R- }
./load.R- else .Internal(loadFromConn(con, envir))
./load.R- }
./load.R- else .Internal(loadFromConn(con, envir))
./load.R-}
./load.R-
./load.R-save <- function(..., list = character(0),
./load.R: file = stop("'file' must be specified"),
./load.R- ascii = FALSE, version = NULL, envir = parent.frame(),
./load.R- compress = FALSE)
./load.R-{
./load.R- list<- c(list, names)
./load.R- if (! is.null(version) && version == 1)
./load.R- invisible(.Internal(save(list, file, ascii, version, envir)))
./load.R- else {
./load.R- if (is.character(file)) {
./load.R: if (file == "") stop("'file' must be non-empty string")
./load.R- if (compress) con <- gzfile(file, "wb")
./load.R- else con <- file(file, "wb")
./load.R- on.exit(close(con))
--
./serialize.R-.saveRDS <-
./serialize.R-function(object, file = "", ascii = FALSE, version = NULL,
./serialize.R- compress = FALSE, refhook = NULL)
./serialize.R-{
./serialize.R- if(is.character(file)) {
./serialize.R: if(file == "") stop("'file' must be non-empty string")
./serialize.R- mode <- if(ascii) "w" else "wb"
./serialize.R- con <- if(compress) gzfile(file, mode) else file(file, mode)
./serialize.R- on.exit(close(con))
./load.R- }
./load.R- else if (inherits(file, "connection"))
./load.R- con <- file
./load.R- else stop("bad file argument")
./load.R- if(isOpen(con) && summary(con)$text != "binary")
./load.R: stop("can only save to a binary connection")
./load.R- invisible(.Internal(saveToConn(list, con, ascii, version, envir)))
./load.R- }
./load.R-}
--
./packages.R-function(e1, e2)
./packages.R-{
./packages.R- if(nargs() == 1)
./packages.R: stop("unary ", .Generic, " not defined for package_version objects")
./packages.R- boolean <- switch(.Generic, "<" = , ">" = , "==" = , "!=" = ,
./packages.R- "<=" = , ">=" = TRUE, FALSE)
./packages.R- if(!boolean)
./packages.R: stop(.Generic, " not defined for package_version objects")
./packages.R- if(!is.package_version(e1)) e1 <- as.package_version(e1)
./packages.R- if(!is.package_version(e2)) e2 <- as.package_version(e2)
./packages.R- base <- max(unlist(e1), unlist(e2), 0) + 1
--
./packages.R-{
./packages.R- ok <- switch(.Generic, max = , min = TRUE, FALSE)
./packages.R- if(!ok)
./packages.R: stop(.Generic, " not defined for package_version objects")
./packages.R- x <- list(x, ...)
./packages.R- x$na.rm <- NULL
./packages.R- x <- do.call("c", lapply(x, as.package_version))
--
./pretty.R- return(x)
./pretty.R- x <- x[is.finite(x)]
./pretty.R- if(is.na(n <- as.integer(n[1])) || n < 0)# n=0 !!
./pretty.R: stop("invalid 'n' value")
./pretty.R- if(!is.numeric(shrink.sml) || shrink.sml <= 0)
./pretty.R- stop("'shrink.sml' must be numeric > 0")
./pretty.R- if((min.n <- as.integer(min.n)) < 0 || min.n > n)