Skip to content

Instantly share code, notes, and snippets.

@Altons

Altons/calendarHeat.R

Forked from aaronwolen/calendarHeat.R
Created February 9, 2020 10:26
Show Gist options
  • Save Altons/d1276d5496863b31f98d9b5c6b66702c to your computer and use it in GitHub Desktop.
Save Altons/d1276d5496863b31f98d9b5c6b66702c to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. @aaronwolen aaronwolen revised this gist Jun 9, 2015. 1 changed file with 2 additions and 2 deletions.
    4 changes: 2 additions & 2 deletions calendarHeat.R
    View file
    Original file line number Diff line number Diff line change
    @@ -33,8 +33,8 @@ calendarHeat <- function(dates,
    ncolors=99,
    title,
    date.form = "%Y-%m-%d", ...) {
    require(lattice)
    require(grid)
    require(lattice, quietly = TRUE)
    require(grid, quietly = TRUE)

    if (class(dates) == "character" | class(dates) == "factor" ) {
    dates <- strptime(dates, date.form)
  2. @aaronwolen aaronwolen revised this gist Jun 9, 2015. 1 changed file with 5 additions and 1 deletion.
    6 changes: 5 additions & 1 deletion calendarHeat.R
    View file
    Original file line number Diff line number Diff line change
    @@ -22,6 +22,10 @@

    ## You can find a copy of the GNU General Public License, Version 2 at:
    ## http://www.gnu.org/licenses/gpl-2.0.html

    # days <- seq(as.Date("2015-01-1"), as.Date("2015-12-31"), "days")
    # values <- runif(365)
    # calendarHeat(days, values)

    calendarHeat <- function(dates,
    values,
    @@ -31,7 +35,7 @@ calendarHeat <- function(dates,
    date.form = "%Y-%m-%d", ...) {
    require(lattice)
    require(grid)
    require(chron)

    if (class(dates) == "character" | class(dates) == "factor" ) {
    dates <- strptime(dates, date.form)
    }
  3. @aaronwolen aaronwolen revised this gist Jun 9, 2015. 1 changed file with 7 additions and 10 deletions.
    17 changes: 7 additions & 10 deletions calendarHeat.R
    View file
    Original file line number Diff line number Diff line change
    @@ -24,9 +24,9 @@
    ## http://www.gnu.org/licenses/gpl-2.0.html

    calendarHeat <- function(dates,
    values,
    ncolors=99,
    color="r2g",
    values,
    colors,
    ncolors=99,
    title,
    date.form = "%Y-%m-%d", ...) {
    require(lattice)
    @@ -61,12 +61,9 @@ calendarHeat <- function(dates,
    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

    assign("col.sty", get(color))
    calendar.pal <- colorRampPalette((col.sty), space = "Lab")
    if (missing(colors)) colors <- c("#D61818", "#FFAE63", "#FFFFBD", "#B5E384")

    calendar.pal <- colorRampPalette(colors, space = "Lab")
    def.theme <- lattice.getOption("default.theme")
    cal.theme <-
    function() {
    @@ -84,7 +81,7 @@ calendarHeat <- function(dates,
    as.table=TRUE,
    aspect=.12,
    layout = c(1, nyr%%7),
    between = list(x=0, y=c(1,1)),
    between = list(x=0, y=c(0.5,0.5)),
    strip=TRUE,
    main = ifelse(missing(title), "", title),
    scales = list(
  4. @aaronwolen aaronwolen revised this gist Jun 9, 2015. 1 changed file with 198 additions and 198 deletions.
    396 changes: 198 additions & 198 deletions calendarHeat.R
    View file
    Original file line number Diff line number Diff line change
    @@ -29,206 +29,206 @@ calendarHeat <- function(dates,
    color="r2g",
    title,
    date.form = "%Y-%m-%d", ...) {
    require(lattice)
    require(grid)
    require(chron)
    if (class(dates) == "character" | class(dates) == "factor" ) {
    dates <- strptime(dates, date.form)
    }
    caldat <- data.frame(value = values, dates = dates)
    min.date <- as.Date(paste(format(min(dates), "%Y"),
    "-1-1",sep = ""))
    max.date <- as.Date(paste(format(max(dates), "%Y"),
    "-12-31", sep = ""))
    dates.f <- data.frame(date.seq = seq(min.date, max.date, by="days"))

    # 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

    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 = ifelse(missing(title), "", title),
    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
    require(lattice)
    require(grid)
    require(chron)
    if (class(dates) == "character" | class(dates) == "factor" ) {
    dates <- strptime(dates, date.form)
    }
    caldat <- data.frame(value = values, dates = dates)
    min.date <- as.Date(paste(format(min(dates), "%Y"),
    "-1-1",sep = ""))
    max.date <- as.Date(paste(format(max(dates), "%Y"),
    "-12-31", sep = ""))
    dates.f <- data.frame(date.seq = seq(min.date, max.date, by="days"))

    # 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

    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))
    }
    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))
    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 = ifelse(missing(title), "", title),
    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
    }
    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))
    }
    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))
    }
    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),
    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))
    }
    }
    }
    }
    trellis.unfocus()
    }
    lattice.options(default.theme = def.theme)
    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)
    }
  5. @aaronwolen aaronwolen revised this gist Jun 9, 2015. 1 changed file with 2 additions and 2 deletions.
    4 changes: 2 additions & 2 deletions calendarHeat.R
    View file
    Original file line number Diff line number Diff line change
    @@ -27,7 +27,7 @@ calendarHeat <- function(dates,
    values,
    ncolors=99,
    color="r2g",
    varname="Values",
    title,
    date.form = "%Y-%m-%d", ...) {
    require(lattice)
    require(grid)
    @@ -86,7 +86,7 @@ print(cal.plot <- levelplot(value~woty*dotw | yr, data=caldat,
    layout = c(1, nyr%%7),
    between = list(x=0, y=c(1,1)),
    strip=TRUE,
    main = paste("Calendar Heat Map of ", varname, sep = ""),
    main = ifelse(missing(title), "", title),
    scales = list(
    x = list(
    at= c(seq(2.9, 52, by=4.42)),
  6. @aaronwolen aaronwolen created this gist Jun 9, 2015.
    234 changes: 234 additions & 0 deletions calendarHeat.R
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,234 @@
    ##############################################################################
    # Calendar Heatmap #
    # by #
    # Paul Bleicher #
    # an R version of a graphic from: #
    # http://stat-computing.org/dataexpo/2009/posters/wicklin-allison.pdf #
    # requires lattice, chron, grid packages #
    ##############################################################################

    ## calendarHeat: An R function to display time-series data as a calendar heatmap
    ## Copyright 2009 Humedica. All rights reserved.

    ## This program is free software; you can redistribute it and/or modify
    ## it under the terms of the GNU General Public License as published by
    ## the Free Software Foundation; either version 2 of the License, or
    ## (at your option) any later version.

    ## This program is distributed in the hope that it will be useful,
    ## but WITHOUT ANY WARRANTY; without even the implied warranty of
    ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    ## GNU General Public License for more details.

    ## You can find a copy of the GNU General Public License, Version 2 at:
    ## http://www.gnu.org/licenses/gpl-2.0.html

    calendarHeat <- function(dates,
    values,
    ncolors=99,
    color="r2g",
    varname="Values",
    date.form = "%Y-%m-%d", ...) {
    require(lattice)
    require(grid)
    require(chron)
    if (class(dates) == "character" | class(dates) == "factor" ) {
    dates <- strptime(dates, date.form)
    }
    caldat <- data.frame(value = values, dates = dates)
    min.date <- as.Date(paste(format(min(dates), "%Y"),
    "-1-1",sep = ""))
    max.date <- as.Date(paste(format(max(dates), "%Y"),
    "-12-31", sep = ""))
    dates.f <- data.frame(date.seq = seq(min.date, max.date, by="days"))

    # 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

    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("Calendar Heat Map of ", 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)
    }