./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)