pp.convdate <-
function (x) 
{
	# function placed in the public domain 2011 by Burns Statistics

	x <- as.character(x)
	xs <- strsplit(x, " ")
	days <- sapply(xs, '[', 1)
	mons <- sapply(xs, '[', 2)
	yrs <- sapply(xs, '[', 3)
	mons <- match(mons, c('January', 'February', 'March', 'April', 'May',
		'June', 'July', 'August', 'September', 'October', 'November',
		'December'))
	mons <- as.character(mons)
	nm <- nchar(mons)
	mons[nm == 1] <- paste('0', mons[nm == 1], sep='')
	nd <- nchar(days)
	days[nd == 1] <- paste('0', days[nd == 1], sep='')
	paste(yrs, mons, days, sep='-')
}

pp.denplot <-
function (ret, name, start, lwd=2, main="", tlim=3,
	probs=c(.99, .95, .90, .75, .25, .10, .05, .01), digits=0, ...) 
{
	# function placed in the public domain 2011 by Burns Statistics

	x <- start * exp(ret)
	denx <- density(x, to=min(max(x), tlim * start))
	plot(denx, main=main, xlab=name, 
		ylab="", lwd=lwd, col="blue", yaxt="n", ...)
	abline(v=start, col="green")
	quans <- quantile(x, probs=probs)
	qtext <- paste(format(probs*100), "%: ", format(round(quans, 
		digits=digits)), sep="")
	text(max(denx$x) - .02 * start, adj=1, .8 * par("usr")[4], 
		paste(qtext, collapse="\n"))
}

pp.garchblocksim <-
function (garobj, block, ahead=250, number=5000, collapse=TRUE, var.out=FALSE, 
	trim=.001) 
{
	# function placed in the public domain 2011 by Burns Statistics

	subfun.samp <- function(resids, top, bseq, nb, ahead, block) {
		ans <- rep(NA * 0, ahead)
		for(i in 1:nb) {
			this.samp <- resids[sample(top, 1) + bseq]
			if(runif(1) < .5) this.samp <- -this.samp
			ans[bseq + 1 + block * (i - 1)] <- this.samp
		}
		length(ans) <- ahead
		ans
	}
	if(length(garobj$coef) != 3) stop("garch(1,1) model only")

	resids <- garobj$residuals # standardized residuals
	resids <- resids[!is.na(resids)]
	top <- length(resids) - block + 1
	bseq <- 0:(block-1)
	nb <- ceiling(ahead/block)
	coefs <- garobj$coef
	int <- coefs[1]
	alph <- coefs[2]
	beta <- coefs[3]
	startvar <- garobj$fitted.values[length(resids)]^2
	out <- array(NA, c(ahead, number))
	if(var.out) outv <- out
	for(j in 1:number) {
		this.res <- subfun.samp(resids, top, bseq, nb, ahead, block)
		this.var <- startvar
		for(i in 1:ahead) {
			out[i,j] <- this.ret <- sqrt(this.var) * this.res[i]
			this.var <- int + alph * this.ret^2 + beta * this.var
			if(var.out) outv[i,j] <- this.var
		}
	}
	if(collapse) {
		out <- colSums(out)
		if(trim > 0) {
			tlim <- quantile(out, c(trim, 1-trim))
			out <- out[out > tlim[1] & out < tlim[2] ]
		}
	}
	if(var.out) {
		list(returns=out, condvar=outv, garch.coef=coefs)
	} else {
		attr(out, "garch.coef") <- coefs
		out
	}

}

pp.garchsim <-
function (garobj, ahead=250, number=5000, collapse=TRUE, var.out=FALSE, 
	trim=.001) 
{
	# function placed in the public domain 2011 by Burns Statistics

	if(length(garobj$coef) != 3) stop("garch(1,1) model only")

	resids <- garobj$residuals # standardized residuals
	resids <- resids[!is.na(resids)]
	resids <- c(resids, -resids)
	coefs <- garobj$coef
	int <- coefs[1]
	alph <- coefs[2]
	beta <- coefs[3]
	startvar <- garobj$fitted.values[length(resids)]^2
	out <- array(NA, c(ahead, number))
	if(var.out) outv <- out
	for(j in 1:number) {
		this.res <- sample(resids, ahead, replace=TRUE)
		this.var <- startvar
		for(i in 1:ahead) {
			out[i,j] <- this.ret <- sqrt(this.var) * this.res[i]
			this.var <- int + alph * this.ret^2 + beta * this.var
			if(var.out) outv[i,j] <- this.var
		}
	}
	if(collapse) {
		out <- colSums(out)
		if(trim > 0) {
			tlim <- quantile(out, c(trim, 1-trim))
			out <- out[out > tlim[1] & out < tlim[2] ]
		}
	}
	if(var.out) {
		list(returns=out, condvar=outv, garch.coef=coefs)
	} else {
		attr(out, "garch.coef") <- coefs
		out
	}

}

pp.htmltable <-
function (x, filename="", order=TRUE) 
{
	# function placed in the public domain 2011 by Burns Statistics

	sfun.row <- function(r) {
		cat(file=filename, append=TRUE, "<tr>\n")
		cat(file=filename, append=TRUE, paste("<td>", r, "</td>\n", sep=""))
		cat(file=filename, append=TRUE, "</tr>\n")
	}
	if(!is.data.frame(x)) stop("expecting 'x' to be a data frame")
	if(ncol(x) != 4) stop("expecting 'x' to have 4 columns")
	if(order) {
		x <- x[order(x[, "value"]), ]
	}

	ref <- as.character(x[, "reference"])
	ref <- paste('<a href="', ref, '" target="_blank">webpage</a>', sep="")
	x[,"reference"] <- ref
	x[, "value"] <- format(x[, "value"], big.mark=",")
	x <- as.matrix(x)
	cat("<table>\n<tbody>\n", file=filename)
	sfun.row(paste("<strong>", colnames(x), "</strong>", sep=""))
	for(i in 1:nrow(x)) sfun.row(x[i,])  #wrong if zero rows
	cat("</tbody>\n</table>\n", file=filename, append=TRUE)
}

pp.lores <-
function (x, nobs)
{
	# function placed in the public domain 2011 by Burns Statistics

	n <- length(x)
	if(nobs > n) {
		res <- x - mean(x)
	} else {
		df <- data.frame(time=1:n, y=drop(x))
		lo <- loess(y ~ time, data=df, span=nobs/n)
		res <- lo$residuals
	}
	res
}

pp.omnipred <-
function (symbol, name, prefix, year=2011, startdate=20030101, nobs=7, 
	block=50, lev=NULL, garsave=FALSE, trim=TRUE) 
{
	# function placed in the public domain 2011 by Burns Statistics

	require(TTR)
	require(tseries)
	if(!length(lev)) {
		lev <- getYahooData(symbol, start=startdate)[, "Close"]
	}
	if(trim) {
		dat <- index(lev)
		out <- substring(dat, 1, 4) == year
		lev <- lev[!out]
	}
	ret <- diff(log(lev))
	res <- pp.lores(ret, nobs)
	sco1 <- c(var(res) * .02, .05, .93)
	gar1 <- garch(res, start=sco1)
	sco2 <- c(var(res) * .01, .05, .94)
	gar2 <- garch(res, start=sco2)
	gsum1 <- sum(gar1$coef[-1])
	gsum2 <- sum(gar2$coef[-1])
	cat("fraction of zeros in res is", mean(abs(unclass(res)) < 1e-10), 
		"\n")
	cat("garch coeficients 1 are:\n")
	print(gar1$coef)
	cat("alpha + beta 1:", gsum1, "\n")
	cat("garch coeficients 2 are:\n")
	print(gar2$coef)
	cat("alpha + beta 2:", gsum2, "\n")
	initlev <- as.vector(tail(lev, 1))
	cat("initial level is", initlev, "\n")
	if(gsum1 < 1 && gsum2 >= 1) {
		gar <- gar1
	} else if(gsum2 < 1 && gsum1 >= 1) {
		gar <- gar2
	} else {
		if(gar1$n.likeli < gar2$n.likeli) {
			gar <- gar1
		} else {
			gar <- gar2
		}
	}
	fullname <- paste(name, year, sep=" -- ")
	if(block > 1) {
		sim <- pp.garchblocksim(gar, block)
	} else {
		sim <- pp.garchsim(gar)
	}
	if(garsave) {
			assign(paste(prefix, year, "gar", sep="_"), gar, pos=1)
	}
	assign(paste(prefix, year, "sim", sep="_"), sim, pos=1)
	assign(paste(prefix, year, "res", sep="_"), res, pos=1)
	assign(paste(prefix, year, "initlev", sep="_"), initlev, pos=1)
	assign(paste(prefix, year, "ecdf", sep="_"), ecdf(initlev * exp(sim)), 
		pos=1)
	
	plotfile <- paste(prefix, "_", year, ".png", sep="")
	png(file=plotfile, width=512)
	on.exit(dev.off())
	par(mar=c(4,2,0,2) + .1)
	pp.denplot(sim, fullname, start=initlev)
	plotfile
}

pp.png <-
function (filename, mar=c(5,4,0,2), ...) 
{
	# function placed in the public domain 2011 by Burns Statistics

	png(file=filename, width=512)
	par(mar=mar + .1, ...)
}

pp.predframe <-
function (prefix, person, firm, value, reference, note="", year=2011) 
{
	# function placed in the public domain 2011 by Burns Statistics

	pfnam <- paste(prefix, "_", year, ".predframe", sep="")
	nin <- length(person)
	if(length(firm) != nin) stop("bad length for 'firm'")
	if(length(value) != nin) stop("bad length for 'value'")
	if(length(reference) != nin) stop("bad length for 'reference'")
	note <- rep(note, length=nin)
	new <- data.frame(person=person, firm=firm, value=value, 
		reference=reference)
	if(exists(pfnam, where=1)) {
		old <- get(pfnam, pos=1)
		ans <- rbind(old, new)
		attr(ans, "prefix") <- attr(old, "prefix")
		attr(ans, "year") <- attr(old, "year")
		attr(ans, "description") <- attr(old, "description")
	} else {
		ans <- new
		attr(ans, "prefix") <- prefix
		attr(ans, "year") <- year
		cat("Need to add 'description' attribute to", pfnam, "\n")
	}
	assign(pfnam, ans, pos=1)
}

pp.predplot <-
function (pframe, ...) 
{
	# function placed in the public domain 2011 by Burns Statistics

	fprefix <- paste(attr(pframe, "prefix"), attr(pframe, "year"), 
		sep="_")
	name <- paste(attr(pframe, "description"), attr(pframe, "year"),
		sep=" - ")
	ret <- get(paste(fprefix, "sim", sep="_"))
	start <- get(paste(fprefix, "initlev", sep="_"))
	lrange <- start * exp(range(ret))
	pp.denplot(ret, name, start, xlim=range(lrange, pframe[, "value"]), ...)
	abline(v=pframe[, "value"], col="purple")
}