Question

我有以下数据集df：

price <- as.vector(c(3755,3243,3109,2990,2949,3021,3104,2988,3014,2999,3090,3209,3039,2748,2671,2556,2554,2650,2627,2560))
people <- as.vector(c(4228,4966,4614,4752,4545,4851,4598,4597,4713,4672,4833,4790,4844,4995,5068,4918,4909,4807,5024,4898))
df <- cbind(price,people)

使用library(vars)建模，使用vecm.pred得到了以下预测VAR：

cointest <- ca.jo(df, K = 5, type = "eigen", ecdet = "trend", spec = "transitory")
vecm.level <- vec2var(cointest, r = 1)
vecm.pred <- predict(vecm.level, n.ahead = 6)

然后我想使用fanchart来绘制我的模型及其预测图。对情节进行切分处理以包括：

标题
y轴名称
可见的y轴范围
我的x轴上的日期
添加样本外点
将预测置信区间的颜色更改为红黄色热图（如果可能，但不是优先级）

我通过首先定义我的x轴来尝试进行此操作（注意：我也尝试使我的tmax <- as.Date("2018-09-01")来考虑我的另外6个vecm.pred预测，但是在尝试执行此操作时，这些未显示在扇形图上）：

tmin <- as.Date("2016-08-01")
tmax <- as.Date("2018-03-01")
tlab <- seq(tmin, tmax, by="month")
time <- substr(tlab, 0, 7)

然后我在下面运行我的幻想图代码：

fanchart(vecm.pred, xaxt="n",ylab = c("Price (€)","Volume"), main = c("Price","People"))

par(new=TRUE)

axis(1, at=seq_along( c( time, rep(NA,6) )), labels=c( time, rep(NA,6)) ,
 las=3, line=-13.5, cex.axis=0.6)

axis(1, at=seq_along( c( time, rep(NA,6) )), labels=c( time, rep(NA,6)) ,
 las=3, line=5, cex.axis=0.6)

这给了我以下幻想：

这有很多问题。你会怎么做：

确保y轴各有一个名字
确保所有y轴的行情收录器值可见
将日期向左移动，以便第一个观察值为“ 2016-08”（如果可能，还应包括下6个预测的日期，即直到“ 2018-09”为止）
添加两个样本外点，以显示我的预测如何预测它们，例如2525的{{1}}和2500
将预测的颜色从默认灰度更改为红色/橙色/黄色热标（如果可能）吗？

Answer 1

我从fanchart中提取了vars函数，并对其进行了破解以添加您所需的某些功能（问题1、3和4）。库中的功能已经可能出现问题2和5。结果图如下所示。

这是遭到入侵的fanchart函数，我称之为fanchart2。主要修改是：更改循环中的y轴标签（问题1），将轴添加到循环中的每个图（问题3），并添加作为预测的点（问题4）。

#### hacked fanchart function ####
# base function taken from vars packaged
# hacked to allow more input as required for this problem
fanchart2 <- function(x,
                       colors = NULL,
                       cis = NULL,
                       names = NULL,
                       main = NULL,
                       ylab = NULL,
                       xlab = NULL,
                       col.y = NULL,
                       add.preds = NULL,
                       nc,
                       plot.type = c("multiple","single"),
                       mar = par("mar"),
                       oma = par("oma"),
                       lab.at=NULL,
                       lab.text=NULL,...) {
  if (!(class(x) == "varprd")){
    stop("\nPlease provide an object of class 'varprd',\ngenerated by predict-method for objects of class 'varest'.\n")
  }
  if (is.null(colors)){
    colors <- gray(sqrt(seq(from = 0.05, to = 1, length = 9)))
  }


  if (is.null(cis)) {
    cis <- seq(0.1, 0.9, by = 0.1)
  }
  else {
    if ((min(cis) <= 0) || (max(cis) >= 1)){
      stop("\nValues of confidence intervals must be in(0, 1).\n")
    }
    if (length(cis) > length(colors)){
      stop("\nSize of 'colors' vector must be at least as long as\nsize of 'cis' vector\n")
    }
  }
  n.regions <- length(cis)
  n.ahead <- nrow(x$fcst[[1]])
  K <- ncol(x$endog)
  e.sample <- nrow(x$endog)
  endog <- x$endog
  fcst <- NULL
  for (j in 1:n.regions) {
    fcst[[j]] <- predict(x$model, n.ahead = n.ahead, ci = cis[j],
                         dumvar = x$exo.fcst)$fcst
  }
  xx <- seq(e.sample, length.out = n.ahead + 1)
  xx <- c(xx, rev(xx))
  op <- par(no.readonly = TRUE)
  plot.type <- match.arg(plot.type)
  ynames <- colnames(endog)
  if (is.null(names)) {
    names <- ynames
  }
  else {
    names <- as.character(names)
    if (!(all(names %in% ynames))) {
      warning("\nInvalid variable name(s) supplied, using first variable.\n")
      names <- ynames[1]
    }
  }
  nv <- length(names)
  ifelse(is.null(main), main <- paste("Fanchart for variable",
                                      names), main <- rep(main, nv)[1:nv])
  ifelse(is.null(ylab), ylab <- "", ylab <- ylab)
  ifelse(is.null(xlab), xlab <- "", xlab <- xlab)
  ifelse(is.null(col.y), col.y <- "black", col.y <- col.y)
  if (plot.type == "single") {
    if (nv > 1)
      par(ask = TRUE)
    par(mar = mar, oma = oma)
  }
  else if (plot.type == "multiple") {
    if (missing(nc)) {
      nc <- ifelse(nv > 4, 2, 1)
    }
    nr <- ceiling(nv/nc)
    par(mfcol = c(nr, nc), mar = mar, oma = oma)
  }
  for (i in 1:nv) {
    ymax <- max(c(fcst[[n.regions]][names[i]][[1]][, 3]),
                endog[, names[i]])
    ymin <- min(c(fcst[[n.regions]][names[i]][[1]][, 2]),
                endog[, names[i]])
    yy1 <- c(endog[e.sample, names[i]], fcst[[1]][names[i]][[1]][,
                                                                 2], rev(c(endog[e.sample, names[i]], fcst[[1]][names[i]][[1]][,
                                                                                                                               3])))
    plot.ts(c(endog[, names[i]], rep(NA, n.ahead)),
            main = main[i],
            ylim = c(ymin, ymax),
            ylab = ylab[i],#### question 1 #### modivied ylab to depend on the loop counter
            xlab = xlab,
            col = col.y,
            ...)
    polygon(xx, yy1, col = colors[1], border = colors[1])
    if (n.regions > 1) {
      for (l in 2:n.regions) {
        yyu <- c(endog[e.sample, names[i]], fcst[[l]][names[i]][[1]][,
                                                                     3], rev(c(endog[e.sample, names[i]], fcst[[l -
                                                                                                                  1]][names[i]][[1]][, 3])))
        yyl <- c(endog[e.sample, names[i]], fcst[[l -
                                                    1]][names[i]][[1]][, 2], rev(c(endog[e.sample,
                                                                                         names[i]], fcst[[l]][names[i]][[1]][, 2])))
        polygon(xx, yyu, col = colors[l], border = colors[l])
        polygon(xx, yyl, col = colors[l], border = colors[l])
      }
    }

    #### question 4 ####
    # if a matrix of points at various times in the prediction is sent to the function
    # they will be plotted here
    # standard adjustments to color and pch are possible
    # assumes a matrix of values is given with columns in order of the variables (price=col 1)
    # and NA values are times without prediction and not plotted
    if(is.null(add.preds)==F){
      points(x=xx[2:(length(xx)/2)]
             ,y=add.preds[,i]
             ,col='gray48'
             ,pch=16)
    }

    #### question 3: adding axis to each plot inside the hacked function ####
    # standard modifications can be done to this function
    if(is.null(lab.at)==F){
      axis(1,
           at=lab.at,
           labels=lab.text,
           las=3,
           line=1,
           cex.axis=0.6)
    }

  }
  on.exit(par(op))
}

将其作为用户定义的函数加载后，可以运行以下基于原始示例的代码来生成图形。我不确定将什么时间分配给预测，所以我选择了一些示例。

library(vars)

price <- as.vector(c(3755,3243,3109,2990,2949,3021,3104,2988,3014,2999,3090,3209,3039,2748,2671,2556,2554,2650,2627,2560))
people <- as.vector(c(4228,4966,4614,4752,4545,4851,4598,4597,4713,4672,4833,4790,4844,4995,5068,4918,4909,4807,5024,4898))
df <- cbind(price,people)

cointest <- ca.jo(df,
                  K = 5,
                  type = "eigen",
                  ecdet = "trend",
                  spec = "transitory") 
vecm.level <- vec2var(cointest, r = 1)
vecm.pred <- predict(vecm.level, n.ahead = 6)

tmin <- as.Date("2016-08-01")
tmax <- as.Date("2018-03-01")
tlab <- seq(tmin, tmax, by="month")
time <- substr(tlab, 0, 7)

fanchart2(vecm.pred
          ,xaxt="n"
          ,ylab = c("Price (€)","Volume") #### question 1: see hacked function ###
          ,main = c("Price","People")
          ,add.preds = matrix(c(NA,2525,NA,NA,2500,NA,rep(NA,6)),byrow = F,ncol=2), #### question 4: see hacked function ####
          ,las=1 #### question 2: rotates text to horizontal for easier viewing ####
          ,colors=heat.colors(9) ##### question 5: capability in pre-hacked function ####
          ,lab.at = seq(1,length(tlab)+6,1) #### question 3: see hacked function, 6 from the n.ahead in vecm.pred  ####
          ,lab.text = c( time, rep(NA,6))  #### question 3: see hacked function
)

Fanchart定制（vars软件包）

1 个答案: