Nothing
# Some Rcmdr dialogs for the epack package
# last modified: March 31, 2012 by E. Hodgess
# Note: the following function (with contributions from Richard Heiberger)
# can be included in any Rcmdr plug-in package to cause the package to load
# the Rcmdr if it is not already loaded
.onAttach <- function(libname, pkgname){
if (!interactive()) return()
Rcmdr <- options()$Rcmdr
plugins <- Rcmdr$plugins
if ((!pkgname %in% plugins) && !getRcmdr("autoRestart")) {
Rcmdr$plugins <- c(plugins, pkgname)
options(Rcmdr=Rcmdr)
closeCommander(ask=FALSE, ask.save=TRUE)
Commander()
}
}
ArimaMod <- function(){
initializeDialog(title=gettextRcmdr("ARIMA Models"))
.activeModel <- ActiveModel()
currentModel <- if (!is.null(.activeModel))
eval(parse(text=paste("class(", .activeModel, ")[1] == 'Arima'", sep="")),
envir=.GlobalEnv)
else FALSE
# if (currentModel) {
# currentFields <- formulaFields(eval(parse(text=.activeModel),
# envir=.GlobalEnv))
# if (currentFields$data != ActiveDataSet()) currentModel <- FALSE
# }
UpdateModelNumber()
modelName <- tclVar(paste("ArimaModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- tkentry(modelFrame, width="20", textvariable=modelName)
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=ArimaMod, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=ArimaMod, message=gettextRcmdr("You must select a variable."))
return()
}
AR1 <- tclvalue(ARLevel)
MA1 <- tclvalue(MAVariable)
DIF1 <- tclvalue(DIFVariable)
SAR1 <- tclvalue(SARLevel)
SMA1 <- tclvalue(SMAVariable)
SDIF1 <- tclvalue(SDIFVariable)
alternative <- as.character(tclvalue(alternativeVariable))
closeDialog()
if (is.element(modelValue, listArimaModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
ArimaMod()
return()
}
}
pd1 <- paste("tsp(",ActiveDataSet(),"$",x,")[3]",sep="")
assign("pd2",justDoIt(pd1),envir=.GlobalEnv)
command <- paste("Arima(", ActiveDataSet(), "$", x,",order=c(",AR1,",",DIF1,",",MA1,"),
include.mean=",alternative,",seasonal=list(order=c(",SAR1,",",SDIF1,",",SMA1
,"),period=",pd2,"))",sep="")
logger(paste(modelValue, " <- ", command, sep=""))
assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(modelValue)
activeModel(modelValue)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="arima")
radioButtons(top, name="alternative", buttons=c("yes","no"), values=c(TRUE,FALSE),
labels=gettextRcmdr(c("Mean Included","Mean Not Included")),
title=gettextRcmdr("Mean"))
rightFrame <- tkframe(top)
ARFrame <- tkframe(rightFrame)
ARLevel <- tclVar("0")
ARField <- tkentry(ARFrame, width="6", textvariable=ARLevel)
MAFrame <- tkframe(rightFrame)
MAVariable <- tclVar("0")
MAField <- tkentry(MAFrame, width="6", textvariable=MAVariable)
DIFFrame <- tkframe(rightFrame)
DIFVariable <- tclVar("0")
DIFField <- tkentry(DIFFrame,width="6",textvariable=DIFVariable)
SARFrame <- tkframe(rightFrame)
SARLevel <- tclVar("0")
SARField <- tkentry(SARFrame, width="6", textvariable=SARLevel)
SMAFrame <- tkframe(rightFrame)
SMAVariable <- tclVar("0")
SMAField <- tkentry(SMAFrame, width="6", textvariable=SMAVariable)
SDIFFrame <- tkframe(rightFrame)
SDIFVariable <- tclVar("0")
SDIFField <- tkentry(SDIFFrame,width="6",textvariable=SDIFVariable)
tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(rightFrame, text=""), sticky="w")
tkgrid(tklabel(ARFrame, text=gettextRcmdr("Reg. AR Order ")), ARField, sticky="w")
tkgrid(ARFrame, sticky="w")
tkgrid(tklabel(DIFFrame,text=gettextRcmdr("Reg. Diff Order ")),DIFField, sticky="w")
tkgrid(DIFFrame,sticky="w")
tkgrid(tklabel(MAFrame, text=gettextRcmdr("Reg. MA Order")), MAField, sticky="w")
tkgrid(MAFrame, sticky="w")
tkgrid(tklabel(SARFrame, text=gettextRcmdr("Sea. AR Order ")), SARField, sticky="w")
tkgrid(SARFrame, sticky="w")
tkgrid(tklabel(SDIFFrame,text=gettextRcmdr("Sea. Diff Order ")),SDIFField, sticky="w")
tkgrid(SDIFFrame,sticky="w")
tkgrid(tklabel(SMAFrame, text=gettextRcmdr("Sea. MA Order")), SMAField, sticky="w")
tkgrid(SMAFrame, sticky="w")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(ARField, sticky="e")
dialogSuffix(rows=6, columns=2)
}
bc2 <- function(x,lam1=seq(-2,2,.1)) {
require(MASS)
if(any(x)<=0)stop("Negative values present..no transformations permitted")
t1 <- 1:length(x)
xxx <-boxcox(x~t1,lambda=lam1,plot=FALSE)
z <- xxx$x[xxx$y==max(xxx$y)]
return(z)
}
newHistPrice <- function() {
initializeDialog(title=gettextRcmdr("New Historical Price"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
tick <- tclVar("ibm")
ticker <- tkentry(top, width="8", textvariable=tick)
starty <- tclVar("1998")
stay1 <- tkentry(top,width="4",textvariable=starty)
startm <- tclVar("01")
stam1 <- tkentry(top,width="2",textvariable=startm)
startd <- tclVar("01")
stad1 <- tkentry(top,width="2",textvariable=startd)
endy <- tclVar("1998")
endy1 <- tkentry(top,width="4",textvariable=endy)
endm <- tclVar("01")
endm1 <- tkentry(top,width="2",textvariable=endm)
endd <- tclVar("31")
endd1 <- tkentry(top,width="2",textvariable=endd)
onOK <- function(){
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=newHistPrice,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
}
alternative <- as.character(tclvalue(alternativeVariable))
startyVal <- tclvalue(starty)
startmVal <- tclvalue(startm)
startdVal <- tclvalue(startd)
endyVal <- tclvalue(endy)
endmVal <- tclvalue(endm)
enddVal <- tclvalue(endd)
TickValue <- trim.blanks(tclvalue(tick))
if (TickValue == "") {
errorCondition(recall=newHistPrice,
message=gettextRcmdr("You must enter a ticker symbol."))
return()
}
tick2 <- paste("",TickValue,"",sep="")
alt1 <- paste("",alternative,"",sep="")
startb <- paste(startyVal,"-",startmVal,"-",startdVal,sep="")
starta <- paste("",startb,"",sep="")
endb <- paste(endyVal,"-",endmVal,"-",enddVal,sep="")
enda <- paste("",endb,"",sep="")
command <- paste('histprice2(inst1="',tick2,'",quot1="',alt1,'",start1="',starta,'",end1="',enda,'")',
sep="")
assign(dsnameValue, justDoIt(command), envir=.GlobalEnv)
logger(paste(dsnameValue, "<-", command))
if (eval(parse(text=paste("nrow(", dsnameValue, ")"))) == 0){
errorCondition(recall=newHistPrice, message=gettextRcmdr("empty data set."))
return()
}
activeDataSet(dsnameValue)
closeDialog()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="get.hist.quote")
radioButtons(top, name="alternative", buttons=c("Open", "Close","High","Low","AdjClose"),
values=c("Open", "Close","High","Low","AdjClose"),
labels=gettextRcmdr(c("Obtain Open Price", "Obtain Closing Price",
"Obtain High Price","Obtain Low Price","Obtain Adj Closing Price")),
title=gettextRcmdr("Price Options"))
rightFrame <- tkframe(top)
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(tklabel(top,text="Ticker"),ticker,sticky="w")
tkgrid(tklabel(top,text="Start year"),stay1,sticky="w")
tkgrid(tklabel(top,text="Start month"),stam1,sticky="w")
tkgrid(tklabel(top,text="Start day"),stad1,sticky="w")
tkgrid(tklabel(top,text="End year"),endy1,sticky="w")
tkgrid(tklabel(top,text="End month"),endm1,sticky="w")
tkgrid(tklabel(top,text="End day"),endd1,sticky="w")
tkgrid(buttonsFrame, columnspan="2", sticky="w")
tkgrid.configure(entryDsname, sticky="w")
tkgrid.configure(ticker,sticky="w")
tkgrid.configure(stay1,sticky="w")
tkgrid.configure(stam1,sticky="w")
tkgrid.configure(stad1,sticky="w")
tkgrid.configure(endy1,sticky="w")
tkgrid.configure(endm1,sticky="w")
tkgrid.configure(endd1,sticky="w")
dialogSuffix(rows=10, columns=2, focus=entryDsname)
}
bcMod <- function(){
initializeDialog(title=gettextRcmdr("Box Cox Transformation"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=bcMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("bc2(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="boxcox")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
opMod <- function(){
initializeDialog(title=gettextRcmdr("Original Plots"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
print(x)
if (length(x) == 0){
errorCondition(recall=opMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("ts.plot(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="boxcox")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
acfMod <- function(){
initializeDialog(title=gettextRcmdr("ACF Plots"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
print(x)
if (length(x) == 0){
errorCondition(recall=acfMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("acf(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="acf")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
pacfMod <- function(){
initializeDialog(title=gettextRcmdr("PACF Plots"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=pacfMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("pacf(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="pacf")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
decomMod <- function(){
initializeDialog(title=gettextRcmdr("Multiplicative Decomposition"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=decomMod, message=gettextRcmdr("You must select a variable."))
return()
}
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=editTSframe,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
return()
}
freq1 <- tclvalue(freqVariable)
fore1 <- tclvalue(foreVariable)
closeDialog()
comm1 <- paste(dsnameValue,"<-decom5(", ActiveDataSet(), "$", x,
",se1=",freq1,",fore1=",fore1,
")", sep="")
doItAndPrint(comm1)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t.test")
freqFrame <- tkframe(top)
freqVariable <- tclVar("1")
freqField <- tkentry(freqFrame, width="6", textvariable=freqVariable)
foreFrame <- tkframe(top)
foreVariable <- tclVar("0")
foreField <- tkentry(foreFrame, width="8", textvariable=foreVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(foreFrame, text=gettextRcmdr("Number of Forecasts: ")), foreField, sticky="w")
tkgrid(foreFrame, sticky="w")
tkgrid(tklabel(freqFrame, text=gettextRcmdr("Freq: ")), freqField, sticky="w")
tkgrid(freqFrame, sticky="w")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid.configure(entryDsname, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(freqField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
specMod <- function(){
initializeDialog(title=gettextRcmdr("Spectral Density Plots"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=specMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("spectrum(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="spectrum")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
listArimaModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "Arima" == (class(eval(parse(text=.x), envir=envir))[1]))]
}
listGARCHModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "garch" == (class(eval(parse(text=.x), envir=envir))[1]))]
}
selectActiveARModel <- function(){
models <- listAllModels()
.activeModel <- ActiveModel()
if ((length(models) == 1) && !is.null(.activeModel)) {
Message(message=gettextRcmdr("There is only one model in memory."),
type="warning")
tkfocus(CommanderWindow())
return()
}
if (length(models) == 0){
Message(message=gettextRcmdr("There are no models from which to choose."),
type="error")
tkfocus(CommanderWindow())
return()
}
initializeDialog(title=gettextRcmdr("Select ARIMA Model"))
.activeDataSet <- ActiveDataSet()
initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"),
initialSelection=initial)
onOK <- function(){
model <- getSelection(modelsBox)
closeDialog()
if (length(model) == 0) {
tkfocus(CommanderWindow())
return()
}
# dataSet <- eval(parse(text=paste("as.character(", model, "$call$data)")))
dataSet <- eval(parse(text=paste("as.character(", model, "$series)")))
dataset1 <- unlist(strsplit(dataSet,"$",fixed=TRUE))[1]
dataSet <- dataset1
if (length(dataSet) == 0){
errorCondition(message=gettextRcmdr("There is no dataset associated with this model."))
return()
}
dataSets <- listDataSets()
if (!is.element(dataSet, dataSets)){
errorCondition(message=sprintf(gettextRcmdr("The dataset associated with this model, %s, is not in memory."), dataSet))
return()
}
if (is.null(.activeDataSet) || (dataSet != .activeDataSet)) activeDataSet(dataSet)
activeModel(model)
tkfocus(CommanderWindow())
}
OKCancelHelp()
nameFrame <- tkframe(top)
tkgrid(tklabel(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")),
tklabel(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
tkgrid(nameFrame, sticky="w", columnspan="2")
tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
predARModel <- function(){
models <- listAllModels()
.activeModel <- ActiveModel()
if ((length(models) == 1) && !is.null(.activeModel)) {
Message(message=gettextRcmdr("There is only one model in memory."),
type="warning")
tkfocus(CommanderWindow())
return()
}
if (length(models) == 0){
Message(message=gettextRcmdr("There are no models from which to choose."),
type="error")
tkfocus(CommanderWindow())
return()
}
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=decomaMod,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
initializeDialog(title=gettextRcmdr("ARIMA Forecasting"))
.activeDataSet <- ActiveDataSet()
initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"),
initialSelection=initial)
onOK <- function(){
model <- getSelection(modelsBox)
closeDialog()
if (length(model) == 0) {
tkfocus(CommanderWindow())
return()
}
activeModel(model)
fore1 <- tclvalue(foreVariable)
closeDialog()
doItAndPrint(paste("forecast.Arima(", model,",fore1=",fore1,
")", sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp()
nameFrame <- tkframe(top)
foreFrame <- tkframe(top)
foreVariable <- tclVar("1")
foreField <- tkentry(foreFrame, width="8", textvariable=foreVariable)
tkgrid(tklabel(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")),
tklabel(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
tkgrid(nameFrame, sticky="w", columnspan="2")
tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
tkgrid(tklabel(top,text=gettextRcmdr("New Data set name")),
entryDsname,sticky="e")
tkgrid(tklabel(foreFrame, text=gettextRcmdr("Number of Forecasts: ")), foreField, sticky="w")
tkgrid(foreFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
pow2 <- function(x,lam1=1) {
if(any(x)<=0)stop("Nonnegative values; transformation not possible")
y <- exp(lam1*log(x))
return(y)
}
decom5 <- function(x1,fore1=0,se1=1) {
#Changes made on 2/21/06
#Remove "its" section and remove options for irre.
#x1 is the original data series;
#fore1 is the number of forecast periods
#se1 is the annual frequency
n1 <- length(x1)
if(is.ts(x1) !=TRUE){
x <- ts(x1,start=1,frequency=1)
}
else {
x <- x1
}
f1 <- tsp(x)[3]
f21 <- f1
ck1 <- n1/f1
if(se1 != 1)f21 <- 1
#if(ck1 != floor(ck1))stop("Need exact values for a year")
if(fore1 < 0)stop("Forecast value must be positive")
if(fore1 > n1)stop("Forecast value must be less than series length")
#Now start the seasonal process
#This is NOT done for annual data
if(f21 == 1) {
y <- filter(x,rep(1,f1))/f1
z <- filter(y,rep(1,2))/2
xx <- as.vector(z)
z1 <- c(NA,xx[-n1])
w1 <- x/z1
#w2 <- matrix(w1,nrow=f1)
#w3 <- apply(w2,1,function(x)mean(x,na.rm=TRUE))
xw <- vector("list",f1)
for(i in 1:n1) {
j1 <- ifelse(i%%f1==0,f1,i%%f1)
xw[[j1]] <- c(xw[[j1]],w1[i])
}
w3 <- unlist(lapply(xw,function(x)mean(x,na.rm=TRUE)))
w4 <- sum(w3)/f1
w3 <- w3/w4
sea1 <- rep(w3,length=n1)
sea1 <- ts(sea1,start=start(x),frequency=f1)
ab <- f1 - start(x)[2] +2
sea2 <- sea1[ab:(ab+f1-1)]
dy <- x/sea1
}
else {
sea1 <- rep(1,length=n1)
sea2 <- 1
dy <- x
}
#Begin fitting the trend
t1 <- 1:n1
trend.lm <- lm(dy ~ t1)
trend.ts <- ts(trend.lm$fitted.values,start=start(x),frequency=f1)
print(trend.lm$coef)
#Obtain Final Fitted series
#2/05/2006
#Make adjustments to set up cycle and irregular as time series
yhat <- trend.ts*sea1
#We will get cyclical and irregular values
cr1 <- x/yhat
cy1 <- ts(as.vector(filter(cr1,rep(1,3))/3),start=start(x),frequency=f1)
ir1 <- cr1/cy1
#Calculate forecasts if needed
if(fore1 != 0) {
new1 <- data.frame(t1=(n1+1):(n1+fore1))
pred1 <- predict(trend.lm,newdata=new1,interval="prediction")
pred2 <- (pred1[,3] - pred1[,2])/2
xs1 <- sea1[1:fore1]
pred4 <- pred1[,1]*xs1
pred5 <- pred4 - pred2
pred6 <- pred4 + pred2
pred.df <- data.frame(pred=pred4,lower=pred5,upper=pred6)
print(pred.df)
return(data.frame(mult=pred.df$pred))
}
#x1 <- data.frame(x1,deas=dy,
# trend=trend.ts,seas=sea1,seay=sea2,cycle=cy1,irr=ir1)
return(data.frame(mult=pred.df$pred))
}
histprice2<- function(inst1,start1="1998-01-01",quot1="Close",end1) {
library(tseries)
z <- get.hist.quote(instrument=inst1, start=start1,end=end1,
quote=quot1,compression = "m")
y <- as.ts(aggregate(z, as.yearmon, tail, 1))
y.df <- data.frame(y=y,time=time(y))
y.df$x <- ts(y.df[,1])
tsp(y.df$x) <- tsp(y.df[,2])
names(y.df) <- c("data","time","ts")
z.df <- data.frame(ts=y.df$ts)
return(z.df)
}
foreMod <- function(){
initializeDialog(title=gettextRcmdr("Forecast Accuracy Results"))
.numeric <- Numeric()
xBox <- variableListBox(top, .numeric, title=gettextRcmdr("First variable (pick one)"))
yBox <- variableListBox(top, .numeric, title=gettextRcmdr("Second variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
y <- getSelection(yBox)
if (length(x) == 0 | length(y) == 0){
errorCondition(recall=foreMod, message=gettextRcmdr("You must select two variables."))
return()
}
if (x == y){
errorCondition(recall=foreMod, message=gettextRcmdr("Variables must be different."))
return()
}
closeDialog()
.activeDataSet <- ActiveDataSet()
doItAndPrint(paste("forerr(", .activeDataSet, "$", x, ", ",
.activeDataSet, "$", y,
")", sep=""))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t.test")
tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
garchMod <- function(){
initializeDialog(title=gettextRcmdr("GARCH Models"))
.activeModel <- ActiveModel()
currentModel <- if (!is.null(.activeModel))
eval(parse(text=paste("class(", .activeModel, ")[1] == 'garch'", sep="")),
envir=.GlobalEnv)
else FALSE
# if (currentModel) {
# currentFields <- formulaFields(eval(parse(text=.activeModel),
# envir=.GlobalEnv))
# if (currentFields$data != ActiveDataSet()) currentModel <- FALSE
# }
UpdateModelNumber()
modelName <- tclVar(paste("GARCHModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- tkentry(modelFrame, width="20", textvariable=modelName)
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=garchMod, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=garchMod, message=gettextRcmdr("You must select a variable."))
return()
}
AR1 <- tclvalue(ARLevel)
MA1 <- tclvalue(MAVariable)
closeDialog()
if (is.element(modelValue, listGARCHModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
garchMod()
return()
}
}
command <- paste("garch(", ActiveDataSet(), "$", x,",order=c(",AR1,",",MA1,"),
trace=F)"
,sep="")
logger(paste(modelValue, " <- ", command, sep=""))
assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
activeModel(modelValue)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="garch")
ARFrame <- tkframe(top)
ARLevel <- tclVar("0")
ARField <- tkentry(ARFrame, width="6", textvariable=ARLevel)
MAFrame <- tkframe(top)
MAVariable <- tclVar("0")
MAField <- tkentry(MAFrame, width="6", textvariable=MAVariable)
tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(top, text=""), sticky="w")
tkgrid(tklabel(ARFrame, text=gettextRcmdr("AR Order ")), ARField, sticky="w")
tkgrid(ARFrame, sticky="w")
tkgrid(tklabel(MAFrame, text=gettextRcmdr("MA Order")), MAField, sticky="w")
tkgrid(MAFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(ARField, sticky="e")
dialogSuffix(rows=6, columns=2)
}
tsConv <- function(){
initializeDialog(title=gettextRcmdr("Time Series Conversion"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=tsConv, message=gettextRcmdr("You must select a variable."))
return()
}
year1 <- tclvalue(yearVariable)
per1 <- tclvalue(perVariable)
freq1 <- tclvalue(freqVariable)
closeDialog()
comm1 <- paste(ActiveDataSet(),"$",x,sep="")
command <- paste("ts(", ActiveDataSet(), "$", x,",start=c(",year1,",",per1,"),frequency=",
freq1,")",sep="")
# logger(paste(comm1, " <- ", command, sep=""))
comm2 <- paste(comm1, " <- ", command, sep="")
# assign(comm1, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(comm2)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="ts")
yearFrame <- tkframe(top)
yearVariable <- tclVar("2000")
yearField <- tkentry(yearFrame, width="6", textvariable=yearVariable)
perFrame <- tkframe(top)
perVariable <- tclVar("1")
perField <- tkentry(perFrame, width="6", textvariable=perVariable)
freqFrame <- tkframe(top)
freqVariable <- tclVar("1")
freqField <- tkentry(freqFrame, width="6", textvariable=freqVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(yearFrame, text=gettextRcmdr("Starting Year: ")), yearField, sticky="w")
tkgrid(yearFrame, sticky="w")
tkgrid(tklabel(perFrame, text=gettextRcmdr("Starting Period: ")), perField, sticky="w")
tkgrid(perFrame, sticky="w")
tkgrid(tklabel(freqFrame, text=gettextRcmdr("Freq: ")), freqField, sticky="w")
tkgrid(freqFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(yearField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
decom6 <- function(x1,fore1=0,se1=1) {
#Additive decomposition pgs 338 - 340
#Bowerman O'Connell Koehler
#x1 is the original data series;
#fore1 is the number of forecast periods
#se1 is the annual frequency
n1 <- length(x1)
if(is.ts(x1) !=TRUE){
x <- ts(x1,start=1,frequency=1)
}
else {
x <- x1
}
f1 <- tsp(x)[3]
f21 <- f1
ck1 <- n1/f1
if(se1 != 1)f21 <- 1
#if(ck1 != floor(ck1))stop("Need exact values for a year")
if(fore1 < 0)stop("Forecast value must be positive")
if(fore1 > n1)stop("Forecast value must be less than series length")
#Now start the seasonal process
#This is NOT done for annual data
if(f21 == 1) {
y <- filter(x,rep(1,f1))/f1
z <- filter(y,rep(1,2))/2
xx <- as.vector(z)
z1 <- c(NA,xx[-n1])
w1 <- x/z1
#w2 <- matrix(w1,nrow=f1)
#w3 <- apply(w2,1,function(x)mean(x,na.rm=TRUE))
xw <- vector("list",f1)
for(i in 1:n1) {
j1 <- ifelse(i%%f1==0,f1,i%%f1)
xw[[j1]] <- c(xw[[j1]],w1[i])
}
w3 <- unlist(lapply(xw,function(x)mean(x,na.rm=TRUE)))
w4 <- sum(w3)/f1
w3 <- w3/w4
sea1 <- rep(w3,length=n1)
sea1 <- ts(sea1,start=start(x),frequency=f1)
ab <- f1 - start(x)[2] +2
sea2 <- sea1[ab:(ab+f1-1)]
dy <- x-sea1
}
else {
sea1 <- rep(0,length=n1)
sea2 <- 0
dy <- x
}
#Begin fitting the trend
t1 <- 1:n1
trend.lm <- lm(dy ~ t1)
trend.ts <- ts(trend.lm$fitted.values,start=start(x),frequency=f1)
print(trend.lm$coef)
#Obtain Final Fitted series
#2/05/2006
#Make adjustments to set up cycle and irregular as time series
yhat <- trend.ts+sea1
#We will get cyclical and irregular values
cr1 <- x-yhat
cy1 <- ts(as.vector(filter(cr1,rep(1,3))/3),start=start(x),frequency=f1)
ir1 <- cr1-cy1
#Calculate forecasts if needed
if(fore1 != 0) {
new1 <- data.frame(t1=(n1+1):(n1+fore1))
pred1 <- predict(trend.lm,newdata=new1,interval="prediction")
pred2 <- (pred1[,3] - pred1[,2])/2
xs1 <- sea1[1:fore1]
pred4 <- pred1[,1]+xs1
pred5 <- pred4 - pred2
pred6 <- pred4 + pred2
pred.df <- data.frame(pred=pred4,lower=pred5,upper=pred6)
print(pred.df)
return(data.frame(add=pred.df$pred))
}
#x1 <- data.frame(x1,deas=dy,
# trend=trend.ts,seas=sea1,seay=sea2,cycle=cy1,irr=ir1)
return(data.frame(add=pred.df$pred))
}
decomaMod <- function(){
initializeDialog(title=gettextRcmdr("Additive Decomposition"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=decomaMod, message=gettextRcmdr("You must select a variable."))
return()
}
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=decomaMod,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
return()
}
freq1 <- tclvalue(freqVariable)
fore1 <- tclvalue(foreVariable)
closeDialog()
comm1 <- paste(dsnameValue,"<-decom6(", ActiveDataSet(), "$", x,
",se1=",freq1,",fore1=",fore1,
")", sep="")
doItAndPrint(comm1)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t.test")
freqFrame <- tkframe(top)
freqVariable <- tclVar("1")
freqField <- tkentry(freqFrame, width="6", textvariable=freqVariable)
foreFrame <- tkframe(top)
foreVariable <- tclVar("0")
foreField <- tkentry(foreFrame, width="8", textvariable=foreVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(foreFrame, text=gettextRcmdr("Number of Forecasts: ")), foreField, sticky="w")
tkgrid(foreFrame, sticky="w")
tkgrid(tklabel(freqFrame, text=gettextRcmdr("Freq: ")), freqField, sticky="w")
tkgrid(freqFrame, sticky="w")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid.configure(entryDsname, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(freqField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
hwseasMod <- function(){
initializeDialog(title=gettextRcmdr("Seasonal Holt Winters Filter"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=bcMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("HoltWinters(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="HoltWinters")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
hwnonseasMod <- function(){
initializeDialog(title=gettextRcmdr("Non-Seasonal Holt Winters Filter"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=bcMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("HoltWinters(", ActiveDataSet(), "$", x,",gamma=0)",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="HoltWinters")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
hwexpoMod <- function(){
initializeDialog(title=gettextRcmdr("Exponential Smoothing"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=bcMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("HoltWinters(", ActiveDataSet(), "$", x,",gamma=0,beta=0)",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="HoltWinters")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
HoltWintersMod <- function(){
initializeDialog(title=gettextRcmdr("Seasonal HoltWinters Models"))
.activeModel <- ActiveModel()
print(.activeModel)
currentModel <- if (!is.null(.activeModel))
eval(parse(text=paste("class(", .activeModel, ")[1] == 'HoltWinters'", sep="")),
envir=.GlobalEnv)
else FALSE
UpdateModelNumber()
modelName <- tclVar(paste("HoltWintersModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- tkentry(modelFrame, width="20", textvariable=modelName)
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=HoltWintersMod, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=HoltWintersMod, message=gettextRcmdr("You must select a variable."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
closeDialog()
if (is.element(modelValue, listHoltWintersModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
HoltWintersMod
return()
}
}
pd1 <- paste("tsp(",ActiveDataSet(),"$",x,")[3]",sep="")
assign("pd2",justDoIt(pd1),envir=.GlobalEnv)
sea2 <- as.character(ifelse(alternative==1,"add","mult"))
command <- paste("HoltWinters(", ActiveDataSet(), "$", x,",
seasonal='", alternative, "')", sep="")
logger(paste(modelValue, " <- ", command, sep=""))
assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(modelValue)
activeModel(modelValue)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="HoltWinters")
radioButtons(top, name="alternative", buttons=c("yes","no"), values=c("add","mult"),
labels=gettextRcmdr(c("Additive", "Multiplicative")),
title=gettextRcmdr("Seasonal Coefficients"))
rightFrame <- tkframe(top)
tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(rightFrame, text=""), sticky="w")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=6, columns=2)
}
listHoltWintersModels <- function(envir=.GlobalEnv, ...) {
objects <- ls(envir=envir, ...)
if (length(objects) == 0) NULL
else objects[sapply(objects,
function(.x) "HoltWinters" == (class(eval(parse(text=.x), envir=envir))[1]))]
}
HoltWintersNonMod <- function(){
initializeDialog(title=gettextRcmdr("HoltWinters NonSeasonal Models"))
.activeModel <- ActiveModel()
print(.activeModel)
currentModel <- if (!is.null(.activeModel))
eval(parse(text=paste("class(", .activeModel, ")[1] == 'HoltWinters'", sep="")),
envir=.GlobalEnv)
else FALSE
UpdateModelNumber()
modelName <- tclVar(paste("HoltWintersModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- tkentry(modelFrame, width="20", textvariable=modelName)
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=HoltWintersMod, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=HoltWintersMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
if (is.element(modelValue, listHoltWintersModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
HoltWintersMod
return()
}
}
command <- paste("HoltWinters(", ActiveDataSet(), "$", x,",
gamma=0)", sep="")
logger(paste(modelValue, " <- ", command, sep=""))
assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(modelValue)
activeModel(modelValue)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="HoltWinters")
rightFrame <- tkframe(top)
tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(rightFrame, text=""), sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=6, columns=2)
}
HoltWintersExpoMod <- function(){
initializeDialog(title=gettextRcmdr("Exponential Smoothing Models"))
.activeModel <- ActiveModel()
print(.activeModel)
currentModel <- if (!is.null(.activeModel))
eval(parse(text=paste("class(", .activeModel, ")[1] == 'HoltWinters'", sep="")),
envir=.GlobalEnv)
else FALSE
UpdateModelNumber()
modelName <- tclVar(paste("HoltWintersModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- tkentry(modelFrame, width="20", textvariable=modelName)
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=HoltWintersMod, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=HoltWintersMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
if (is.element(modelValue, listHoltWintersModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
HoltWintersMod
return()
}
}
command <- paste("HoltWinters(", ActiveDataSet(), "$", x,",
gamma=0,beta=0)", sep="")
logger(paste(modelValue, " <- ", command, sep=""))
assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(modelValue)
activeModel(modelValue)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="HoltWinters")
rightFrame <- tkframe(top)
tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(rightFrame, text=""), sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=6, columns=2)
}
predar3 <- function(x,fore1=1) {
z <- forecast.Arima(x,h=fore1)
zlow <- z$lower
zup <- z$upper
zz <- data.frame(pred=z$mean,lower=zlow,upper=zup)
plot(z)
return(as.data.frame(zz$pred))
}
predhw <- function(x,fore1=1) {
z <- predict(x,prediction.interval=TRUE,n.ahead=fore1)
print(z)
return(as.data.frame(z[,1]))
}
predAllModel <- function(){
models <- listAllModels()
.activeModel <- ActiveModel()
if ((length(models) == 1) && !is.null(.activeModel)) {
Message(message=gettextRcmdr("There is only one model in memory."),
type="warning")
tkfocus(CommanderWindow())
return()
}
if (length(models) == 0){
Message(message=gettextRcmdr("There are no models from which to choose."),
type="error")
tkfocus(CommanderWindow())
return()
}
initializeDialog(title=gettextRcmdr("Forecasting"))
.activeDataSet <- ActiveDataSet()
initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"),
initialSelection=initial)
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
model <- getSelection(modelsBox)
closeDialog()
if (length(model) == 0) {
tkfocus(CommanderWindow())
return()
}
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=editTSframe,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
return()
}
activeModel(model)
fore1 <- tclvalue(foreVariable)
closeDialog()
if( eval(parse(text=paste("class(", model, ")[1] == 'HoltWinters'", sep="")),
envir=.GlobalEnv)) {
comm1 <- paste(dsnameValue, " <- predhw(", model,",fore1=",fore1,
")", sep="")
doItAndPrint(comm1)
}
else {
comm1 <- paste(dsnameValue, " <- predar3(", model,",fore1=",fore1,
")", sep="")
doItAndPrint(comm1)
}
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp()
nameFrame <- tkframe(top)
foreFrame <- tkframe(top)
foreVariable <- tclVar("1")
foreField <- tkentry(foreFrame, width="8", textvariable=foreVariable)
tkgrid(tklabel(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")),
tklabel(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
tkgrid(nameFrame, sticky="w", columnspan="2")
tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
tkgrid(tklabel(foreFrame, text=gettextRcmdr("Number of Forecasts: ")), foreField, sticky="w")
tkgrid(foreFrame, sticky="w")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid.configure(entryDsname, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
fixa <- function(x)
{
tsa <- tsp(x[,1])
y <- edit(as.matrix(x))
y <- data.frame(y)
for(i in 1:ncol(y)) {
y[,i] <- ts(y[,i],start=tsa[1],frequency=tsa[3])
}
return(y)
}
editTSframe <- function() {
initializeDialog(title=gettextRcmdr("Edit TS Data"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=editTSframe,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
}
command <- paste('fixa(',dsnameValue,')',sep="")
assign(dsnameValue, justDoIt(command), envir=.GlobalEnv)
logger(paste(dsnameValue, "<-", command))
if (eval(parse(text=paste("nrow(", dsnameValue, ")"))) == 0){
errorCondition(recall=editTSframe, message=gettextRcmdr("empty data set."))
return()
}
activeDataSet(dsnameValue)
closeDialog()
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="edit")
rightFrame <- tkframe(top)
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid(buttonsFrame, columnspan="2", sticky="w")
tkgrid.configure(entryDsname, sticky="w")
dialogSuffix(rows=10, columns=2, focus=entryDsname)
}
bulkfit <- function(x) {
w <- matrix(0,nrow=27,ncol=4)
ii <- 0
for(i in 0:2) {
for(k in 0:2) {
for(j in 0:2) {
ii <- ii + 1
fit <- try(arima(x,order=c(i,k,j)),silent=TRUE)
if(inherits(fit,"try-error")) {
w[ii,4] <- 99999
}
else {
w[ii,4] <- fit$aic
w[ii,1] <- i
w[ii,2] <- k
w[ii,3] <- j
}
}
}
}
dimnames(w) <- list(NULL,c("ar","d","ma","AIC"))
xxx <- which(w[,4]==min(w[,4]))[1]
return(list(res=w,min=w[xxx,]))
}
decomModcom <- function(){
initializeDialog(title=gettextRcmdr("Decomposition: Both Versions"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=decomModcom, message=gettextRcmdr("You must select a variable."))
return()
}
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=editTSframe,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
return()
}
freq1 <- tclvalue(freqVariable)
fore1 <- tclvalue(foreVariable)
closeDialog()
command <- print("Multiplicative")
logger(command)
comm1 <- paste(".One <-decom5(", ActiveDataSet(), "$", x,
",se1=",freq1,",fore1=",fore1,
")", sep="")
doItAndPrint(comm1)
command <- print("Additive")
logger(command)
comm1 <- paste(".Two <-decom6(", ActiveDataSet(), "$", x,
",se1=",freq1,",fore1=",fore1,
")", sep="")
doItAndPrint(comm1)
comm2 <- paste(dsnameValue,"<-cbind(.One,.Two)",sep="")
doItAndPrint(comm2)
rm(.One,.Two)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t.test")
freqFrame <- tkframe(top)
freqVariable <- tclVar("1")
freqField <- tkentry(freqFrame, width="6", textvariable=freqVariable)
foreFrame <- tkframe(top)
foreVariable <- tclVar("0")
foreField <- tkentry(foreFrame, width="8", textvariable=foreVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(foreFrame, text=gettextRcmdr("Number of Forecasts: ")), foreField, sticky="w")
tkgrid(foreFrame, sticky="w")
tkgrid(tklabel(freqFrame, text=gettextRcmdr("Freq: ")), freqField, sticky="w")
tkgrid(freqFrame, sticky="w")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid.configure(entryDsname, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(freqField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
runbulk <- function(){
initializeDialog(title=gettextRcmdr("Run Multiple ARIMA models"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=runbulk, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("bulkfit(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="arima")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
runbulkg <- function(){
initializeDialog(title=gettextRcmdr("Run Multiple GARCH models"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=runbulkg, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("bulkfitg(", ActiveDataSet(), "$", x,")",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="garch")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
bulkfitg <- function(x) {
w <- matrix(0,nrow=8,ncol=3)
oldopts <- options()
options(show.error.messages=FALSE)
ii <- 0
for(i in 0:2) {
for(j in 0:2) {
if(i==0 & j==0)next()
ii <- ii + 1
cat(i,j,ii,"\n")
fit <- try(garch(x,order=c(i,j)),silent=TRUE)
if(inherits(fit,"try-error")) {
w[ii,3] <- 99999
}
else {
if(any(is.nan(fit[[5]])))w[ii,3] <- 99999
else {
w[ii,3] <- AIC(fit)
w[ii,1] <- i
w[ii,2] <- j
}
}
}
}
dimnames(w) <- list(NULL,c("ar","ma","AIC"))
xxx <- which(w[,3]==min(w[,3]))[1]
options(oldopts)
return(list(res=w,min=w[xxx,]))
}
mse1 <- function(x,y) {
n1 <- length(x)
z <- sum((x-y)^2)/n1
return(z)
}
mad1 <- function(x,y) {
n1 <- length(x)
z <- sum(abs(x-y))/n1
return(z)
}
fore1 <- function(x,w,y) {
z <- which(names(y) == as.character(x))
u <- y[,-z,drop=FALSE]
print("MSE")
a <- apply(u,2,mse1,y=w)
print(a)
print("MAD")
b <- apply(u,2,mad1,y=w)
print(b)
return(data.frame(mse=a,mad=b))
}
forebMod <- function(){
initializeDialog(title=gettextRcmdr("Multiple Forecast Accuracy Results"))
.numeric <- Numeric()
xBox <- variableListBox(top, .numeric, title=gettextRcmdr("First variable (pick one)"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=forebMod, message=gettextRcmdr("You must select a variable."))
}
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=editTSframe,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
return()
}
closeDialog()
.activeDataSet <- ActiveDataSet()
x1 <- as.character(x)
# doItAndPrint(paste("forerr(", .activeDataSet, "$", x, ", ",
# .activeDataSet, "$", y,
# ")", sep=""))
comm1 <- paste(dsnameValue, "<- fore1('",x1,"',", ActiveDataSet(), "$", x, ", ",ActiveDataSet(),
")", sep="")
doItAndPrint(comm1)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t.test")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid.configure(entryDsname, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
subMod <- function(){
initializeDialog(title=gettextRcmdr("Plot Plus Subset"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
print(x)
if (length(x) == 0){
errorCondition(recall=subMod, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
doItAndPrint(paste("ts.plot(", ActiveDataSet(), "$", x,")",sep=""))
comm1 <- paste("plotsub(", ActiveDataSet(), "$", x,
")", sep="")
doItAndPrint(comm1)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="ts.plot")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
plotsub <- function(x) {
plot(x)
z <- locator(2)
plot(window(x,start=min(z$x),end=max(z$x)))
}
aggConv <- function(){
initializeDialog(title=gettextRcmdr("Low Frequency Aggregation"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
dsname <- tclVar(gettextRcmdr("Dataset"))
entryDsname <- tkentry(top, width="20", textvariable=dsname)
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=aggConv, message=gettextRcmdr("You must select a variable."))
return()
}
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=aggConv,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet()
return()
}
}
alternative <- as.character(tclvalue(alternativeVariable))
alternativea <- as.character(tclvalue(alternativeaVariable))
alt1 <- paste("",alternative,"",sep="")
alt2 <- paste("",alternativea,"",sep="")
closeDialog()
comma <- paste(ActiveDataSet(),"$",x,sep="")
comm3 <- paste("ep <- endpoints(",comma,",on='",alt2,"')",sep="")
doItAndPrint(comm3)
# logger(paste(comm1, " <- ", command, sep=""))
comm2 <- paste(dsnameValue, " <- data.frame(ts=period.apply(as.xts(", comma,"),ep,",alt1,"))", sep="")
comm4 <- paste(".One <- period.apply(as.xts(", comma,"),ep,",alt1,")", sep="")
doItAndPrint(comm4)
comm5 <- paste(dsnameValue, "<- data.frame(x=1:(length(ep)-1))",sep="")
doItAndPrint(comm5)
comm6 <- paste(dsnameValue,"$x <- zoo(.One)",sep="")
doItAndPrint(comm6)
# assign(comm1, justDoIt(command), envir=.GlobalEnv)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="period.apply")
radioButtons(top, name="alternative", buttons=c("Sum", "Mean","Min","Max"),
values=c("sum", "mean","min","max"),
labels=gettextRcmdr(c("Sum", "Mean",
"Minimum","Maximum")),
title=gettextRcmdr("Aggregation Options"))
rightFrame <- tkframe(top)
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
radioButtons(top, name="alternativea", buttons=c("Months", "Quarters","Years"),
values=c("months", "quarters","years"),
labels=gettextRcmdr(c("Months",
"Quarters","Years")),
title=gettextRcmdr("Time Options"))
rightFrame1 <- tkframe(top)
tkgrid(alternativeaFrame, rightFrame1, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
ArimaModIn <- function(){
initializeDialog(title=gettextRcmdr("Interactive ARIMA Models"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=ArimaModIn, message=gettextRcmdr("You must select a variable."))
return()
}
AR1 <- tclvalue(ARLevel)
MA1 <- tclvalue(MAVariable)
DIF1 <- tclvalue(DIFVariable)
SAR1 <- tclvalue(SARLevel)
SMA1 <- tclvalue(SMAVariable)
SDIF1 <- tclvalue(SDIFVariable)
alternative <- as.character(tclvalue(alternativeVariable))
closeDialog()
pd1 <- paste("tsp(",ActiveDataSet(),"$",x,")[3]",sep="")
assign("pd2",justDoIt(pd1),envir=.GlobalEnv)
command <- paste("fit <- arima(", ActiveDataSet(), "$", x,",order=c(",AR1,",",DIF1,",",MA1,"),
include.mean=",alternative,",seasonal=list(order=c(",SAR1,",",SDIF1,",",SMA1
,"),period=",pd2,"))",sep="")
#doItAndPrint(paste("ts.plot(", ActiveDataSet(), "$", x,")",sep=""))
doItAndPrint(paste("fit1 <- predict(fit,n.ahead=7)",sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="arima")
radioButtons(top, name="alternative", buttons=c("yes","no"), values=c(TRUE,FALSE),
labels=gettextRcmdr(c("Mean Included","Mean Not Included")),
title=gettextRcmdr("Mean"))
rightFrame <- tkframe(top)
ARFrame <- tkframe(rightFrame)
ARLevel <- tclVar("0")
ARField <- tkentry(ARFrame, width="6", textvariable=ARLevel)
MAFrame <- tkframe(rightFrame)
MAVariable <- tclVar("0")
MAField <- tkentry(MAFrame, width="6", textvariable=MAVariable)
DIFFrame <- tkframe(rightFrame)
DIFVariable <- tclVar("0")
DIFField <- tkentry(DIFFrame,width="6",textvariable=DIFVariable)
SARFrame <- tkframe(rightFrame)
SARLevel <- tclVar("0")
SARField <- tkentry(SARFrame, width="6", textvariable=SARLevel)
SMAFrame <- tkframe(rightFrame)
SMAVariable <- tclVar("0")
SMAField <- tkentry(SMAFrame, width="6", textvariable=SMAVariable)
SDIFFrame <- tkframe(rightFrame)
SDIFVariable <- tclVar("0")
SDIFField <- tkentry(SDIFFrame,width="6",textvariable=SDIFVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(tklabel(rightFrame, text=""), sticky="w")
tkgrid(tklabel(ARFrame, text=gettextRcmdr("Reg. AR Order ")), ARField, sticky="w")
tkgrid(ARFrame, sticky="w")
tkgrid(tklabel(DIFFrame,text=gettextRcmdr("Reg. Diff Order ")),DIFField, sticky="w")
tkgrid(DIFFrame,sticky="w")
tkgrid(tklabel(MAFrame, text=gettextRcmdr("Reg. MA Order")), MAField, sticky="w")
tkgrid(MAFrame, sticky="w")
tkgrid(tklabel(SARFrame, text=gettextRcmdr("Sea. AR Order ")), SARField, sticky="w")
tkgrid(SARFrame, sticky="w")
tkgrid(tklabel(SDIFFrame,text=gettextRcmdr("Sea. Diff Order ")),SDIFField, sticky="w")
tkgrid(SDIFFrame,sticky="w")
tkgrid(tklabel(SMAFrame, text=gettextRcmdr("Sea. MA Order")), SMAField, sticky="w")
tkgrid(SMAFrame, sticky="w")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(ARField, sticky="e")
dialogSuffix(rows=6, columns=2)
}
foreAllModel <- function(){
models <- listAllModels()
.activeModel <- ActiveModel()
if ((length(models) == 1) && !is.null(.activeModel)) {
Message(message=gettextRcmdr("There is only one model in memory."),
type="warning")
tkfocus(CommanderWindow())
return()
}
if (length(models) == 0){
Message(message=gettextRcmdr("There are no models from which to choose."),
type="error")
tkfocus(CommanderWindow())
return()
}
initializeDialog(title=gettextRcmdr("Plotting Forecasts"))
.activeDataSet <- ActiveDataSet()
initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"),
initialSelection=initial)
onOK <- function(){
model <- getSelection(modelsBox)
closeDialog()
if (length(model) == 0) {
tkfocus(CommanderWindow())
return()
}
activeModel(model)
comm1 <- paste("plot.forecast(", model,")", sep="")
doItAndPrint(comm1)
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp()
nameFrame <- tkframe(top)
tkgrid(tklabel(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")),
tklabel(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
tkgrid(nameFrame, sticky="w", columnspan="2")
tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=3, columns=2)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.