Heatmap Plot + SMA

SMA_Heatmap_Plot.R

SMA_Heatmap_Plot <- function(Dat, term=c("2020-01-01", as.character(lubridate::today())),
                             lag=5, xax = 0.1, yax = 0.999, xcex=0.8, ycex=0.8, rou=0,
                             SMA_periods=2000, pal_n=200, xcex_t=0.3, ccRep=20, srt_t=90,
                             M1=0.2, m1=0.9, line_col=F, Main_text="Heatmap Plot"){
  #lag=5; xax = 0.1; yax = 0.999; xcex=0.8; ycex=0.8; rou=0; SMA_periods=2000; pal_n=200;xcex_t=0.5; M1=0.2; m1=0.9; line_col=F; Main_text="Heatmap Plot"

  oldpar <- graphics::par(no.readonly = TRUE)
  on.exit(graphics::par(oldpar))
  
  if(!all(colnames(Dat) == c("Date", "Close", "Month"))){
    stop("Incorrect format of Dat object")
  }
  
  aa <- c(sum(Dat$Date <= term[1]):sum(Dat$Date <= term[2]))
  M <- max(Dat$Close[aa]) + abs(max(Dat$Close[aa]) - min(Dat$Close[aa]))*M1
  m <- min(Dat$Close[aa])*m1
  
  par(family= "HiraKakuPro-W3", xpd =F)
  layout(matrix(c(1,2), 1, 2, byrow = TRUE),
         widths=c(5,1),
         heights=c(1,1))
  par(mar = c(4,  4, 2, 2))
  plot(Dat$Date, Dat$Close, 
       ylim = c(m, M),
       xlim = c(min(as.numeric(Dat$Date)[aa]),
                max(as.numeric(Dat$Date)[aa])+as.numeric(lag)),
       xlab = "", ylab = "", 
       type = "l", col = "white", 
       lwd = 1,
       xaxt = "n",
       yaxt = "n",
       main=Main_text,
       xaxs="i", yaxs="i")
  
  #X-axis
  par(family= "HiraKakuPro-W3", xpd =F)
  lab <- seq.Date(as.Date(term[1]), as.Date(term[2]), length.out = 5, format="%Y年%B")
  axis.Date(1, at=lab, labels = FALSE, format="%Y年%B", cex=0.7)
  text(lab, m - (M-m)*xax, adj = 0.5,
       labels = format(lab, "%Y年%B"), srt = 45, pos = 1,
       xpd = TRUE, cex=xcex)
  
  #Y-axis
  par(family= "HiraKakuPro-W3", xpd =F)
  lab <- round(seq(signif(m, 1), signif(M, 1), length.out = 7),rou)  
  lab <- lab[lab > m]
  lab <- lab[lab < M]
  axis(2, at = lab, labels = F)
  text(par("usr")[1]*yax, lab, labels = lab, srt = 0, pos = 2, xpd = TRUE, cex=ycex)
  
  #Plot
  lines(Dat$Date, Dat$Close, type = "l", lwd = 1, col="grey")
  
  #SMA
  a <- as.numeric(Dat$Date)
  aa <- TTR::SMA(Dat$Close, n = SMA_periods)
  lines(a, aa, col="#56bc82", lwd=2.5)
  
  Dat$SMA <- aa
  Dat$Inc <- Dat$Close/Dat$SMA
  Dat$SMA[is.na(Dat$SMA)] <- NA
  Dat$Inc[is.na(Dat$Inc)] <- NA
  
  #color
  pal <- c("violet", "blue", "skyblue", "green", "yellow", "orange", "red")
  suppressWarnings(cls <- classInt::classIntervals(Dat$Inc, n=pal_n, style="quantile"))
  color.pal <- classInt::findColours(cls, pal)
  Dat$color.pal <- as.character(color.pal)
  
  cc <- c(T, rep(F, ccRep))
  Dat01 <- Dat[cc,]
  
  #Plot
  points(Dat01$Date, Dat01$Close, type = "p", pch=21, bg=Dat01$color.pal)
  text(Dat01$Date, Dat01$Close, 
       labels = round(Dat01$Inc,1), srt = srt_t, pos = 3,
       xpd = F, cex=xcex_t)
  
  color.bar <- function(lut, clsb, min, max=-min, nticks=11,
                        ticks=seq(min, max, len=nticks), title='') {
    plot(c(0,10), c(min,max), type='n', bty='n', 
         xaxt='n', xlab='', yaxt='n', ylab='', main=title,
         xaxs="i", yaxs="i")
    axis(4, ticks, las=1, hadj=0.25, cex.axis=0.5)
    for (i in 1:(length(clsb)-1)) {
      rect(0, clsb[i+1], 10, clsb[i], col=lut[i], border=NA)
    }
  }
  
  par(mar = c(5,  0.25, 3, 3), bg=NA)
  color.bar(lut=colorRampPalette(colors=pal)(pal_n), 
            clsb=cls$brks,
            min=round(min(cls$brks), 1), 
            max=round(max(cls$brks), 1))

}