Add new packages installed

elpa/ess-20180319.504/etc/other/S-spread/sprd-emc.s

@@ -0,0 +1,280 @@
+#-*-Fundamental-*-
+
+	
+col.spacing <- function(x)
+{
+	rn.w <- if (length(dimnames(x)[[1]]) > 0) max(nchar(dimnames(x)[[1]]))
+		else nchar(as.character(nrow(x)))+3
+	col.w <- apply(x, 2, function(x) nchar(format(x))[1])
+	dn.w <- if (length(dimnames(x)[[2]]) > 0) nchar(dimnames(x)[[2]])
+		else nchar(as.character(ncol(x)))+3
+	col.w <- ifelse( col.w > dn.w , col.w, dn.w)
+	cumsum(c(rn.w,col.w)+1)
+}
+
+emacs.expr <- function(x, i, j=i[2], result.type)
+# 1. emacs.rc
+# 2. emacs.macro
+# 3. emacs.macro.text(deparse.result=T) #default for index.value
+# 4. emacs.macro.text(deparse.result=F)
+# 1. assign expression to cell or to macro
+# 2. evaluate macro expression
+# 3. retrieve macro expression
+# 4. construct control.text() expression from macro name
+# 5. construct print.text() expression from macro name
+{
+	# i and j are integer scalars
+
+	if (missing(j)) {j <- i[2] ; i <- i[1]}
+
+	if ((.Active == .Active.buffer) && (length(dim(x)) > 2))
+		stop("Must use rectangular slice, not 3d buffer")
+
+	if (i <= nrow(x) && result.type==1)
+		return(expr.rc(x, c(i, j)))
+
+	if (!inherits(x, "spread")) stop("Not a spread.frame")
+	mm <- (nrow(x)+1):(nrow(x)+2+length(macro(x)))
+	bb <- mm[length(mm)]+(1:(2+length(before(x))))
+	aa <- bb[length(bb)]+(1:(2+length(after(x))))
+
+	find.expr <- function(type.x, kk, type, result.type)
+	{
+	   if (kk>0) {
+	      iv <- index.value(names(type.x), kk,
+			!((result.type == 4) || (result.type == 5)))
+	      switch(result.type,
+		paste(type, "(x)[", iv, "] <- expression(",
+		   expr.value(type.x[kk],1), ")"),
+		paste("x <- eval.spread(x, ", type, "(x)[", iv, "] )" ),
+		deparse(eval(parse(text=paste(type, "(x)[", iv, "]")))[[1]]),
+		paste(iv, "<- control.text(", iv, ")"),
+		paste(iv, "<- print.text(", iv, ")")
+	      )
+	}
+	   else if (result.type==1) paste(type, "(x)[\"\"] <- expression()")
+	      else NULL
+	}
+
+	k <- match(i, mm, 0)
+	if (k) return(find.expr(macro(x), k-2, "macro", result.type))
+
+	k <- match(i, bb, 0)
+	if (k) return(find.expr(before(x), k-2, "before", result.type))
+
+	k <- match(i, aa, 0)
+	if (k) return(find.expr(after(x), k-2, "after", result.type))
+}
+
+cell.rc.emacs <- function(x, e.r, e.c)
+{
+	x.r <- ifelse(e.c == 0, e.r, e.r-1)
+	x.c <- sum(e.c >= col.spacing(x))
+	c(row=x.r, col=x.c)
+}
+
+print.update.emacs <- function(x, ...,
+	file=paste(.spread.directory, .Active.buffer, sep="/"))
+{
+	sink(file)
+	print(x, ...)
+
+	xs <- get(.Active)
+	if (inherits(xs, "spread"))
+	{
+		print.spread.macro(xs, macro)
+		print.spread.macro(xs, before)
+		print.spread.macro(xs, after)
+	}
+
+	sink()
+	invisible(x)
+}
+
+print.spread.macro <- function(x, macro)
+{
+	cat("\n**", as.character(substitute(macro)), "**\n", sep="")
+	ne <- names(macro(x))
+	if (length(ne))
+		for (i in 1:length(ne))
+			cat(index.value(ne,i,F),"\n")
+}
+	
+
+as.two.way.array <- function(x, subs=parse(text=.Active.buffer)[[1]][-(1:2)])
+{
+	if (length(dim(x))==2) return(x)
+# This is designed for 3 way arrays with
+# two missing and one specified dimension.
+# If the drop parameter exists, it is over-ridden.
+	subs$drop <- NULL
+	which.subs <- (sapply(subs,length)==0)
+	dnx <- dimnames(x)[which.subs]
+	dimnames(x) <- NULL
+	dim(x) <- dim(x)[which.subs]
+	dimnames(x) <- dnx
+	x
+}
+
+
+fg <- function( sprdname=.Active )
+# sprdname = character name, possibly subscripted
+{
+   if (is.na(match(sprdname, names(macro(.Registry))))) {
+	macro(.Registry)[sprdname] <- sprdname
+        assign(".Registry", .Registry, where=1 )
+   }	
+   assign(".Active.buffer", sprdname, frame=0 )
+   assign(".Active", find.names(sprdname), frame=0 )
+   assign("x", eval(parse(text=.Active)), where=1 )
+   assign("x.buffer", where=1,
+	if (.Active.buffer==.Active) x
+	else as.two.way.array(eval(parse(text=.Active.buffer))))
+   invisible(sprdname)
+}
+
+control.emacs <- function(x)
+{
+#this is a fake function
+#emacs does the work
+
+# control.emacs never gets called when emacs is in control.
+#	RET in spread window puts old command in minibuffer:
+# emacs sends
+#    emacs.cell('spreadname', e.r, e.c, result.type)
+# emacs reads the file written by the above and
+# asks the user to revise it in the minibuffer.
+#	RET in minibuffer puts revised command in S buffer,
+# and causes the revised command to be executed, updating the spreadsheet.
+# emacs issues
+#    invisible(assign(.Active, x))
+# to place the object in x into the object named in .Active
+# emacs issues
+#    print.find.emacs('spreadname', update.Registry=F)
+# to update all buffers showing views of the object named in .Active
+# When S gets control back, the command has been executed and the
+# spreadsheet has been updated
+}
+
+#emacs usage
+#load-file S-spread.el
+#In the *S* buffer, type ^Cr to place a spread.frame or 2-way or 3-way array
+# into a spread.frame buffer.
+#In the spread.frame buffer, type RET to update a cell.
+#In the minibuffer, revise the cell and type RET to update the object and
+# the display.
+#If there is a timing problem and the display is not updated,
+# then type ^Cv in the spread buffer.
+
+
+
+find.sprds <- function(sprdname, reg.names=names(macro(.Registry)))
+{
+	reg.names[find.names(reg.names) == find.names(sprdname)]
+}
+
+find.names <- function(reg.names)
+{
+	prn <- parse(text=reg.names)
+	for (i in 1:length(prn))
+		if (mode(prn[[i]]) != "name") reg.names[i] <- prn[[i]][[2]]
+	reg.names
+}
+
+
+print.sprds.emacs <- function(sprdname)
+{
+	fssn <- find.sprds(sprdname)
+	fssn2 <- fssn
+	for(i in fssn2) {
+		fg(i)
+		print.update.emacs(x.buffer)
+	}
+	cat(paste(fssn, collapse="\n"), "\n", sep="", file=.spread.command.file)
+	invisible(fg(sprdname))
+}
+
+print.update.emacs.3d <- function(object)
+{
+	object.name <- as.character(substitute(object))
+	dobject <- dim(object)
+	if (length(dobject) != 3) stop("3-way array required")
+	fg(object.name)
+
+	n3 <- dimnames(object)[[3]]
+	if (is.null(n3)) n3 <- seq(length=dobject[3])
+	else n3 <- paste("\"", n3, "\"", sep="")
+	for (i in n3) {
+		fg(paste( object.name, "[,,", i, "]", sep="" ))
+		print.update.emacs(x.buffer)
+	}
+	invisible(object)
+}
+
+emacs.start <- function(spread.directory)
+{
+	assign('.spread.directory', spread.directory, frame=0)
+	if (!exists('.Registry', 1))
+		assign(".Registry", where=1, as.spread(matrix(".Registry")))
+	assign(".spread.command.file", frame=0,
+		paste(spread.directory, "*command*", sep="/"))
+	fg(".Registry")
+	print.update.emacs(.Registry)
+	invisible(".Registry")
+}
+
+
+print.find.emacs <- function(spread=.Active, update.Registry=T)
+{
+	fg(spread)
+	if (update.Registry) {
+		fg(".Registry")
+		print.update.emacs(.Registry)
+		fg(spread)
+	}
+	print.sprds.emacs(spread)
+	invisible(spread)
+}
+
+
+emacs.cell <- function(spread, e.r, e.c, result.type)
+{
+	fg(spread)
+	cell.rc <- cell.rc.emacs(x.buffer, e.r, e.c)
+	.Options$width <- 1000
+	if (result.type==1 && cell.rc[1] <= nrow(x.buffer)) {
+		cell.rc <- cell.sub.emacs(x, cell.rc)
+		cell.expr <- expr.rc(x, cell.rc)
+	}
+	else
+		cell.expr <- emacs.expr(x, cell.rc, result.type=result.type)
+	cat(cell.expr, '\n', sep='', file=.spread.command.file)
+}
+
+cell.sub.emacs <- function(x, i, j=i[2])
+{
+	# i and j are integer scalars
+
+	if (missing(j)) {j <- i[2] ; i <- i[1]}
+	if (i==0 && j==0) stop("non-zero row or column required")
+
+	if ((length(dim(x)) == 2)) {
+		acpab <- c("","")
+		positions <- 1:2
+	}
+	else if (.Active == .Active.buffer)
+		stop("Must use rectangular slice, not 3d buffer")
+	else {
+		pab <- parse(text=.Active.buffer)
+		acpab <- as.character( pab[[1]][-(1:2)] )
+		positions <- (1:length(acpab))[sapply(acpab, nchar) == 0]
+	}
+
+	di <- index.value(dimnames(x)[[positions[1]]], i)
+	dj <- index.value(dimnames(x)[[positions[2]]], j)
+
+	acpab[positions[1]] <- di
+	acpab[positions[2]] <- dj
+
+	acpab
+}