map_wav_signal: Map Wavelet Signal

In nelson16silva/wavsigmap: Wavelet-Based Signal Estimation

Map Wavelet Signal

Description

This functional computes wavelet-based signal by mapping diferent arguments.

Usage

map_wav_signal(x, args)

Arguments

x	A time series or a numeric vector.
args	A tibble get from the function map_wav_args.

Value

A tibble. The respective estimated signal is presented in a specific column of the tibble. Each row of this column has a possibly wavelet-based signal estimated in a list form. Examples bellow explain how to extract the time series of a given wavelet model.

See Also

map_wav_args, signal

Examples

library(magrittr)
library(rlang)
library(purrr)
library(ggplot2)
library(tidyr)
library(tibble)

# EbayesThresh::ebayesthresh.wavelet

ebthr_wt <- list(
wf = c("haar", "la8"),
n.levels = 4:5,
boundary = "reflection",
wt = "modwt"
)
ebthr_ebwav <- list(
vscale = "level",
a = c(0.5, 1),
threshrule = c("median", "soft")
)

args_ebthr <- map_wav_args(c(ebthr_wt, ebthr_ebwav))

GDP_wavelet <- map_wav_signal(GDPC1, args_ebthr)

# Output gap estimation from wavelets and rmse in relation
# to GDPC1_GDPPOT.

GDP_gap_wav <- GDP_wavelet %>%
dplyr::mutate(gap = purrr::map(GDPC1_signal, ~ 100 * (GDPC1 - .x) / .x),
             rmse = purrr::map_dbl(gap, ~sqrt(mean((GDPC1_GDPPOT - .x) ^ 2))))

# RMSE graph

GDP_gap_wav %>%
  ggplot(aes(x = wf, y = rmse, color = threshrule)) +
  geom_jitter() +
  facet_wrap(a ~ n.levels)

# The best wavelet model to replicate GDPC1_GDPPOT

gap_wav_best <- GDP_gap_wav[which.min(GDP_gap_wav$rmse), ]

# Graph of GDP_gap_wav and GDPC1_GDPPOT
gap_wav_best %>%
`[`(1 ,) %>%
  add_column(date = list(time(GDPC1)), GDPC1_GDPPOT = list(GDPC1_GDPPOT)) %>%
  unnest(date, gap, GDPC1_GDPPOT) %>%
  ggplot(aes(x = date, y = gap, color = "Wavelet")) +
  geom_line() +
  geom_line(aes(y = GDPC1_GDPPOT, color = "GDPC1_GDPPOT")) +
  xlab("") +
  ylab("%") +
  labs(colour = "Output GAP")

# Find a best "a" prior for Empirical EbayesThresh to
# replicate GDPC1_GDPPOT:

best_a_prior <- function(x, ...) {
gdpw <- wavsigmap::signal(GDPC1, a = x, ...)
gapw <- 100 * (GDPC1 - gdpw) / gdpw
sqrt(mean((GDPC1_GDPPOT - gapw) ^ 2))
}

args_ebthr2 <- args_ebthr %>%
dplyr::select(-a) %>%
dplyr::mutate(
a = pmap_dbl(., ~optimise(best_a_prior, c(0.01, 3), ...)$minimum))

# wavethresh example

# Find the best alpha and beta priors to replicate GDPC1_GDPPOT

best_alpha_beta <- function(x, ...) {
gdpw <- wavsigmap::signal(GDPC1, alpha = x[1], beta = x[2], ...)
gapw <- 100 * (GDPC1 - gdpw) / gdpw
sqrt(mean((GDPC1_GDPPOT - gapw) ^ 2))
}

wthr_list <- list(
# wd list
filter.number = 4:5,
bc = c("periodic", "symmetric"),
#   type for wd and threshold
type = list(c("wavelet", "soft"), c("station", "hard")),
# threshold list
policy = "BayesThresh",
by.level = TRUE
)

wthr_args <- map_wav_args(wthr_list)

# Including the best priors

wthr_args2 <- wthr_args %>%
dplyr::mutate(alpha_beta = pmap(., ~possibly(optim, NULL)(
  c(0.5, 1), best_alpha_beta, lower = c(0, 0), upper = c(3, 3),
  method = "L-BFGS-B", ...)$par),
  alpha = map(alpha_beta, ~`[`(.x, 1)),
  beta = map(alpha_beta, ~`[`(.x, 2))
)

GDP_wavelet2 <- wthr_args2 %>%
dplyr::select(-alpha_beta) %>%
  map_wav_signal(x = GDPC1, args = .)

GDP_gap_wav2 <- GDP_wavelet2 %>%
dplyr::mutate(gap = purrr::map(GDPC1_signal, ~ 100 * (GDPC1 - .x) / .x),
              rmse = purrr::map(gap, ~sqrt(mean((GDPC1_GDPPOT - .x) ^ 2))))

# The best model to replicate GDPC1_GDPPOT

gap_wav_best2 <- GDP_gap_wav2[which.min(GDP_gap_wav2$rmse), ]

# Graph of GDP_gap_wav and GDPC1_GDPPOT

gap_wav_best2 %>%
  `[`(1 ,) %>%
  add_column(date = list(time(GDPC1)), GDPC1_GDPPOT = list(GDPC1_GDPPOT)) %>%
  unnest(date, gap, GDPC1_GDPPOT) %>%
  ggplot(aes(x = date, y = gap, color = "Wavelet")) +
  geom_line() +
  geom_line(aes(y = GDPC1_GDPPOT, color = "GDPC1_GDPPOT")) +
  xlab("") +
  ylab("%") +
  labs(colour = "Output GAP")

nelson16silva/wavsigmap documentation built on March 7, 2023, 10:45 a.m.