inst/Rcmdr/Rcmdr-urca.R

In urca: Unit Root and Cointegration Tests for Time Series Data

library(urca)
#
# ADF-test
#
urcadf <- function(){
  if (!checkActiveDataSet()) return()
  if (!checkNumeric(n=1)) return()
  initializeDialog(title="ADF Test")
  xBox <- variableListBox(top, Numeric(), title="Variable (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    var <- paste(.activeDataSet, "$", x, sep="")
    ttype <- tclvalue(testtypeVariable)
    lags <- tclvalue(lagsVariable)
    if (length(x) == 0){
      errorCondition(recall=urcadf, message="You must select a variable.")
      return()
      }
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(ur.df(y= ", var, ", type = ", ttype, ", lags = ",  lags, "))", sep=""))
    tkdestroy(top)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ur.df")
  radioButtons(name="testtype", buttons=c("none", "drift", "trend"), values=c("'none'", "'drift'", "'trend'" ), labels=c("no deterministic regressor", "drift only", "drift and trend"), title="Type of test")
  rightFrame <- tkframe(top)
  lagsFrame <- tkframe(rightFrame)
  lagsVariable <- tclVar("4")
  lagsField <- tkentry(lagsFrame, width="2", textvariable=lagsVariable)
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(tklabel(rightFrame, text=""))
  tkgrid(tklabel(lagsFrame, text="Maximum number of lags = ", fg="blue"), lagsField, sticky="w")
  tkgrid(lagsFrame, sticky="w")
  tkgrid(testtypeFrame, rightFrame, sticky="nw")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  tkgrid.configure(lagsField, sticky="e")
  dialogSuffix(rows=4, columns=2)
}
#
# ERS-test
#
urcaers <- function(){
  if (!checkActiveDataSet()) return()
  if (!checkNumeric(n=1)) return()
  initializeDialog(title="ERS Test")
  xBox <- variableListBox(top, Numeric(), title="Variable (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    var <- paste(.activeDataSet, "$", x, sep="")
    ttype <- tclvalue(testtypeVariable)
    modtype <- tclvalue(modelVariable)
    lags <- tclvalue(lagsVariable)
    if (length(x) == 0){
      errorCondition(recall=urcaers, message="You must select a variable.")
      return()
      }
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(ur.ers(y= ", var, ", type = ", ttype, ", model = ", modtype, ", lag.max = ",  lags, "))", sep=""))
    tkdestroy(top)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ur.ers")
  radioButtons(name="testtype", buttons=c("DFGLS", "Ptest"), values=c("'DF-GLS'", "'P-test'"), 
               labels=c("DF-GLS statistic", "P-test statistic"), title="Type of test")
  radioButtons(name="model", buttons=c("const", "trend"), values=c("'constant'", "'trend'"), 
               labels=c("Include constant", "Include constant + trend"), title="Model type")
  rightFrame <- tkframe(top)
  lagsFrame <- tkframe(rightFrame)
  lagsVariable <- tclVar("4")
  lagsField <- tkentry(lagsFrame, width="2", textvariable=lagsVariable)
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(tklabel(rightFrame, text=""))
  tkgrid(tklabel(lagsFrame, text="Maximum number of lags = ", fg="blue"), lagsField, sticky="w")
  tkgrid(lagsFrame, sticky="w")
  tkgrid(testtypeFrame, rightFrame, sticky="nw")
  tkgrid(modelFrame, rightFrame, sticky="nw")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  tkgrid.configure(lagsField, sticky="e")
  dialogSuffix(rows=4, columns=2)
}
#
# KPSS-test
#
urcakpss <- function(){
  if (!checkActiveDataSet()) return()
  if (!checkNumeric(n=1)) return()
  initializeDialog(title="KPSS Test")
  xBox <- variableListBox(top, Numeric(), title="Variable (pick one)")
  radioButtons(name="testtype", buttons=c("constant", "trend"), 
        values=c("'mu'", "'tau'"), initialValue="'mu'", 
        labels=c("Include constant", "Include trend"), title="Deterministic Part")
  radioButtons(name="lags", buttons=c("short", "long", "nil"), 
        values=c("'short'", "'long'", "'nil'"), initialValue="'short'",         labels=c("use short lags", "use long lags", "use no lags"), title="Lag Selection")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcakpss, message="You must select a variable.")
      return()
    }
    var <- paste(.activeDataSet, "$", x, sep="")
    ttype <- tclvalue(testtypeVariable)
    ltype <- tclvalue(lagsVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    command <- paste("summary(ur.kpss(", var, ", type = ", ttype, ", lags = ", ltype, "))", sep="")
    doItAndPrint(command)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ur.kpss")
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(testtypeFrame, lagsFrame,  sticky="w")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  dialogSuffix(rows=3, columns=2)
}
#
# Schmidt-Phillips test
#
urcasp <- function(){
  if (!checkActiveDataSet()) return()
  if (!checkNumeric(n=1)) return()
  initializeDialog(title="SP Test")
  xBox <- variableListBox(top, Numeric(), title="Variable (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    var <- paste(.activeDataSet, "$", x, sep="")
    ttype <- tclvalue(testtypeVariable)
    pdtype <- tclvalue(poldegVariable)
    sltype <- tclvalue(signifVariable)
    if (length(x) == 0){
      errorCondition(recall=urcasp, message="You must select a variable.")
      return()
      }
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(ur.sp(y= ", var, ", type = ", ttype, ", pol.deg = ", pdtype, ", signif = ",  sltype, "))", sep=""))
    tkdestroy(top)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ur.sp")
  radioButtons(name="testtype", buttons=c("tau", "rho"), values=c("'tau'", "'rho'"), 
               labels=c("tau statistic", "rho statistic"), title="Type of test")
  radioButtons(name="poldeg", buttons=c("pb1", "pb2", "pb3", "pb4"), values=c("1", "2", "3", "4"), 
               labels=c("1st", "2nd", "3rd", "4th"), title="Select pol. degree")
  radioButtons(name="signif", buttons=c("sb1", "sb5", "sb10"), values=c("0.01", "0.05", "0.1"), 
               labels=c("alpha=1%", "alpha=5%", "alpha=10%"), title="Sig. Level")
  tkgrid(getFrame(xBox), testtypeFrame, sticky="nw")
  tkgrid(poldegFrame, signifFrame, sticky="nw")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  dialogSuffix(rows=4, columns=2)
}
#
# Phillips-Perron test
#
urcapp <- function(){
  if (!checkActiveDataSet()) return()
  if (!checkNumeric(n=1)) return()
  initializeDialog(title="PP Test")
  xBox <- variableListBox(top, Numeric(), title="Variable (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    var <- paste(.activeDataSet, "$", x, sep="")
    ttype <- tclvalue(testtypeVariable)
    modtype <- tclvalue(modelVariable)
    lagtype <- tclvalue(lagsVariable)
    if (length(x) == 0){
      errorCondition(recall=urcapp, message="You must select a variable.")
      return()
      }
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(ur.pp(x= ", var, ", type = ", ttype, ", model = ", modtype, ", lags = ",  lagtype, "))", sep=""))
    tkdestroy(top)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ur.pp")
  radioButtons(name="testtype", buttons=c("Zalpha", "Ztau"), values=c("'Z-alpha'", "'Z-tau'"), 
               labels=c("Z-alpha statistic", "Z-tau statistic"), title="Type of test")
  radioButtons(name="model", buttons=c("const", "trend"), values=c("'constant'", "'trend'"), 
               labels=c("Include constant", "include constant + trend"), title="Model type")
  radioButtons(name="lags", buttons=c("short", "long"), values=c("'short'", "'long'"), 
               labels=c("short lags", "long lags"), title="Lags for error correction")
  tkgrid(getFrame(xBox), testtypeFrame, sticky="nw")
  tkgrid(modelFrame, lagsFrame, sticky="nw")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  dialogSuffix(rows=4, columns=2)
}
#
# Zivot-Andrews test
#
urcaza <- function(){
  if (!checkActiveDataSet()) return()
  if (!checkNumeric(n=1)) return()
  initializeDialog(title="Zivot & Andrews Test")
  xBox <- variableListBox(top, Numeric(), title="Variable (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    var <- paste(.activeDataSet, "$", x, sep="")
    modtype <- tclvalue(modelVariable)
    lags <- tclvalue(lagsVariable)
    ptype <- if(tclvalue(plotVariable) == 0) "FALSE" else "TRUE"
    if (length(x) == 0){
      errorCondition(recall=urcaza, message="You must select a variable.")
      return()
      }
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    command <- paste("ur.za(y= ", var, ",  model = ", modtype, ", lag = ",  lags, ")", sep="")
    logger(paste("ZAstat <- ", command, sep=""))
    assign("ZAstat", justDoIt(command), envir=.GlobalEnv)
    doItAndPrint("summary(ZAstat)")
    if(ptype==TRUE) {
      justDoIt("x11()")
      justDoIt("plot(ZAstat)")
    }
    logger("remove(ZAstat)") 
    remove(ZAstat, envir=.GlobalEnv)       
    tkdestroy(top)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ur.za")
  radioButtons(name="model", buttons=c("const", "trend", "both"), values=c("'intercept'", "'trend'", "'both'"), 
               labels=c("Include constant", "Include trend", "Include both"), title="Model type")
  checkBoxes(frame="plotFrame", boxes="plot", initialValues="0", labels="Plot path of Zivot & Andrews Statistic?")
  rightFrame <- tkframe(top)
  lagsFrame <- tkframe(rightFrame)
  lagsVariable <- tclVar("4")
  lagsField <- tkentry(lagsFrame, width="2", textvariable=lagsVariable)
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(tklabel(rightFrame, text=""))
  tkgrid(tklabel(lagsFrame, text="Maximum number of lags = ", fg="blue"), lagsField, sticky="w")
  tkgrid(lagsFrame, sticky="w")
  tkgrid(modelFrame, rightFrame, sticky="nw")
  tkgrid(plotFrame, sticky="nw")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  tkgrid.configure(lagsField, sticky="e")
  dialogSuffix(rows=3, columns=2)
}
#
# Phillips-Ouliaris test
#
urcacapo <- function(){
  dataSets <- listDataSets()
  if (length(dataSets) == 0){
    tkmessageBox(message="There are no data sets from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Phillips & Ouliaris Test")
  xBox <- variableListBox(top, dataSets, title="Data Sets (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcacapo, message="You must select a data set.")
      return()
    }
    meantype <- tclvalue(demeanVariable)
    lags <- tclvalue(lagsVariable)
    ttype <- tclvalue(typeVariable)
    tolvar <- tclvalue(tolVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(ca.po(z = ", x, ",  demean = ", meantype, ", lag = ",  lags, ", type = ", ttype, ", tol = ", tolvar, "))", sep=""))
    tkdestroy(top)
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ca.po")
  radioButtons(name="demean", buttons=c("none", "constant", "trend"), values=c("'none'", "'constant'", "'trend'"), 
               labels=c("None", "Include constant", "Include trend"), title="Demean?")
  radioButtons(name="lags", buttons=c("short", "long"), values=c("'short'", "'long'"), 
               labels=c("short lags", "long lags"), title="Lags for error correction")
  radioButtons(name="type", buttons=c("Pu", "Pz"), values=c("'Pu'", "'Pz'"), 
               labels=c("Pu statistic", "Pz statistic"), title="Type of test")
  rightFrame <- tkframe(top)
  tolFrame <- tkframe(rightFrame)
  tolVariable <- tclVar("NULL")
  tolField <- tkentry(tolFrame, width="8", textvariable=tolVariable)
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(tklabel(rightFrame, text=""))
  tkgrid(tklabel(tolFrame, text="Tolerance level =  ", fg="blue"), tolField, sticky="w")
  tkgrid(tolFrame, sticky="w")
  tkgrid(demeanFrame, rightFrame, sticky="nw")
  tkgrid(lagsFrame, typeFrame, sticky="nw")
  tkgrid(buttonsFrame, columnspan=2, sticky="w")
  tkgrid.configure(tolField, sticky="e")
  dialogSuffix(rows=5, columns=2)
}
#
# Johansen-Procedure
#
urcacajo <- function(){
  dataSets <- listDataSets()
  if (length(dataSets) == 0){
    tkmessageBox(message="There are no data sets from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Johansen's Procedure")
  xBox <- variableListBox(top, dataSets, title="Data Sets (pick one)")
  assign("UpdateModelNumber", UpdateModelNumber() + 1, envir=.GlobalEnv)
  modelName <- tclVar(paste("VECMmodel.", UpdateModelNumber, sep=""))
  modelFrame <- tkframe(top)
  model <- tkentry(modelFrame, width="20", textvariable=modelName)
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcacajo, message="You must select a data set.")
      return()
    }
    ttype <- tclvalue(typeVariable)
    spect <- tclvalue(specVariable)
    ctype <- tclvalue(ecdetVariable)
    lags <- tclvalue(lagVariable)
    seas <- tclvalue(seasonVariable)
    dummy <- tclvalue(dumVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    modelValue <- tclvalue(modelName)
    if (!is.valid.name(modelValue)){
      assign("UpdateModelNumber", UpdateModelNumber() - 1, envir=.GlobalEnv)
      errorCondition(recall=urcacajo, message=paste('"', modelValue, '" is not a valid name.', sep=""))
      return()
    }
    if (is.element(modelValue, listVECMmodels())) {
      if ("no" == tclvalue(checkReplace(modelValue, type="Model"))){
        assign("UpdateModelNumber", UpdateModelNumber() - 1, envir=.GlobalEnv)
        if (GrabFocus()) tkgrab.release(top)
        tkdestroy(top)
        urcacajo()
        return()
      }
    }
    command <- paste("ca.jo(x = ", x, ",  type = ", ttype, ", ecdet = ",  ctype, ", K = ",
                     lags, ", spec = ", spect, ", season = ", seas, ", dumvar = ", dummy , ")", sep="")
    logger(paste(modelValue, " <- ", command, sep=""))
    assign(modelValue, justDoIt(command), envir=.GlobalEnv)
    doItAndPrint(paste("summary(", modelValue, ")", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ca.jo")
  radioButtons(name="type", buttons=c("eigen", "trace"), values=c("'eigen'", "'trace'"), 
               labels=c("Eigenvalue statistic", "Trace statistic"), title="Type of statistic")
  radioButtons(name="spec", buttons=c("long", "trans"), values=c("'longrun'", "'transitory'"), 
               labels=c("longrun specification", "transitory specification"), title="VECM specification")
  radioButtons(name="season", buttons=c("none", "monthly", "quarterly"), values=c("NULL", "12", "4"), 
               labels=c("None", "Monthly seasonality", "Quarterly seasonality"), title="Seasonality")
  radioButtons(name="ecdet", buttons=c("none", "const", "trend"), values=c("'none'", "'const'", "'trend'"), 
               labels=c("none", "constant", "trend"), title="Deterministic Variable in Cointegration") 
  rightFrame <- tkframe(top)
  lagFrame <- tkframe(rightFrame)
  lagVariable <- tclVar("2")
  lagField <- tkentry(lagFrame, width="2", textvariable=lagVariable)
  dumFrame <- tkframe(rightFrame)
  dumVariable <- tclVar("NULL")
  dumField <- tkentry(dumFrame, width="8", textvariable=dumVariable)
  tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
  tkgrid(modelFrame, sticky="w")
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(tklabel(rightFrame, text=""), sticky="w")
  tkgrid(tklabel(lagFrame, text="Lag order =  ", fg="blue"), lagField, sticky="w")
  tkgrid(lagFrame, sticky="w")
  tkgrid(tklabel(dumFrame, text="Matrix of dummy variables =  ", fg="blue"), dumField, sticky="w")
  tkgrid(dumFrame, sticky="w")
  tkgrid(typeFrame, rightFrame, sticky="nw")
  tkgrid(specFrame, seasonFrame, sticky="nw")
  tkgrid(ecdetFrame, rightFrame, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(lagField, sticky="e")
  tkgrid.configure(dumField, sticky="e")
  dialogSuffix(rows=8, columns=2)
}
#
# Linear Trend test
#
urcalttest <- function(){
  VECMmodels <- listVECMmodels()
  if (length(VECMmodels) == 0){
    tkmessageBox(message="There are no VECM models from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Linear Trend Test")
  xBox <- variableListBox(top, VECMmodels, title="VECM models (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcalttest, message="You must select a VECM model.")
      return()
    }
    rint <- tclvalue(rankVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("lttest(z = ", x, ", r = ", rint, ")", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="lttest")
  rankFrame <- tkframe(top)
  rankVariable <- tclVar("1")
  rankField <- tkentry(rankFrame, width="2", textvariable=rankVariable)
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(rankFrame, sticky="w")
  tkgrid(tklabel(rankFrame, text="Number of cointegrating relationships =  ", fg="blue"), rankField, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(rankField, sticky="e")
  dialogSuffix(rows=3, columns=2)
}
#
# Restrictions on Loading matrix
#
urcaalrtest <- function(){
  VECMmodels <- listVECMmodels()
  matrices <- listMatrix()
  if (length(VECMmodels) == 0){
    tkmessageBox(message="There are no VECM models from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  if (length(matrices) == 0){
    tkmessageBox(message="There are no restriction matrices defined from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Test Restrictions on Loading Vectors")
  xBox <- variableListBox(top, VECMmodels, title="VECM models (pick one)")
  yBox <- variableListBox(top, matrices, title="Restriction matrices (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcaalrtest, message="You must select a VECM model.")
      return()
    }
    y <- getSelection(yBox)
    if (length(y) == 0){
      errorCondition(recall=urcaalrtest, message="You must select a restriction matrix.")
      return()
    }
    rint <- tclvalue(rankVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(alrtest(z = ", x, ", A = ", y , ", r = ", rint, "))", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="alrtest")
  rankFrame <- tkframe(top)
  rankVariable <- tclVar("1")
  rankField <- tkentry(rankFrame, width="2", textvariable=rankVariable)
  tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
  tkgrid(rankFrame, sticky="w")
  tkgrid(tklabel(rankFrame, text="Number of cointegrating relationships =  ", fg="blue"), rankField, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(rankField, sticky="e")
  dialogSuffix(rows=3, columns=1)
}
#
# Restrictions on cointegration matrix
#
urcablrtest <- function(){
  VECMmodels <- listVECMmodels()
  matrices <- listMatrix()
  if (length(VECMmodels) == 0){
    tkmessageBox(message="There are no VECM models from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  if (length(matrices) == 0){
    tkmessageBox(message="There are no restriction matrices defined from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Test Restrictions on Cointegration Vectors")
  xBox <- variableListBox(top, VECMmodels, title="VECM models (pick one)")
  yBox <- variableListBox(top, matrices, title="Restriction matrices (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcaablrtest, message="You must select a VECM model.")
      return()
    }
    y <- getSelection(yBox)
    if (length(y) == 0){
      errorCondition(recall=urcaalrtest, message="You must select a restriction matrix.")
      return()
    }
    rint <- tclvalue(rankVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(blrtest(z = ", x, ", H = ", y , ", r = ", rint, "))", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="blrtest")
  rankFrame <- tkframe(top)
  rankVariable <- tclVar("1")
  rankField <- tkentry(rankFrame, width="2", textvariable=rankVariable)
  tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
  tkgrid(rankFrame, sticky="w")
  tkgrid(tklabel(rankFrame, text="Number of cointegrating relationships =  ", fg="blue"), rankField, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(rankField, sticky="e")
  dialogSuffix(rows=3, columns=1)
}
#
# Restrictions for partly known cointegrating vectors
#
urcabh5lrtest <- function(){
  VECMmodels <- listVECMmodels()
  matrices <- listMatrix()
  numerics <- listNumeric()
  elements <- c(matrices, numerics)
  if (length(VECMmodels) == 0){
    tkmessageBox(message="There are no VECM models from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  if (length(matrices) == 0){
    tkmessageBox(message="There are no restriction matrices defined from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Test validity of partly known cointegrating Vectors")
  xBox <- variableListBox(top, VECMmodels, title="VECM models (pick one)")
  yBox <- variableListBox(top, elements, title="Restriction matrices (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcabh5lrtest, message="You must select a VECM model.")
      return()
    }
    y <- getSelection(yBox)
    if (length(y) == 0){
      errorCondition(recall=urcabh5lrtest, message="You must select a restriction matrix.")
      return()
    }
    rint <- tclvalue(rankVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(bh5lrtest(z = ", x, ", H = ", y , ", r = ", rint, "))", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="bh5lrtest")
  rankFrame <- tkframe(top)
  rankVariable <- tclVar("2")
  rankField <- tkentry(rankFrame, width="2", textvariable=rankVariable)
  tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
  tkgrid(rankFrame, sticky="w")
  tkgrid(tklabel(rankFrame, text="Number of cointegrating relationships =  ", fg="blue"), rankField, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(rankField, sticky="e")
  dialogSuffix(rows=3, columns=1)
}
#
# Restrictions for partly known cointegrating vectors
#
urcabh6lrtest <- function(){
  VECMmodels <- listVECMmodels()
  matrices <- listMatrix()
  numerics <- listNumeric()
  elements <- c(matrices, numerics)
  if (length(VECMmodels) == 0){
    tkmessageBox(message="There are no VECM models from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  if (length(matrices) == 0){
    tkmessageBox(message="There are no restriction matrices defined from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Test restrictions of partly known cointegrating Vectors")
  xBox <- variableListBox(top, VECMmodels, title="VECM models (pick one)")
  yBox <- variableListBox(top, elements, title="Restriction matrices (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcabh6lrtest, message="You must select a VECM model.")
      return()
    }
    y <- getSelection(yBox)
    if (length(y) == 0){
      errorCondition(recall=urcaalrtest, message="You must select a restriction matrix.")
      return()
    }
    rint <- tclvalue(rankVariable)
    r1int <- tclvalue(r1Variable)
    maxiter <- tclvalue(maxiterVariable)
    conv <- tclvalue(conVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(bh6lrtest(z = ", x, ", H = ", y , ", r = ", rint, ", r1 =", r1int, ", conv.val =", conv, ", max.iter =", maxiter, "))", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="bh6lrtest")
  rankFrame <- tkframe(top)
  r1Frame <- tkframe(top)
  rankVariable <- tclVar("2")
  r1Variable <- tclVar("1")
  rightFrame <- tkframe(top)
  maxiterFrame <- tkframe(rightFrame)
  maxiterVariable <- tclVar("50")
  maxiterField <- tkentry(maxiterFrame, width="4", textvariable=maxiterVariable)
  conFrame <- tkframe(rightFrame)
  conVariable <- tclVar("0.0001")
  conField <- tkentry(conFrame, width="8", textvariable=conVariable)
  tkgrid(tklabel(rightFrame, text=""))
  rankField <- tkentry(rankFrame, width="2", textvariable=rankVariable)
  r1Field <- tkentry(r1Frame, width="2", textvariable=r1Variable)
  tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
  tkgrid(rankFrame, rightFrame, sticky="w")
  tkgrid(tklabel(rankFrame, text="Number of cointegrating relationships =  ", fg="blue"), rankField, sticky="w")
  tkgrid(r1Frame, rightFrame, sticky="w")
  tkgrid(tklabel(r1Frame, text="Number of restricted ci relationships =  ", fg="blue"), r1Field, sticky="w")
  tkgrid(maxiterFrame, sticky="w")
  tkgrid(tklabel(maxiterFrame, text="Maximum number of iterations = ", fg="blue"), maxiterField, sticky="w")
  tkgrid(conFrame, sticky="w")
  tkgrid(tklabel(conFrame, text="Convergence criteria = ", fg="blue"), conField, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(rankField, sticky="e")
  tkgrid.configure(r1Field, sticky="e")
  tkgrid.configure(maxiterField, sticky="e")
  tkgrid.configure(conField, sticky="e")
  dialogSuffix(rows=4, columns=2)
}
#
# Restrictions for loading and cointegration matrix
#
urcaablrtest <- function(){
  VECMmodels <- listVECMmodels()
  matrices <- listMatrix()
  if (length(VECMmodels) == 0){
    tkmessageBox(message="There are no VECM models from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  if (length(matrices) == 0){
    tkmessageBox(message="There are no restriction matrices defined from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="Test Restrictions on Loading & Cointegration vectors")
  xBox <- variableListBox(top, VECMmodels, title="VECM models (pick one)")
  yBox <- variableListBox(top, matrices, title="Restriction matrices for cointegration vectors (pick one)")
  lBox <- variableListBox(top, matrices, title="Restriction matrices for loading vectors (pick one)")
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcaablrtest, message="You must select a VECM model.")
      return()
    }
    y <- getSelection(yBox)
    if (length(y) == 0){
      errorCondition(recall=urcaablrtest, message="You must select a cointegration restriction matrix.")
      return()
    }
    l <- getSelection(lBox)
    if (length(l) == 0){
      errorCondition(recall=urcaablrtest, message="You must select a loading restriction matrix.")
      return()
    }
    rint <- tclvalue(rankVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    doItAndPrint(paste("summary(ablrtest(z = ", x, ", H = ", y, ", A = ", l,  ", r = ", rint, "))", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="ablrtest")
  rankFrame <- tkframe(top)
  rankVariable <- tclVar("1")
  rankField <- tkentry(rankFrame, width="2", textvariable=rankVariable)
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(getFrame(yBox), getFrame(lBox), sticky="nw")
  tkgrid(rankFrame, sticky="w")
  tkgrid(tklabel(rankFrame, text="Number of cointegrating relationships =  ", fg="blue"), rankField, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(rankField, sticky="e")
  dialogSuffix(rows=3, columns=2)
}
#
# VECM with a structural shift
#
urcacajolst <- function(){
  dataSets <- listDataSets()
  if (length(dataSets) == 0){
    tkmessageBox(message="There are no data sets from which to choose.", icon="error", type="ok")
    tkfocus(CommanderWindow())
    return()
  }
  initializeDialog(title="VECM with level shift")
  xBox <- variableListBox(top, dataSets, title="Data Sets (pick one)")
  assign("UpdateModelNumber", UpdateModelNumber + 1, envir=.GlobalEnv)
  modelName <- tclVar(paste("VECMmodel.", UpdateModelNumber, sep=""))
  modelFrame <- tkframe(top)
  model <- tkentry(modelFrame, width="20", textvariable=modelName)
  onOK <- function(){
    x <- getSelection(xBox)
    if (length(x) == 0){
      errorCondition(recall=urcacajo, message="You must select a data set.")
      return()
    }
    ttype <- if(tclvalue(trendVariable) == 0) "FALSE" else "TRUE"
    lags <- tclvalue(lagVariable)
    seas <- tclvalue(seasonVariable)
    if (GrabFocus()) tkgrab.release(top)
    tkdestroy(top)
    modelValue <- tclvalue(modelName)
    if (!is.valid.name(modelValue)){
      assign("UpdateModelNumber", UpdateModelNumber - 1, envir=.GlobalEnv)
      errorCondition(recall=urcacajolst, message=paste('"', modelValue, '" is not a valid name.', sep=""))
      return()
    }
    if (is.element(modelValue, listVECMmodels())) {
      if ("no" == tclvalue(checkReplace(modelValue, type="Model"))){
        assign("UpdateModelNumber", UpdateModelNumber - 1, envir=.GlobalEnv)
        if (GrabFocus()) tkgrab.release(top)
        tkdestroy(top)
        urcacajolst()
        return()
      }
    }
    command <- paste("cajolst(x = ", x, ",  trend = ", ttype, ", K = ", lags, ", season = ", seas, ")", sep="")
    logger(paste(modelValue, " <- ", command, sep=""))
    assign(modelValue, justDoIt(command), envir=.GlobalEnv)
    doItAndPrint(paste("summary(", modelValue, ")", sep=""))
    tkfocus(CommanderWindow())
  }
  OKCancelHelp(helpSubject="cajolst")
  radioButtons(name="season", buttons=c("none", "monthly", "quarterly"), values=c("NULL", "12", "4"), 
               labels=c("None", "Monthly seasonality", "Quarterly seasonality"), title="Seasonality")
  checkBoxes(frame="trendFrame", boxes="trend", initialValues="1", labels="Include linear trend in the auxiliary regressions?")
  lagFrame <- tkframe(top)
  lagVariable <- tclVar("2")
  lagField <- tkentry(lagFrame, width="2", textvariable=lagVariable)
  tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
  tkgrid(modelFrame, sticky="w")
  tkgrid(getFrame(xBox), sticky="nw")
  tkgrid(tklabel(lagFrame, text="Lag order =  ", fg="blue"), lagField, sticky="w")
  tkgrid(lagFrame, sticky="w")
  tkgrid(trendFrame, sticky="w")
  tkgrid(buttonsFrame, sticky="w")
  tkgrid.configure(lagField, sticky="e")
  dialogSuffix(rows=5, columns=1)
}
#
# Utility Functions
#
listVECMmodels <- function(envir=.GlobalEnv, ...) {
  objects <- ls(envir=envir, ...)
  if (length(objects) == 0) NULL
  else objects[sapply(objects, function(.x) "ca.jo" == (class(eval(parse(text=.x), envir=envir))[1]))]
}

listMatrix <- function(envir=.GlobalEnv, ...) {
  objects <- ls(envir=envir, ...)
  if (length(objects) == 0) NULL
  else objects[sapply(objects, function(.x) "matrix" == (class(eval(parse(text=.x), envir=envir))[1]))]
}

listNumeric <- function(envir=.GlobalEnv, ...) {
  objects <- ls(envir=envir, ...)
  if (length(objects) == 0) NULL
  else objects[sapply(objects, function(.x) "numeric" == (class(eval(parse(text=.x), envir=envir))[1]))]
}