R/diagnostic_plot.R

In fognyc/bindr: Tools for Binding Raw Times-Series Hosted on Remote Site Into a Synchronized Factor Data Set

# If dplyr::select is in a package, using .data also prevents R CMD check from
# giving a NOTE about undefined global variables (provided that @importFrom
# rlang .data is inserted). Using rlang::.data (without @importFrom rlang .data)
# is another option. See Wickham, Hadley, R Packages, O'Reilly, 1st Edition,
# 2015, p. 89 for details

#' @importFrom rlang .data
#' @importFrom magrittr "%>%"
plot_difference_ur <- function(diag_obj,
                               which_ = c('difference', 'fitted difference'),
                               type = c('period', 'rolling'), wnd = 60){

  stopifnot(any(attr(diag_obj, "class") %in% c("tbl_df", "tbl", "data.frame")))
  nm <- c('test.name', 'test.model', 'test.lag', 'test.stat',
          'test.cval', 'test.cl')
  stopifnot( all(nm %in% names(diag_obj)) )

  type <- match.arg(arg = type)
  which_ <- match.arg(which_)

  if(type == 'period'){

    # Baseline plot
    g <- ggplot2::ggplot(data = diag_obj,
                         ggplot2::aes(x = .data$sub_period,
                                      y = .data$test.stat,
                                      col = .data$model))
    g <- g + ggplot2::geom_point(size = 3)

    # y-title, y-text
    y_lab <- base::unique(diag_obj$test.name)
    g <- g + ggplot2::ylab(label = y_lab)
    g <- g + ggplot2::theme(axis.text.y = ggplot2::element_text(face = 'bold'))

    # x-title, x-txt
    g <- g + ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 90,vjust = 0.5, hjust=1))
    g <- g + ggplot2::theme(axis.title.x = ggplot2::element_blank())
    g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text(face = 'bold'))

    # Title, sub-title, caption
    main_title <- stringr::str_glue(base::unique(diag_obj$test.name),
                                    ' of Actual vs Expected Inflation, ',
                                    'by Sub-Period ', '(Wnd = ', wnd, ')')
    sub_title <- stringr::str_glue('In Sample ',
                                   stringr::str_to_title(which_), ' | ',
                                   '* ADF Specifications * ', 'Model: ',
                                   base::unique(diag_obj$test.model), ', ',
                                   'Max. Lags: ',
                                   max(base::unique(diag_obj$test.lag),
                                       na.rm = T), ', ',
                                   base::unique(diag_obj$test.cl))
    g <- g + ggplot2::labs(title = main_title, subtitle = sub_title)

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5),
      plot.subtitle = ggplot2::element_text(hjust = 0.5))

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(
        color = "black", size = 12, face = "bold"))

    # Add confidence value
    cval <- base::unique(diag_obj$test.cval)
    g <- g + ggplot2::geom_hline(yintercept = cval,
                                 linetype = 'dashed', size = 0.25)
    # Display by grid
    g <- g + ggplot2::facet_grid(rows = ggplot2::vars(.data$model))
  }

  if(type == 'rolling'){

    test.cl <- base::unlist(base::unique(
      tidyr::drop_na(tibble::tibble(diag_obj$test.cl))))
    test.name <- base::unlist(base::unique(
      tidyr::drop_na(tibble::tibble(diag_obj$test.name))))
    test.lag <- base::unlist(base::unique(
      tidyr::drop_na(tibble::tibble(diag_obj$test.lag))))
    test.model <- base::unlist(base::unique(
      tidyr::drop_na(tibble::tibble(diag_obj$test.model))))

    # -------------------------------------------------------------------------
    # Baseline plot ***
    g <- ggplot2::ggplot(data = diag_obj,
                         ggplot2::aes(x = .data$date,
                                      y = .data$test.stat,
                                      col = .data$model))
    g <- g + ggplot2::geom_line()
    g <- g + ggplot2::facet_grid(rows = ggplot2::vars(.data$model))


    g <- g + ggplot2::geom_hline(
      yintercept = base::unique(.data$test.cval),
      linetype = 'dashed', size = 0.25)


    # -------------------------------------------------------------------------
    # y-title, y-text

    y_lab <- test.name
    g <- g + ggplot2::ylab(label = y_lab)
    g <- g + ggplot2::theme(axis.text.y = ggplot2::element_text(face = 'bold'))

    # x-title, x-txt
    g <- g + ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 90,vjust = 0.5, hjust=1))
    g <- g + ggplot2::theme(axis.title.x = ggplot2::element_blank())
    g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text(face = 'bold'))


    # -------------------------------------------------------------------------
    # Title, sub-title, caption ***
    main_title <- stringr::str_glue(test.name,
                                    ' of Actual vs Expected Inflation, ',
                                    'by Rolling Windows ', '(Wnd = ', wnd, ')')
    sub_title <- stringr::str_glue('In Sample ',
                                   stringr::str_to_title(which_), ' | ',
                                   '* ADF Specifications * ', 'Model: ',
                                   test.model, ', ',
                                   'Max. Lags: ', max(test.lag, na.rm = T),
                                   ', ', test.cl)
    g <- g + ggplot2::labs(title = main_title, subtitle = sub_title)

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5),
      plot.subtitle = ggplot2::element_text(hjust = 0.5))

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(
        color = "black", size = 12, face = "bold"))

    # Add confidence value
    cval <- base::unique(diag_obj$test.cval)
    g <- g + ggplot2::geom_hline(yintercept = cval,
                                 linetype = 'dashed', size = 0.25)

    # Display by grid
    g <- g + ggplot2::facet_grid(rows = ggplot2::vars(.data$model))
  }

  base::print(g)
  return(diag_obj)
}


plot_error <- function(diag_obj,
                       which_ = c('mean', 'test', 'sd', 'rmse'),
                       type = c('period', 'rolling'),
                       scaling = 10000, wnd){

  stopifnot(any(attr(diag_obj, "class") %in% c("tbl_df", "tbl", "data.frame")))
  which_ <- match.arg(which_)
  stopifnot( which_ %in% names(diag_obj) )
  type <- match.arg(arg = type)
  stopifnot( base::is.integer(scaling) || base::is.double(scaling) )

  if(which_ == 'test') {scaling  = 1}

  strHdl <- switch(which_,
                   mean = 'Average',
                   test = 'Student t-test',
                   sd = 'Standard Deviation',
                   rmse = 'Root Mean Square')

  if(type == 'period'){
    diag_obj <- dplyr::select(.data = diag_obj,
                              .data$model, .data$sub_period, !!which_)
    # Baseline plot
    g <- ggplot2::ggplot(data = diag_obj,
                         ggplot2::aes(x = .data$sub_period,
                                      y = .data[[which_]] * scaling,
                                      col = .data$model))
    g <- g + ggplot2::geom_point(size = 3)

    # y-title, y-text
    scaling_str <- base::formatC(
      x = scaling, format = 'f', digits = 0, big.mark = ',')
    y_lab <- ifelse( scaling != 1,
                     stringr::str_glue(which_, " x ", scaling_str),
                     which_)
    g <- g + ggplot2::ylab(label = y_lab)
    g <- g + ggplot2::theme(axis.text.y = ggplot2::element_text(face = 'bold'))

    # x-title, x-txt
    g <- g + ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 90,vjust = 0.5, hjust=1))
    g <- g + ggplot2::theme(axis.title.x = ggplot2::element_blank())
    g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text(face = 'bold'))

    # Title, sub-title, caption
    main_title <- stringr::str_glue(strHdl, ' of Monthly Forecast Error, ',
      'by Sub-Period, In-Sample')
    g <- g + ggplot2::labs(title = main_title)

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5),
      plot.subtitle = ggplot2::element_text(hjust = 0.5))

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(
        color = "black", size = 12, face = "bold"))
  }


  if(type == 'rolling'){
    diag_obj <- dplyr::select(.data = diag_obj,
                              .data$model, .data$date, !!which_)

    # -------------------------------------------------------------------------
    # Baseline plot ***
    g <- ggplot2::ggplot(data = diag_obj,
                         ggplot2::aes(x = .data$date,
                                      y = .data[[which_]] * scaling,
                                      col = .data$model))
    g <- g + ggplot2::geom_line()
    g <- g + ggplot2::facet_grid(rows = ggplot2::vars(.data$model))

    if(which_ == 'mean'){
      g <- g + ggplot2::geom_hline(
        yintercept = 0, linetype = 'dashed', size = 0.25)
    }

    if(which_ == 'test'){
      g <- g + ggplot2::geom_hline(
        yintercept = stats::qt(p = 0.025, df = (wnd -1)),
        linetype = 'dashed', size = 0.25)
      g <- g + ggplot2::geom_hline(
        yintercept = stats::qt(p = 0.975, df = (wnd -1)),
        linetype = 'dashed', size = 0.25)
    }


    # -------------------------------------------------------------------------
     # y-title, y-text
    scaling_str <- base::formatC(
      x = scaling, format = 'f', digits = 0, big.mark = ',')
    y_lab <- ifelse( scaling != 1,
                     stringr::str_glue(which_, " x ", scaling_str),
                     which_)
    g <- g + ggplot2::ylab(label = y_lab)
    g <- g + ggplot2::theme(axis.text.y = ggplot2::element_text(face = 'bold'))

    # x-title, x-txt
    g <- g + ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 90,vjust = 0.5, hjust=1))
    g <- g + ggplot2::theme(axis.title.x = ggplot2::element_blank())
    g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text(face = 'bold'))


    # -------------------------------------------------------------------------
    # Title, sub-title, caption ***
    main_title <- stringr::str_glue(strHdl, ' of Monthly Forecast Error, ',
                                    'by Rolling Window (', wnd, '), ',
                                    'In-Sample')
    g <- g + ggplot2::labs(title = main_title)

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5),
      plot.subtitle = ggplot2::element_text(hjust = 0.5))

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(
        color = "black", size = 12, face = "bold"))
  }

  base::print(g)
  return(diag_obj)
}


plot_lm <- function(diag_obj,
                    which_ = c('term'), select_ = c('constant', 'slope'),
                    type = c('period', 'rolling'),
                    wnd, conf_level = 0.95){

  stopifnot(any(attr(diag_obj, "class") %in% c("tbl_df", "tbl", "data.frame")))
  which_ <- match.arg(which_)
  select_ <- match.arg(select_)
  stopifnot( which_ %in% names(diag_obj) )
  type <- match.arg(arg = type)

  strHdl <- switch(select_,
                   constant = '(Intercept)',
                   slope = 'expected')

  if(type == 'period'){
    diag_obj <- dplyr::select(.data = diag_obj,
                              .data$model, .data$sub_period, !!which_,
                              .data$estimate, .data$conf.low, .data$conf.high)
    diag_obj <- dplyr::filter(.data = diag_obj, .data[[which_]] == strHdl)

    # Baseline plot
    g <- ggplot2::ggplot(data = diag_obj,
                         ggplot2::aes(x = .data$sub_period,
                                      y = .data$estimate,
                                      col = .data$model))
    g <- g + ggplot2::geom_point(size = 3)
    g <- g + ggplot2::geom_errorbar(ggplot2::aes(ymax = .data$conf.high,
                                                 ymin = .data$conf.low))
    if(strHdl == '(Intercept)'){
      g <- g + ggplot2::geom_hline(yintercept = 0,
                                   linetype = 'dashed', size = 0.25)
    }
    if(strHdl == 'expected'){
      g <- g + ggplot2::geom_hline(yintercept = 1,
                                   linetype = 'dashed', size = 0.25)
    }
    g <- g + ggplot2::facet_grid(rows = ggplot2::vars(.data$model))

    # -------------------------------------------------------------------------
    # y-title, y-text
    y_lab <- 'Estimate and Confidence Interval'
    g <- g + ggplot2::ylab(label = y_lab)
    g <- g + ggplot2::theme(axis.text.y = ggplot2::element_text(face = 'bold'))

    # x-title, x-txt
    g <- g + ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 90,vjust = 0.5, hjust=1))
    g <- g + ggplot2::theme(axis.title.x = ggplot2::element_blank())
    g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text(face = 'bold'))


    # -------------------------------------------------------------------------
    # Title, sub-title, caption
    main_title <- stringr::str_glue('Actual vs. Forecasted Inflation: ',
                                    stringr::str_to_title(select_),
                                    ' Coefficient')
    sub_title <- stringr::str_glue('Confidence Interval (c.l. = ',
                                   conf_level,
                                   '), Period Window (n = ', wnd, ')')
    g <- g + ggplot2::labs(
      title = main_title, subtitle = sub_title,
      caption = "Ref.: Fama, Gibbons (1984), Section 2, pp. 328-333")

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5),
      plot.subtitle = ggplot2::element_text(hjust = 0.5))

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(
        color = "black", size = 12, face = "bold"),
      plot.caption = ggplot2::element_text(color = "blue", face = "italic"))
  }


  if(type == 'rolling'){
    diag_obj <- dplyr::select(.data = diag_obj,
                              .data$model, .data$date, !!which_,
                              .data$estimate, .data$conf.low, .data$conf.high)
    diag_obj <- dplyr::filter(.data = diag_obj, .data[[which_]] == strHdl)


    # -------------------------------------------------------------------------
    # Baseline plot ***
    g <- ggplot2::ggplot(data = diag_obj,
                         ggplot2::aes(x = .data$date, col = .data$model))
    g <- g + ggplot2::geom_ribbon(ggplot2::aes(ymin = .data$conf.low,
                                               ymax = .data$conf.high),
                                  linetype = 1, size = 0.5, alpha = 0.1)

    if(strHdl == '(Intercept)'){
      g <- g + ggplot2::geom_hline(yintercept = 0,
                                   linetype = 'dashed', size = 0.25)
    }
    if(strHdl == 'expected'){
      g <- g + ggplot2::geom_hline(yintercept = 1,
                                   linetype = 'dashed', size = 0.25)
    }
    g <- g + ggplot2::facet_grid(rows = ggplot2::vars(.data$model))


    # -------------------------------------------------------------------------
    # y-title, y-text
    y_lab <- 'Confidence Interval'
    g <- g + ggplot2::ylab(label = y_lab)
    g <- g + ggplot2::theme(axis.text.y = ggplot2::element_text(face = 'bold'))

    # x-title, x-txt
    g <- g + ggplot2::theme(
      axis.text.x = ggplot2::element_text(angle = 90,vjust = 0.5, hjust=1))
    g <- g + ggplot2::theme(axis.title.x = ggplot2::element_blank())
    g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text(face = 'bold'))


    # -------------------------------------------------------------------------
    # Title, sub-title, caption
    main_title <- stringr::str_glue('Actual vs. Forecasted Inflation: ',
                                    stringr::str_to_title(select_),
                                    ' Coefficient')
    sub_title <- stringr::str_glue('Confidence Interval (c.l. = ',
                                   conf_level,
                                   '), Rolling Window (n = ', wnd, ')')
    g <- g + ggplot2::labs(
      title = main_title, subtitle = sub_title,
      caption = "Ref.: Fama, Gibbons (1984), Section 2, pp. 328-333")

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(hjust = 0.5),
      plot.subtitle = ggplot2::element_text(hjust = 0.5))

    g <- g + ggplot2::theme(
      plot.title = ggplot2::element_text(
        color = "black", size = 12, face = "bold"),
      plot.caption = ggplot2::element_text(color = "blue", face = "italic"))
  }

  base::print(g)
  return(diag_obj)

}