R/viz_local_predabil.R

In ooelrich/oscbvar: Stuff for Bayesian vector autoregressions

#' @title Plots local predictive ability
#'
#' @description
#' Plots local predictive ability over a set of smoothing variables for
#' one or more models.
#' Options for univariate distibutions (lpdens vs each of the pooling
#' variables) or bivariate (size of dots corresponds to lpdens, x and y
#' axes corresponds to two different pooling variables).
#'
#' @details
#' Details go here.
#'
#' @param df_preds Data frame with predictions. Needs to contain a
#'   column named "t" that contains time point as well as a column
#'   called "lpdens." It also needs to have a column called "method." 
#'   If there is more than one unique value in the method column (which
#'   corresponds to a multiplicity of models), predictions from 
#'   different models will be given different colors.
#' @param df_pooling Data frame with pooling variables, as well as a 
#'   column names "t" that contains time point and corresponds to the
#'   time points in df_preds.
#' @param univariate Boolean. Should univariate plots be returned? 
#'   Defaults to true. 
#' @param bivariate Boolean. Should bivariate plots be returned?
#'   Defaults to true.
#'
#' @return A list of (gg)plots.
#' @export
#' @importFrom utils combn

local_predictive_ability <- function(
        df_preds,
        df_pooling,
        univariate = TRUE,
        bivariate = TRUE
    ) {

    pred_df <- df_preds[, c("t", "lpdens", "method")]
    dfz <- merge(df_preds, df_pooling)
    pool_vars <- colnames(df_pooling)
    pool_vars <- pool_vars[!(pool_vars %in% "t")]

    if (univariate) {
        pltlist <- lapply(pool_vars, univariate_predabil, df = dfz)
    }

    if (bivariate) {
        pv <- combn(pool_vars, 2)
        pvl <- split(pv, col(pv))
        plt_bi <- lapply(pvl, bivariate_predabil, df = dfz)
        pltlist <- c(pltlist, plt_bi)
    }

    return(pltlist)

    }

#' Univariate predictive ability plot
#'
#' @keywords internal

univariate_predabil <- function(df, pool_v) {
    df <- df[, c(pool_v, "lpdens", "method")]
    plt <-
        ggplot(df, aes(y = .data$lpdens, x = .data[[pool_v]], color = .data$method)) +
        ggplot2::geom_line() +
        labs(
            title = sprintf("lpdens vs %s", pool_v),
            x = pool_v,
            y = "lpdens")
    return(plt)
}


#' Bivariate predictive ability plot using plotly
#'
#' @keywords internal
#' @importFrom plotly ggplotly

bivariate_predabil <- function(df, pool_v) {
    df <- df[, c(pool_v, "lpdens", "method")]
    plt <- 
    ggplot(df, aes(
        x = .data[[colnames(df)[1]]],
        y = .data[[colnames(df)[2]]],
        size = -.data$lpdens,
        shape = .data$method,
        color = .data$method)) +
    ggplot2::geom_jitter() +
    labs(
        title = sprintf(
            "lpdens vs %s and %s",
            colnames(df)[1],
            colnames(df)[2]),
        x = colnames(df)[1],
        y = colnames(df)[2]) +
    ggplot2::scale_shape_manual(values = c(3, 1, 4)) 
    plt <- plotly::ggplotly(plt)
    return(plt)
}