Calendar

# Merge moves data by one day, avoid
   caldat <- data.frame(date.seq = seq(min.date, max.date, by="days"), value = NA)
   dates <- as.Date(dates)
   caldat$value[match(dates, caldat$date.seq)] <- values

   caldat$dotw <- as.numeric(format(caldat$date.seq, "%w"))
   caldat$woty <- as.numeric(format(caldat$date.seq, "%U")) + 1
   caldat$yr <- as.factor(format(caldat$date.seq, "%Y"))
   caldat$month <- as.numeric(format(caldat$date.seq, "%m"))
   yrs <- as.character(unique(caldat$yr))
   d.loc <- as.numeric()
   for (m in min(yrs):max(yrs)) {
     d.subset <- which(caldat$yr == m)
     sub.seq <- seq(1,length(d.subset))
     d.loc <- c(d.loc, sub.seq)
   }
   caldat <- cbind(caldat, seq=d.loc)

   #color styles
   r2b <- c("#0571B0", "#92C5DE", "#F7F7F7", "#F4A582", "#CA0020") #red to blue
   r2g <- c("#D61818", "#FFAE63", "#FFFFBD", "#B5E384")   #red to green
   w2b <- c("#045A8D", "#2B8CBE", "#74A9CF", "#BDC9E1", "#F1EEF6")   #white to blue
   g2r <- c("#B5E384", "#FFFFBD", "#FFAE63", "#D61818") #green to red
   b2r <- c("#CA0020", "#F4A582", "#F7F7F7", "#92C5DE", "#0571B0") #blue to red
   ryb <- c("#0571B0", "#96fc9d", "#ffff66", "#ffa062", "#D61818") #blue to red

   assign("col.sty", get(color))
   calendar.pal <- colorRampPalette((col.sty), space = "Lab")
   def.theme <- lattice.getOption("default.theme")
   cal.theme <-
     function() {
       theme <-
         list(
           strip.background = list(col = "transparent"),
           strip.border = list(col = "transparent"),
           axis.line = list(col="transparent"),
           par.strip.text=list(cex=0.8))
     }
   lattice.options(default.theme = cal.theme)
   yrs <- (unique(caldat$yr))
   nyr <- length(yrs)
   print(cal.plot <- levelplot(value~woty*dotw | yr, data=caldat,
                               as.table=TRUE,
                               aspect=.12,
                               layout = c(1, nyr%%7),
                               between = list(x=0, y=c(1,1)),
                               strip=TRUE,
                               main = paste("", varname, sep = ""),
                               scales = list(
                                 x = list(
                                   at= c(seq(2.9, 52, by=4.42)),
                                   labels = month.abb,
                                   alternating = c(1, rep(0, (nyr-1))),
                                   tck=0,
                                   cex = 0.7),
                                 y=list(
                                   at = c(0, 1, 2, 3, 4, 5, 6),
                                   labels = c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday",
                                              "Friday", "Saturday"),
                                   alternating = 1,
                                   cex = 0.6,
                                   tck=0)),
                               xlim =c(0.4, 54.6),
                               ylim=c(6.6,-0.6),
                               cuts= ncolors - 1,
                               col.regions = (calendar.pal(ncolors)),
                               xlab="" ,
                               ylab="",
                               colorkey= list(col = calendar.pal(ncolors), width = 0.6, height = 0.5),
                               subscripts=TRUE
   ) )
   panel.locs <- trellis.currentLayout()
   for (row in 1:nrow(panel.locs)) {
     for (column in 1:ncol(panel.locs))  {
       if (panel.locs[row, column] > 0)
       {
         trellis.focus("panel", row = row, column = column,
                       highlight = FALSE)
         xyetc <- trellis.panelArgs()
         subs <- caldat[xyetc$subscripts,]
         dates.fsubs <- caldat[caldat$yr == unique(subs$yr),]
         y.start <- dates.fsubs$dotw[1]
         y.end   <- dates.fsubs$dotw[nrow(dates.fsubs)]
         dates.len <- nrow(dates.fsubs)
         adj.start <- dates.fsubs$woty[1]

         for (k in 0:6) {
           if (k < y.start) {
             x.start <- adj.start + 0.5
           } else {
             x.start <- adj.start - 0.5
           }
           if (k > y.end) {
             x.finis <- dates.fsubs$woty[nrow(dates.fsubs)] - 0.5
           } else {
             x.finis <- dates.fsubs$woty[nrow(dates.fsubs)] + 0.5
           }
           grid.lines(x = c(x.start, x.finis), y = c(k -0.5, k - 0.5),
                      default.units = "native", gp=gpar(col = "grey", lwd = 1))
         }
         if (adj.start <  2) {
           grid.lines(x = c( 0.5,  0.5), y = c(6.5, y.start-0.5),
                      default.units = "native", gp=gpar(col = "grey", lwd = 1))
           grid.lines(x = c(1.5, 1.5), y = c(6.5, -0.5), default.units = "native",
                      gp=gpar(col = "grey", lwd = 1))
           grid.lines(x = c(x.finis, x.finis),
                      y = c(dates.fsubs$dotw[dates.len] -0.5, -0.5), default.units = "native",
                      gp=gpar(col = "grey", lwd = 1))
           if (dates.fsubs$dotw[dates.len] != 6) {
             grid.lines(x = c(x.finis + 1, x.finis + 1),
                        y = c(dates.fsubs$dotw[dates.len] -0.5, -0.5), default.units = "native",
                        gp=gpar(col = "grey", lwd = 1))
           }
           grid.lines(x = c(x.finis, x.finis),
                      y = c(dates.fsubs$dotw[dates.len] -0.5, -0.5), default.units = "native",
                      gp=gpar(col = "grey", lwd = 1))
         }
         for (n in 1:51) {
           grid.lines(x = c(n + 1.5, n + 1.5),
                      y = c(-0.5, 6.5), default.units = "native", gp=gpar(col = "grey", lwd = 1))
         }
         x.start <- adj.start - 0.5

         if (y.start > 0) {
           grid.lines(x = c(x.start, x.start + 1),
                      y = c(y.start - 0.5, y.start -  0.5), default.units = "native",
                      gp=gpar(col = "black", lwd = 1.75))
           grid.lines(x = c(x.start + 1, x.start + 1),
                      y = c(y.start - 0.5 , -0.5), default.units = "native",
                      gp=gpar(col = "black", lwd = 1.75))
           grid.lines(x = c(x.start, x.start),
                      y = c(y.start - 0.5, 6.5), default.units = "native",
                      gp=gpar(col = "black", lwd = 1.75))
           if (y.end < 6  ) {
             grid.lines(x = c(x.start + 1, x.finis + 1),
                        y = c(-0.5, -0.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
             grid.lines(x = c(x.start, x.finis),
                        y = c(6.5, 6.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
           } else {
             grid.lines(x = c(x.start + 1, x.finis),
                        y = c(-0.5, -0.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
             grid.lines(x = c(x.start, x.finis),
                        y = c(6.5, 6.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
           }
         } else {
           grid.lines(x = c(x.start, x.start),
                      y = c( - 0.5, 6.5), default.units = "native",
                      gp=gpar(col = "black", lwd = 1.75))
         }

         if (y.start == 0 ) {
           if (y.end < 6  ) {
             grid.lines(x = c(x.start, x.finis + 1),
                        y = c(-0.5, -0.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
             grid.lines(x = c(x.start, x.finis),
                        y = c(6.5, 6.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
           } else {
             grid.lines(x = c(x.start + 1, x.finis),
                        y = c(-0.5, -0.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
             grid.lines(x = c(x.start, x.finis),
                        y = c(6.5, 6.5), default.units = "native",
                        gp=gpar(col = "black", lwd = 1.75))
           }
         }
         for (j in 1:12)  {
           last.month <- max(dates.fsubs$seq[dates.fsubs$month == j])
           x.last.m <- dates.fsubs$woty[last.month] + 0.5
           y.last.m <- dates.fsubs$dotw[last.month] + 0.5
           grid.lines(x = c(x.last.m, x.last.m), y = c(-0.5, y.last.m),
                      default.units = "native", gp=gpar(col = "black", lwd = 1.75))
           if ((y.last.m) < 6) {
             grid.lines(x = c(x.last.m, x.last.m - 1), y = c(y.last.m, y.last.m),
                        default.units = "native", gp=gpar(col = "black", lwd = 1.75))
             grid.lines(x = c(x.last.m - 1, x.last.m - 1), y = c(y.last.m, 6.5),
                        default.units = "native", gp=gpar(col = "black", lwd = 1.75))
           } else {
             grid.lines(x = c(x.last.m, x.last.m), y = c(- 0.5, 6.5),
                        default.units = "native", gp=gpar(col = "black", lwd = 1.75))
           }
         }
       }
     }
     trellis.unfocus()
   }
   lattice.options(default.theme = def.theme)
 }

```

### Plot Calendar

```
calendar(Ref_Data$Date, Ref_Data$Station, varname="title")

```