Installation

library(devtools)
devtools::install_github("msummersgill/RcppWavelet")

Load Libraries

suppressMessages({
  library(RcppWavelet)
  library(data.table)
  library(plotly)
})

Generate Data

set.seed(1234)
sampleLength <- 2000L
sampleFrequency <- 10L
Index <- seq.default(from = 1/sampleFrequency, by = 1/sampleFrequency, length.out = sampleLength)
Scale <- c(seq.default(from = 0, to = 1.25, length.out = sampleLength/2),
           seq.default(from = 1.25, to = 0, length.out = sampleLength/2))
Drift   <- seq.default(from = 0.75, to = 1.5, length.out = sampleLength)
DT <- data.table(Time = Index,
                 c1 = sin(1/8*(2*pi)*Index),
                 c2 = sin(1/Drift*(2*pi)*Index*1.25),
                 c3 = sin(1/5*(2*pi)*Index)*(Scale^3),
                 Noise = rnorm(sampleLength,mean = 0,sd = 0.5))
DT[,Signal := c1 + c2 + c3 + Noise]

Input Signal

DT %>% 
  plot_ly() %>% 
  add_lines(x ~Time, y = ~c1 ,name = "c1 - Constant",
            color = I("goldenrod1"), line = list(width = 1.5)) %>% 
  add_lines(x ~Time, y = ~c2 ,name = "c2 - Shifting Frequency",
            color = I("firebrick2"), line = list(width = 1.5)) %>% 
  add_lines(x ~Time, y = ~c3 ,name = "c3 - Modulated Amplitude",
            color = I("dodgerblue3"), line = list(width = 1.5)) %>% 
  add_lines(x ~Time, y = ~Noise ,name = "Noise",
            color = I("gray30"),line = list(width = 1)) %>% 
  add_lines(x ~Time, y = ~Signal ,name = "Composite Signal",
            color = I("black"), line = list(width = 2.5)) %>% 
  layout(hovermode = "compare",
         plot_bgcolor = "rgba(235,235,235,0.7)",
         paper_bgcolor = "rgba(0,0,0,0)",
         legend = list(x = 0.5, y = -0.1,
                       xanchor = "center",yanchor = "top",
                       orientation = "h",
                       bgcolor = "transparent"),
         yaxis = list(title = "Amplitude",
                      gridcolor = "rgba(255,255,255,1)"),
         xaxis = list(title = "",
                      gridcolor = "rgba(255,255,255,1)"))

Construct a Wavelet Representation

Wavelet <- RcppWavelet::analyze(x = DT[,Signal],
                                bands_per_octave = 64,
                                frequency_min = 1/10,
                                frequency_max = 2,
                                samplerate_hz = sampleFrequency,
                                mother_wavelet = "MORLET",
                                morlet_carrier = 30,
                                cores = 6L)
DT[,Recon := RcppWavelet::reconstruct(wavelet = Wavelet,scale = TRUE,method = "quantile")]
cat(Wavelet$configuration)
Wavelet Filter:
    Frequency Range: 0.1 2
    Bands per Octave: 64
    Optimisation: 0
Wavelet:
    Sampling rate: 10
    Scale: 0.2
    Equivalent Frequency (Hz): 23.8865
    Window Size: 1
    Type: Morlet
    Omega0 (carrier frequency): 30

Review Scalogram and Reconstruction

DT %>% 
  plot_ly() %>% 
  add_lines(x ~Time, y = ~Signal ,name = "Original Signal",
            color = I("black"), line = list(width = 1)) %>% 
  add_lines(x ~Time, y = ~Recon ,name = "Wavelet Reconstruction",
            color = I("firebrick2")) %>% 
  layout(hovermode = "compare",
         plot_bgcolor = "rgba(235,235,235,0.7)",
         paper_bgcolor = "rgba(0,0,0,0)",
         legend = list(x = 0.5, y = -0.1,
                       xanchor = "center", yanchor = "top",
                       orientation = "h",
                       bgcolor = "transparent"),
         yaxis = list(title = "Amplitude",
                      gridcolor = "rgba(255,255,255,1)"),
         xaxis = list(title = "",
                      gridcolor = "rgba(255,255,255,1)"))-> ReconstructionPlot
plot_ly() %>% 
  add_heatmap(z = t(Mod(Wavelet$scalogram)),x = Index, y = Wavelet$periods,
              name = "Scalogram") %>%
  layout(yaxis = list(title = "Period"),
         xaxis = list(title = "")) %>% 
  hide_colorbar() -> ScalogramPlot
subplot(ScalogramPlot,ReconstructionPlot, nrows = 2, shareX = TRUE,titleY = TRUE)
LS0tCnRpdGxlOiAiVXNpbmcgUmNwcFdhdmVsZXQiCm91dHB1dDogaHRtbF9ub3RlYm9vawotLS0KCgojIyBJbnN0YWxsYXRpb24KCmBgYHIKbGlicmFyeShkZXZ0b29scykKZGV2dG9vbHM6Omluc3RhbGxfZ2l0aHViKCJtc3VtbWVyc2dpbGwvUmNwcFdhdmVsZXQiKQpgYGAKCiMjIExvYWQgTGlicmFyaWVzCgpgYGB7cn0Kc3VwcHJlc3NNZXNzYWdlcyh7CiAgbGlicmFyeShSY3BwV2F2ZWxldCkKICBsaWJyYXJ5KGRhdGEudGFibGUpCiAgbGlicmFyeShwbG90bHkpCn0pCmBgYAoKCiMjIEdlbmVyYXRlIERhdGEKCmBgYHtyfQpzZXQuc2VlZCgxMjM0KQpzYW1wbGVMZW5ndGggPC0gMjAwMEwKc2FtcGxlRnJlcXVlbmN5IDwtIDEwTAoKSW5kZXggPC0gc2VxLmRlZmF1bHQoZnJvbSA9IDEvc2FtcGxlRnJlcXVlbmN5LCBieSA9IDEvc2FtcGxlRnJlcXVlbmN5LCBsZW5ndGgub3V0ID0gc2FtcGxlTGVuZ3RoKQoKU2NhbGUgPC0gYyhzZXEuZGVmYXVsdChmcm9tID0gMCwgdG8gPSAxLjI1LCBsZW5ndGgub3V0ID0gc2FtcGxlTGVuZ3RoLzIpLAogICAgICAgICAgIHNlcS5kZWZhdWx0KGZyb20gPSAxLjI1LCB0byA9IDAsIGxlbmd0aC5vdXQgPSBzYW1wbGVMZW5ndGgvMikpCgpEcmlmdCAgIDwtIHNlcS5kZWZhdWx0KGZyb20gPSAwLjc1LCB0byA9IDEuNSwgbGVuZ3RoLm91dCA9IHNhbXBsZUxlbmd0aCkKCkRUIDwtIGRhdGEudGFibGUoVGltZSA9IEluZGV4LAogICAgICAgICAgICAgICAgIGMxID0gc2luKDEvOCooMipwaSkqSW5kZXgpLAogICAgICAgICAgICAgICAgIGMyID0gc2luKDEvRHJpZnQqKDIqcGkpKkluZGV4KjEuMjUpLAogICAgICAgICAgICAgICAgIGMzID0gc2luKDEvNSooMipwaSkqSW5kZXgpKihTY2FsZV4zKSwKICAgICAgICAgICAgICAgICBOb2lzZSA9IHJub3JtKHNhbXBsZUxlbmd0aCxtZWFuID0gMCxzZCA9IDAuNSkpCgpEVFssU2lnbmFsIDo9IGMxICsgYzIgKyBjMyArIE5vaXNlXQpgYGAKCgoKIyMgSW5wdXQgU2lnbmFsCgpgYGB7ciBmaWcud2lkdGg9OS41LGZpZy5oZWlnaHQ9Nn0KCkRUICU+JSAKICBwbG90X2x5KCkgJT4lIAogIGFkZF9saW5lcyh4IH5UaW1lLCB5ID0gfmMxICxuYW1lID0gImMxIC0gQ29uc3RhbnQiLAogICAgICAgICAgICBjb2xvciA9IEkoImdvbGRlbnJvZDEiKSwgbGluZSA9IGxpc3Qod2lkdGggPSAxLjUpKSAlPiUgCiAgYWRkX2xpbmVzKHggflRpbWUsIHkgPSB+YzIgLG5hbWUgPSAiYzIgLSBTaGlmdGluZyBGcmVxdWVuY3kiLAogICAgICAgICAgICBjb2xvciA9IEkoImZpcmVicmljazIiKSwgbGluZSA9IGxpc3Qod2lkdGggPSAxLjUpKSAlPiUgCiAgYWRkX2xpbmVzKHggflRpbWUsIHkgPSB+YzMgLG5hbWUgPSAiYzMgLSBNb2R1bGF0ZWQgQW1wbGl0dWRlIiwKICAgICAgICAgICAgY29sb3IgPSBJKCJkb2RnZXJibHVlMyIpLCBsaW5lID0gbGlzdCh3aWR0aCA9IDEuNSkpICU+JSAKICBhZGRfbGluZXMoeCB+VGltZSwgeSA9IH5Ob2lzZSAsbmFtZSA9ICJOb2lzZSIsCiAgICAgICAgICAgIGNvbG9yID0gSSgiZ3JheTMwIiksbGluZSA9IGxpc3Qod2lkdGggPSAxKSkgJT4lIAogIGFkZF9saW5lcyh4IH5UaW1lLCB5ID0gflNpZ25hbCAsbmFtZSA9ICJDb21wb3NpdGUgU2lnbmFsIiwKICAgICAgICAgICAgY29sb3IgPSBJKCJibGFjayIpLCBsaW5lID0gbGlzdCh3aWR0aCA9IDIuNSkpICU+JSAKICBsYXlvdXQoaG92ZXJtb2RlID0gImNvbXBhcmUiLAogICAgICAgICBwbG90X2JnY29sb3IgPSAicmdiYSgyMzUsMjM1LDIzNSwwLjcpIiwKICAgICAgICAgcGFwZXJfYmdjb2xvciA9ICJyZ2JhKDAsMCwwLDApIiwKICAgICAgICAgbGVnZW5kID0gbGlzdCh4ID0gMC41LCB5ID0gLTAuMSwKICAgICAgICAgICAgICAgICAgICAgICB4YW5jaG9yID0gImNlbnRlciIseWFuY2hvciA9ICJ0b3AiLAogICAgICAgICAgICAgICAgICAgICAgIG9yaWVudGF0aW9uID0gImgiLAogICAgICAgICAgICAgICAgICAgICAgIGJnY29sb3IgPSAidHJhbnNwYXJlbnQiKSwKICAgICAgICAgeWF4aXMgPSBsaXN0KHRpdGxlID0gIkFtcGxpdHVkZSIsCiAgICAgICAgICAgICAgICAgICAgICBncmlkY29sb3IgPSAicmdiYSgyNTUsMjU1LDI1NSwxKSIpLAogICAgICAgICB4YXhpcyA9IGxpc3QodGl0bGUgPSAiIiwKICAgICAgICAgICAgICAgICAgICAgIGdyaWRjb2xvciA9ICJyZ2JhKDI1NSwyNTUsMjU1LDEpIikpCgpgYGAKCiMjIENvbnN0cnVjdCBhIFdhdmVsZXQgUmVwcmVzZW50YXRpb24KCmBgYHtyfQpXYXZlbGV0IDwtIFJjcHBXYXZlbGV0OjphbmFseXplKHggPSBEVFssU2lnbmFsXSwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBiYW5kc19wZXJfb2N0YXZlID0gNjQsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgZnJlcXVlbmN5X21pbiA9IDEvMTAsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgZnJlcXVlbmN5X21heCA9IDIsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgc2FtcGxlcmF0ZV9oeiA9IHNhbXBsZUZyZXF1ZW5jeSwKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICBtb3RoZXJfd2F2ZWxldCA9ICJNT1JMRVQiLAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIG1vcmxldF9jYXJyaWVyID0gMzAsCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgY29yZXMgPSA2TCkKCkRUWyxSZWNvbiA6PSBSY3BwV2F2ZWxldDo6cmVjb25zdHJ1Y3Qod2F2ZWxldCA9IFdhdmVsZXQsc2NhbGUgPSBUUlVFLG1ldGhvZCA9ICJxdWFudGlsZSIpXQoKY2F0KFdhdmVsZXQkY29uZmlndXJhdGlvbikKYGBgCgojIyBSZXZpZXcgU2NhbG9ncmFtIGFuZCBSZWNvbnN0cnVjdGlvbgoKYGBge3IgZmlnLndpZHRoPTkuNSxmaWcuaGVpZ2h0PTZ9CkRUICU+JSAKICBwbG90X2x5KCkgJT4lIAogIGFkZF9saW5lcyh4IH5UaW1lLCB5ID0gflNpZ25hbCAsbmFtZSA9ICJPcmlnaW5hbCBTaWduYWwiLAogICAgICAgICAgICBjb2xvciA9IEkoImJsYWNrIiksIGxpbmUgPSBsaXN0KHdpZHRoID0gMSkpICU+JSAKICBhZGRfbGluZXMoeCB+VGltZSwgeSA9IH5SZWNvbiAsbmFtZSA9ICJXYXZlbGV0IFJlY29uc3RydWN0aW9uIiwKICAgICAgICAgICAgY29sb3IgPSBJKCJmaXJlYnJpY2syIikpICU+JSAKICBsYXlvdXQoaG92ZXJtb2RlID0gImNvbXBhcmUiLAogICAgICAgICBwbG90X2JnY29sb3IgPSAicmdiYSgyMzUsMjM1LDIzNSwwLjcpIiwKICAgICAgICAgcGFwZXJfYmdjb2xvciA9ICJyZ2JhKDAsMCwwLDApIiwKICAgICAgICAgbGVnZW5kID0gbGlzdCh4ID0gMC41LCB5ID0gLTAuMSwKICAgICAgICAgICAgICAgICAgICAgICB4YW5jaG9yID0gImNlbnRlciIsIHlhbmNob3IgPSAidG9wIiwKICAgICAgICAgICAgICAgICAgICAgICBvcmllbnRhdGlvbiA9ICJoIiwKICAgICAgICAgICAgICAgICAgICAgICBiZ2NvbG9yID0gInRyYW5zcGFyZW50IiksCiAgICAgICAgIHlheGlzID0gbGlzdCh0aXRsZSA9ICJBbXBsaXR1ZGUiLAogICAgICAgICAgICAgICAgICAgICAgZ3JpZGNvbG9yID0gInJnYmEoMjU1LDI1NSwyNTUsMSkiKSwKICAgICAgICAgeGF4aXMgPSBsaXN0KHRpdGxlID0gIiIsCiAgICAgICAgICAgICAgICAgICAgICBncmlkY29sb3IgPSAicmdiYSgyNTUsMjU1LDI1NSwxKSIpKS0+IFJlY29uc3RydWN0aW9uUGxvdAoKcGxvdF9seSgpICU+JSAKICBhZGRfaGVhdG1hcCh6ID0gdChNb2QoV2F2ZWxldCRzY2Fsb2dyYW0pKSx4ID0gSW5kZXgsIHkgPSBXYXZlbGV0JHBlcmlvZHMsCiAgICAgICAgICAgICAgbmFtZSA9ICJTY2Fsb2dyYW0iKSAlPiUKICBsYXlvdXQoeWF4aXMgPSBsaXN0KHRpdGxlID0gIlBlcmlvZCIpLAogICAgICAgICB4YXhpcyA9IGxpc3QodGl0bGUgPSAiIikpICU+JSAKICBoaWRlX2NvbG9yYmFyKCkgLT4gU2NhbG9ncmFtUGxvdAoKc3VicGxvdChTY2Fsb2dyYW1QbG90LFJlY29uc3RydWN0aW9uUGxvdCwgbnJvd3MgPSAyLCBzaGFyZVggPSBUUlVFLHRpdGxlWSA9IFRSVUUpCmBgYAoK