Update packages/ Add org-ref
This commit is contained in:
Mateus Pinto Rodrigues
329
elpa/ess-20180611.502/etc/other/S-spread/sprd-spr.s
Normal file
329
elpa/ess-20180611.502/etc/other/S-spread/sprd-spr.s
Normal file
@@ -0,0 +1,329 @@
|
||||
#-*-Fundamental-*-
|
||||
|
||||
|
||||
# Spreadsheet written in S
|
||||
|
||||
# The spreadsheet may be called anything.
|
||||
# References to cells in the spreadsheet must be called "x".
|
||||
|
||||
# Updating is in column order.
|
||||
|
||||
# Version 3 classes and methods technology.
|
||||
|
||||
|
||||
as.spread <- function(x)
|
||||
{
|
||||
if (is.spread(x)) return(x)
|
||||
x <- as.array(x)
|
||||
attr(x,"expr") <- as.expr(x, length=0)
|
||||
attr(x,"macro") <- as.expr(x, length=0)
|
||||
attr(x,"before") <- as.expr(x, length=0)
|
||||
attr(x,"after") <- as.expr(x, length=0)
|
||||
class(x) <- c("spread", class(x))
|
||||
x
|
||||
}
|
||||
|
||||
is.spread <- function(x)
|
||||
inherits(x,"spread")
|
||||
|
||||
|
||||
print.spread <- function(x, ..., quote=F)
|
||||
{
|
||||
if (inherits(x, "data.frame")) print.data.frame(x)
|
||||
else {
|
||||
class(x) <- class(x)[-match("spread",class(x))]
|
||||
print.array(x, ..., quote=quote)
|
||||
}
|
||||
invisible(x)
|
||||
}
|
||||
|
||||
|
||||
|
||||
"[.spread"<-
|
||||
function(x, ..., drop = F)
|
||||
{
|
||||
# Note: We do not retain the spread class!
|
||||
# If we did, the subscripts on the expr() and macros() would be wrong
|
||||
#
|
||||
NextMethod("[", drop=drop)
|
||||
}
|
||||
|
||||
|
||||
"[.expr" <- function(x, ... , drop=F)
|
||||
{
|
||||
# Note: We do retain the expr class.
|
||||
# The primary use is for printing, so we want the original subscripting.
|
||||
|
||||
z <- NextMethod("[", drop=drop)
|
||||
class(z) <- class(x)
|
||||
z
|
||||
}
|
||||
|
||||
|
||||
update.spread <- function(object, ..., force=F)
|
||||
{
|
||||
if (force) object <- eval.spread(object, NULL, force=force)
|
||||
if (length(before(object)))
|
||||
object <- eval.spread(object, before(object))
|
||||
if (length(expr(object)))
|
||||
object <- eval.spread(object, force=force)
|
||||
if (length(after(object)))
|
||||
object <- eval.spread(object, after(object))
|
||||
object
|
||||
}
|
||||
|
||||
eval.spread <- function(object, e, force=F)
|
||||
{
|
||||
x <- object
|
||||
class(x) <- class(x)[-match("spread",class(x))]
|
||||
if (force) {
|
||||
.Options$warn <- -1
|
||||
tmp <- as.numeric(as.matrix(x))
|
||||
if (!any(is.na(tmp))) x <- tmp
|
||||
}
|
||||
if (missing(e)) {
|
||||
if (inherits(x,"data.frame")) {
|
||||
e <- expr(object)
|
||||
if (force)
|
||||
for (j in 1:ncol(x)) for (i in 1:nrow(x))
|
||||
x[[i,j]] <- eval(e[i,j])
|
||||
else
|
||||
for (j in 1:ncol(x)) for (i in 1:nrow(x)) {
|
||||
eij <- e[i,j]
|
||||
if(is.language(eij)) x[[i,j]] <- eval(eij)
|
||||
}
|
||||
}
|
||||
else {
|
||||
i <- 0
|
||||
if (force)
|
||||
for (ei in expr(object))
|
||||
{i <- i+1; x[i] <- eval(ei)}
|
||||
else
|
||||
for (ei in expr(object))
|
||||
{i <- i+1; if(is.language(ei)) x[i] <- eval(ei)}
|
||||
}
|
||||
}
|
||||
else eval(e)
|
||||
class(x) <- class(object)
|
||||
x
|
||||
}
|
||||
|
||||
#usage: x <- macro.eval(x, i)
|
||||
macro.eval <- function(object, i)
|
||||
eval.spread(object, macro(x)[i])
|
||||
|
||||
|
||||
"[[<-.spread" <- function(...) do.call("[<-.spread", list(...))
|
||||
|
||||
"[<-.spread" <- function(object, ..., value)
|
||||
{
|
||||
x <- object
|
||||
expr(x) <- expression()
|
||||
class(x) <- NULL
|
||||
e <- expr(object)
|
||||
l.e <- length(e)
|
||||
i.a.v <- is.atomic(substitute(value))
|
||||
n.cells <- prod(dim(x[..., drop=F]))
|
||||
|
||||
if (l.e == 0) {
|
||||
if (n.cells != 1 || i.a.v )
|
||||
x[...] <- eval(substitute(value))
|
||||
else {
|
||||
e <- as.expr(object)
|
||||
l.e <- length(e)
|
||||
}
|
||||
}
|
||||
if (l.e != 0) {
|
||||
if (n.cells != 1) {
|
||||
e.s.v <- eval(substitute(value, sys.parent()))
|
||||
x[...] <- e.s.v
|
||||
e[...] <- e.s.v
|
||||
}
|
||||
else {
|
||||
e[[...]] <- substitute(value)
|
||||
x[[...]] <- eval(e[[...]])
|
||||
}
|
||||
}
|
||||
attributes(x) <- attributes(object)
|
||||
class(x) <- class(object)
|
||||
expr(x) <- e
|
||||
update.spread(x)
|
||||
}
|
||||
|
||||
|
||||
print.expr <- function(e, ..., replace.string=F) {
|
||||
replace <- as.logical(replace.string)
|
||||
if (length(e) == 0) {
|
||||
if (replace) cat(replace.string, "<- ")
|
||||
print(expression())
|
||||
}
|
||||
else if (is.null(dim(e))) {
|
||||
ne <- names(e)
|
||||
for (i in 1:length(e)) {
|
||||
nei <- index.value(ne, i)
|
||||
if (replace) cat(replace.string)
|
||||
cat(paste("[", nei, "] ", sep=""))
|
||||
if (replace) cat("<- expression(")
|
||||
cat(e[i])
|
||||
if (replace) cat(")")
|
||||
cat("\n")
|
||||
}
|
||||
}
|
||||
else {
|
||||
dn <- dimnames(e)
|
||||
if (is.null(dn)) dn <- list()
|
||||
for (i in 1:length(dim(e))) {
|
||||
if (is.null(dn[[i]])) dn[[i]] <- 1:dim(e)[i]
|
||||
}
|
||||
dnn <- outer(dn[[1]], dn[[2]], paste, sep=",")
|
||||
if (length(dn) > 2)
|
||||
for (i in 3:length(dn))
|
||||
dnn <- outer(dnn, dn[[i]], paste, sep=",")
|
||||
for (i in seq(length=length(e))) {
|
||||
if (replace) cat("x")
|
||||
cat(paste("[", dnn[i], "] ", sep=""))
|
||||
if (replace) cat("<-")
|
||||
cat(paste(" ", e[i], "\n", sep=""))
|
||||
}
|
||||
}
|
||||
invisible(e)
|
||||
}
|
||||
|
||||
as.expr <- function(x, ...) UseMethod("as.expr")
|
||||
|
||||
as.expr.default <- function(x, length.x=prod(dim(x))) {
|
||||
e <- vector(mode="expression", length=length.x)
|
||||
x <- unclass(x)
|
||||
if (length.x > 0) {
|
||||
e <- array(e, dim(x), dimnames(x))
|
||||
e[] <- x[]
|
||||
# for (i in 1:length(e)) e[i] <- x[i]
|
||||
}
|
||||
class(e) <- "expr"
|
||||
e
|
||||
}
|
||||
|
||||
as.expr.data.frame <- function(x, length.x=prod(dim(x))) {
|
||||
e <- vector(mode="expression", length=length.x)
|
||||
if (length.x > 0) {
|
||||
e <- array(e, dim(x), dimnames(x))
|
||||
u.x <- unclass(x)
|
||||
for (j in 1:ncol(x)) {
|
||||
uxj <- as.matrix(u.x[[j]])
|
||||
for (i in 1:nrow(x))
|
||||
e[i,j] <- uxj[i,1]
|
||||
}
|
||||
}
|
||||
class(e) <- "expr"
|
||||
e
|
||||
}
|
||||
|
||||
|
||||
expr <- function(x)
|
||||
attr(x,"expr")
|
||||
|
||||
# "expr<-" is used only when value is a matrix the size of x, or to update
|
||||
# a subscripted piece of x. It is not a user function.
|
||||
# Currently used only in "[<-.spread".
|
||||
"expr<-" <- function(x, value)
|
||||
{
|
||||
attr(x,"expr") <- value
|
||||
x
|
||||
}
|
||||
|
||||
"before<-" <- function(x, value)
|
||||
{
|
||||
attr(x,"before") <- value
|
||||
class(attr(x,"before")) <- "expr"
|
||||
x
|
||||
}
|
||||
|
||||
"macro<-" <- function(x, value)
|
||||
{
|
||||
attr(x,"macro") <- value
|
||||
class(attr(x,"macro")) <- "expr"
|
||||
x
|
||||
}
|
||||
|
||||
"after<-" <- function(x, value)
|
||||
{
|
||||
attr(x,"after") <- value
|
||||
class(attr(x,"after")) <- "expr"
|
||||
x
|
||||
}
|
||||
|
||||
before <- function(x)
|
||||
attr(x,"before")
|
||||
|
||||
|
||||
macro <- function(x)
|
||||
attr(x,"macro")
|
||||
|
||||
|
||||
after <- function(x)
|
||||
attr(x,"after")
|
||||
|
||||
|
||||
expr.rc <- function(x, ...) UseMethod("expr.rc")
|
||||
|
||||
expr.rc.default <- function(x, acpab)
|
||||
{
|
||||
subs <- paste("[", paste(acpab, collapse=","), "]")
|
||||
|
||||
if (length(expr(x))==0) {
|
||||
x.expr <- paste("x.value(x",subs,")",sep="")
|
||||
value <- eval(parse(text=x.expr))
|
||||
}
|
||||
else {
|
||||
e.expr <- paste("expr.value(expr(x)", subs, ", x", subs, ")")
|
||||
value <- eval(parse(text=e.expr))
|
||||
}
|
||||
|
||||
paste("x", subs, " <- ", value, sep="")
|
||||
}
|
||||
|
||||
|
||||
x.value <- function(x) {
|
||||
value <-
|
||||
if (length(x)==1)
|
||||
as.vector(as.matrix(x[[1]]))
|
||||
else if (inherits(x,"data.frame"))
|
||||
lapply(x, function(x) as.vector(as.matrix(x)))
|
||||
else
|
||||
as.vector(x)
|
||||
deparse(value)
|
||||
}
|
||||
|
||||
expr.value <- function(e, x) {
|
||||
if (inherits(x,"data.frame") &&
|
||||
(dim(e)[2]>1 || inherits(x[[1]],"factor")))
|
||||
value <- deparse(lapply(e, function(x) as.vector(as.matrix(x))))
|
||||
else {
|
||||
value <- paste(e, collapse=",")
|
||||
if (length(e) > 1) value <- paste("c(", value, ")", sep="")
|
||||
}
|
||||
value
|
||||
}
|
||||
|
||||
|
||||
index.value <- function(dn, i, deparse.result=T) {
|
||||
if (i==0) {i <- 0; mode(i) <- "missing"}
|
||||
if (is.numeric(i) && i>0 && length(dn)) i <- dn[i]
|
||||
if (deparse.result) deparse(as.vector(i))
|
||||
else as.vector(i)
|
||||
}
|
||||
|
||||
as.numeric.spread <- function(x)
|
||||
{
|
||||
.Options$warn <- -1
|
||||
tmp <- as.numeric(unclass(x))
|
||||
tmp <- ifelse(is.na(tmp), 0, tmp)
|
||||
attributes(tmp) <- attributes(x)
|
||||
tmp
|
||||
}
|
||||
|
||||
all.numeric <- function(x) {
|
||||
.Options$warn <- -1
|
||||
!any(is.na(as.numeric(x)))
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user