在日历热力图中添加日期

Question

在日历热力图中添加日期

11

我正在使用Paul Bleicher的calenderHeat.R代码绘制日历热力图，这是我的绘图结果:

我想知道如何添加日期到绘图中，而不是空白的网格。以下是我的示例数据:

structure(list(Date = c("2014-10-01", "2014-09-30", "2014-09-29", 
"2014-09-26", "2014-09-25", "2014-09-24", "2014-09-23", "2014-09-22", 
"2014-09-19", "2014-09-18", "2014-09-17", "2014-09-16", "2014-09-15", 
"2014-09-12", "2014-09-11", "2014-09-10", "2014-09-09", "2014-09-08", 
"2014-09-05", "2014-09-04", "2014-09-03", "2014-09-02", "2014-08-29", 
"2014-08-28", "2014-08-27", "2014-08-26", "2014-08-25", "2014-08-22", 
"2014-08-21", "2014-08-20", "2014-08-19", "2014-08-18", "2014-08-15", 
"2014-08-14", "2014-08-13", "2014-08-12", "2014-08-11", "2014-08-08", 
"2014-08-07", "2014-08-06", "2014-08-05", "2014-08-04", "2014-08-01", 
"2014-07-31", "2014-07-30", "2014-07-29", "2014-07-28", "2014-07-25", 
"2014-07-24", "2014-07-23", "2014-07-22", "2014-07-21", "2014-07-18", 
"2014-07-17", "2014-07-16", "2014-07-15", "2014-07-14", "2014-07-11", 
"2014-07-10", "2014-07-09", "2014-07-08", "2014-07-07", "2014-07-03", 
"2014-07-02", "2014-07-01", "2014-06-30", "2014-06-27", "2014-06-26", 
"2014-06-25", "2014-06-24", "2014-06-23", "2014-06-20", "2014-06-19", 
"2014-06-18", "2014-06-17", "2014-06-16", "2014-06-13", "2014-06-12", 
"2014-06-11", "2014-06-10", "2014-06-09", "2014-06-06", "2014-06-05", 
"2014-06-04", "2014-06-03", "2014-06-02", "2014-05-30", "2014-05-29", 
"2014-05-28", "2014-05-27", "2014-05-23", "2014-05-22", "2014-05-21", 
"2014-05-20", "2014-05-19", "2014-05-16", "2014-05-15", "2014-05-14", 
"2014-05-13", "2014-05-12", "2014-05-09", "2014-05-08", "2014-05-07", 
"2014-05-06", "2014-05-05", "2014-05-02", "2014-05-01", "2014-04-30", 
"2014-04-29", "2014-04-28", "2014-04-25", "2014-04-24", "2014-04-23", 
"2014-04-22", "2014-04-21", "2014-04-17", "2014-04-16", "2014-04-15", 
"2014-04-14", "2014-04-11", "2014-04-10", "2014-04-09", "2014-04-08", 
"2014-04-07", "2014-04-04", "2014-04-03", "2014-04-02", "2014-04-01", 
"2014-03-31", "2014-03-28", "2014-03-27", "2014-03-26", "2014-03-25", 
"2014-03-24", "2014-03-21", "2014-03-20", "2014-03-19", "2014-03-18", 
"2014-03-17", "2014-03-14", "2014-03-13", "2014-03-12", "2014-03-11", 
"2014-03-10", "2014-03-07", "2014-03-06", "2014-03-05", "2014-03-04", 
"2014-03-03", "2014-02-28", "2014-02-27", "2014-02-26", "2014-02-25", 
"2014-02-24", "2014-02-21", "2014-02-20", "2014-02-19", "2014-02-18", 
"2014-02-14", "2014-02-13", "2014-02-12", "2014-02-11", "2014-02-10", 
"2014-02-07", "2014-02-06", "2014-02-05", "2014-02-04", "2014-02-03", 
"2014-01-31", "2014-01-30", "2014-01-29", "2014-01-28", "2014-01-27", 
"2014-01-24", "2014-01-23", "2014-01-22", "2014-01-21", "2014-01-17", 
"2014-01-16", "2014-01-15", "2014-01-14", "2014-01-13", "2014-01-10", 
"2014-01-09", "2014-01-08", "2014-01-07", "2014-01-06", "2014-01-03", 
"2014-01-02", "2013-12-31", "2013-12-30", "2013-12-27", "2013-12-26", 
"2013-12-24", "2013-12-23", "2013-12-20", "2013-12-19", "2013-12-18", 
"2013-12-17", "2013-12-16", "2013-12-13", "2013-12-12", "2013-12-11", 
"2013-12-10", "2013-12-09", "2013-12-06", "2013-12-05", "2013-12-04", 
"2013-12-03", "2013-12-02", "2013-11-29", "2013-11-27", "2013-11-26", 
"2013-11-25", "2013-11-22", "2013-11-21", "2013-11-20", "2013-11-19", 
"2013-11-18", "2013-11-15", "2013-11-14", "2013-11-13", "2013-11-12", 
"2013-11-11", "2013-11-08", "2013-11-07", "2013-11-06", "2013-11-05", 
"2013-11-04", "2013-11-01", "2013-10-31", "2013-10-30", "2013-10-29", 
"2013-10-28", "2013-10-25", "2013-10-24", "2013-10-23", "2013-10-22", 
"2013-10-21", "2013-10-18", "2013-10-17", "2013-10-16", "2013-10-15", 
"2013-10-14", "2013-10-11", "2013-10-10", "2013-10-09", "2013-10-08", 
"2013-10-07", "2013-10-04", "2013-10-03", "2013-10-02", "2013-10-01", 
"2013-09-30", "2013-09-27", "2013-09-26", "2013-09-25", "2013-09-24", 
"2013-09-23", "2013-09-20", "2013-09-19", "2013-09-18", "2013-09-17", 
"2013-09-16", "2013-09-13", "2013-09-12", "2013-09-11", "2013-09-10", 
"2013-09-09", "2013-09-06", "2013-09-05", "2013-09-04", "2013-09-03", 
"2013-08-30", "2013-08-29", "2013-08-28", "2013-08-27", "2013-08-26", 
"2013-08-23", "2013-08-22", "2013-08-21", "2013-08-20", "2013-08-19", 
"2013-08-16", "2013-08-15", "2013-08-14", "2013-08-13", "2013-08-12"
), Adj.Close = c(45.9, 46.36, 46.44, 46.41, 46.04, 47.08, 46.56, 
47.06, 47.52, 46.68, 46.52, 46.76, 46.24, 46.7, 47, 46.84, 46.76, 
46.47, 45.91, 45.26, 44.96, 45.09, 45.43, 44.88, 44.87, 45.01, 
45.17, 45.15, 45.22, 44.95, 45.33, 44.83, 44.51, 44, 43.81, 43.25, 
42.93, 42.93, 42.96, 42.47, 42.81, 43.1, 42.59, 42.89, 43.31, 
43.62, 43.7, 44.22, 44.12, 44.59, 44.55, 44.56, 44.41, 44.25, 
43.81, 42.19, 41.88, 41.83, 41.43, 41.41, 41.52, 41.73, 41.54, 
41.64, 41.61, 41.44, 41.99, 41.46, 41.77, 41.49, 41.73, 41.42, 
41.25, 41.39, 41.42, 41.24, 40.97, 40.33, 40.61, 40.85, 41.01, 
41.22, 40.95, 40.07, 40.04, 40.54, 40.69, 40.09, 39.76, 39.94, 
39.87, 39.85, 40.1, 39.43, 39.5, 39.58, 39.35, 39.99, 40.17, 
39.44, 39.02, 39.12, 38.9, 38.55, 38.91, 39.17, 39.47, 39.87, 
39.98, 40.33, 39.38, 39.34, 39.17, 39.46, 39.41, 39.48, 39.87, 
39.23, 38.66, 38.69, 38.84, 39.94, 39.3, 39.28, 39.34, 40.47, 
40.81, 40.87, 40.45, 39.77, 38.84, 39.27, 39.81, 39.97, 39.63, 
39.8, 38.75, 39.03, 37.55, 37.2, 37.39, 37.77, 37.52, 37.32, 
37.4, 37.65, 37.61, 37.9, 37.28, 37.81, 37.36, 36.98, 37.05, 
37.19, 37.48, 37.25, 37.02, 36.93, 36.85, 36.84, 36.7, 36.41, 
36.05, 35.81, 35.44, 35.09, 35.6, 35.73, 37.06, 36.1, 35.91, 
35.53, 35.29, 36.05, 35.32, 35.19, 35.43, 35.63, 36.13, 36.01, 
35.05, 34.26, 35.3, 34.8, 35.03, 35.66, 35.39, 36.15, 36.4, 36.64, 
36.53, 36.53, 36.67, 36.32, 35.87, 36.05, 35.51, 35.83, 35.77, 
36.13, 35.94, 36.46, 36.84, 37.33, 37.92, 37.57, 37.22, 38.14, 
37.52, 37.66, 37.35, 36.83, 36.58, 36.87, 36.8, 36.63, 36.32, 
35.99, 36.16, 36.78, 36.96, 37.1, 36.32, 36.54, 36.73, 36.45, 
37.12, 35.62, 34.94, 34.54, 34.42, 34.55, 34.53, 34.58, 34.73, 
32.78, 32.82, 33.62, 34.01, 33.99, 33.95, 33.67, 33.53, 33.49, 
33.18, 32.82, 32.15, 32.09, 32.37, 32.94, 32.92, 32.97, 32.64, 
32.35, 32.34, 31.86, 31.6, 31.55, 31.83, 31.88, 32.7, 32.39, 
32.01, 31.89, 32.11, 31.78, 31.83, 31.49, 30.78, 30.28, 30.36, 
30.33, 30.99, 32.47, 32.61, 32.1, 32.33, 33.2, 33.78, 31.49, 
30.73, 30.74, 30.51, 30.91, 30.9, 31.45, 31.33, 31.73)), .Names = c("Date", 
"Adj.Close"), class = "data.frame", row.names = c(NA, -288L))

以及生成绘图的代码：

calendarHeat(stock.data$Date, stock.data$Adj.Close, varname="MSFT Adjusted Close")

我已经在互联网上搜索并尝试过自己解决，但最接近的解决方案是像这样添加字母：

p6 <- extra.calendarHeat(dates= stock.data$Date, values = stock.data$Adj.Close,
                     pvalues = stock.data$Volume,
                     varname="MSFT Adjusted Close  \n Volume as LETTERS symbols",
                     pch.symbol = letters,
                     color='r2b')

在此输入图片描述

请帮我添加月份的日期。提前致谢。

- Tavi

你至少应该发布一个解决方案的链接：https://dev59.com/7GUp5IYBdhLWcg3w1aF7 或者extra.caledarHeat函数本身的链接，因为它在这里没有定义：https://gist.github.com/agstudy/5024781 - MrFlick

@MrFlick，对啊，我的帖子里有很多东西我需要添加，但是我忘了，抱歉。 - Tavi

2个回答

2

我喜欢MrFlick的答案，但我想要更简洁的东西，所以我尝试只打印星期天的日期。

stock.data <- structure(list(Date = c("2014-10-01", "2014-09-30", "2014-09-29", 
"2014-09-26", "2014-09-25", "2014-09-24", "2014-09-23", "2014-09-22", 
"2014-09-19", "2014-09-18", "2014-09-17", "2014-09-16", "2014-09-15", 
"2014-09-12", "2014-09-11", "2014-09-10", "2014-09-09", "2014-09-08", 
"2014-09-05", "2014-09-04", "2014-09-03", "2014-09-02", "2014-08-29", 
"2014-08-28", "2014-08-27", "2014-08-26", "2014-08-25", "2014-08-22", 
"2014-08-21", "2014-08-20", "2014-08-19", "2014-08-18", "2014-08-15", 
"2014-08-14", "2014-08-13", "2014-08-12", "2014-08-11", "2014-08-08", 
"2014-08-07", "2014-08-06", "2014-08-05", "2014-08-04", "2014-08-01", 
"2014-07-31", "2014-07-30", "2014-07-29", "2014-07-28", "2014-07-25", 
"2014-07-24", "2014-07-23", "2014-07-22", "2014-07-21", "2014-07-18", 
"2014-07-17", "2014-07-16", "2014-07-15", "2014-07-14", "2014-07-11", 
"2014-07-10", "2014-07-09", "2014-07-08", "2014-07-07", "2014-07-03", 
"2014-07-02", "2014-07-01", "2014-06-30", "2014-06-27", "2014-06-26", 
"2014-06-25", "2014-06-24", "2014-06-23", "2014-06-20", "2014-06-19", 
"2014-06-18", "2014-06-17", "2014-06-16", "2014-06-13", "2014-06-12", 
"2014-06-11", "2014-06-10", "2014-06-09", "2014-06-06", "2014-06-05", 
"2014-06-04", "2014-06-03", "2014-06-02", "2014-05-30", "2014-05-29", 
"2014-05-28", "2014-05-27", "2014-05-23", "2014-05-22", "2014-05-21", 
"2014-05-20", "2014-05-19", "2014-05-16", "2014-05-15", "2014-05-14", 
"2014-05-13", "2014-05-12", "2014-05-09", "2014-05-08", "2014-05-07", 
"2014-05-06", "2014-05-05", "2014-05-02", "2014-05-01", "2014-04-30", 
"2014-04-29", "2014-04-28", "2014-04-25", "2014-04-24", "2014-04-23", 
"2014-04-22", "2014-04-21", "2014-04-17", "2014-04-16", "2014-04-15", 
"2014-04-14", "2014-04-11", "2014-04-10", "2014-04-09", "2014-04-08", 
"2014-04-07", "2014-04-04", "2014-04-03", "2014-04-02", "2014-04-01", 
"2014-03-31", "2014-03-28", "2014-03-27", "2014-03-26", "2014-03-25", 
"2014-03-24", "2014-03-21", "2014-03-20", "2014-03-19", "2014-03-18", 
"2014-03-17", "2014-03-14", "2014-03-13", "2014-03-12", "2014-03-11", 
"2014-03-10", "2014-03-07", "2014-03-06", "2014-03-05", "2014-03-04", 
"2014-03-03", "2014-02-28", "2014-02-27", "2014-02-26", "2014-02-25", 
"2014-02-24", "2014-02-21", "2014-02-20", "2014-02-19", "2014-02-18", 
"2014-02-14", "2014-02-13", "2014-02-12", "2014-02-11", "2014-02-10", 
"2014-02-07", "2014-02-06", "2014-02-05", "2014-02-04", "2014-02-03", 
"2014-01-31", "2014-01-30", "2014-01-29", "2014-01-28", "2014-01-27", 
"2014-01-24", "2014-01-23", "2014-01-22", "2014-01-21", "2014-01-17", 
"2014-01-16", "2014-01-15", "2014-01-14", "2014-01-13", "2014-01-10", 
"2014-01-09", "2014-01-08", "2014-01-07", "2014-01-06", "2014-01-03", 
"2014-01-02", "2013-12-31", "2013-12-30", "2013-12-27", "2013-12-26", 
"2013-12-24", "2013-12-23", "2013-12-20", "2013-12-19", "2013-12-18", 
"2013-12-17", "2013-12-16", "2013-12-13", "2013-12-12", "2013-12-11", 
"2013-12-10", "2013-12-09", "2013-12-06", "2013-12-05", "2013-12-04", 
"2013-12-03", "2013-12-02", "2013-11-29", "2013-11-27", "2013-11-26", 
"2013-11-25", "2013-11-22", "2013-11-21", "2013-11-20", "2013-11-19", 
"2013-11-18", "2013-11-15", "2013-11-14", "2013-11-13", "2013-11-12", 
"2013-11-11", "2013-11-08", "2013-11-07", "2013-11-06", "2013-11-05", 
"2013-11-04", "2013-11-01", "2013-10-31", "2013-10-30", "2013-10-29", 
"2013-10-28", "2013-10-25", "2013-10-24", "2013-10-23", "2013-10-22", 
"2013-10-21", "2013-10-18", "2013-10-17", "2013-10-16", "2013-10-15", 
"2013-10-14", "2013-10-11", "2013-10-10", "2013-10-09", "2013-10-08", 
"2013-10-07", "2013-10-04", "2013-10-03", "2013-10-02", "2013-10-01", 
"2013-09-30", "2013-09-27", "2013-09-26", "2013-09-25", "2013-09-24", 
"2013-09-23", "2013-09-20", "2013-09-19", "2013-09-18", "2013-09-17", 
"2013-09-16", "2013-09-13", "2013-09-12", "2013-09-11", "2013-09-10", 
"2013-09-09", "2013-09-06", "2013-09-05", "2013-09-04", "2013-09-03", 
"2013-08-30", "2013-08-29", "2013-08-28", "2013-08-27", "2013-08-26", 
"2013-08-23", "2013-08-22", "2013-08-21", "2013-08-20", "2013-08-19", 
"2013-08-16", "2013-08-15", "2013-08-14", "2013-08-13", "2013-08-12"
), Adj.Close = c(45.9, 46.36, 46.44, 46.41, 46.04, 47.08, 46.56, 
47.06, 47.52, 46.68, 46.52, 46.76, 46.24, 46.7, 47, 46.84, 46.76, 
46.47, 45.91, 45.26, 44.96, 45.09, 45.43, 44.88, 44.87, 45.01, 
45.17, 45.15, 45.22, 44.95, 45.33, 44.83, 44.51, 44, 43.81, 43.25, 
42.93, 42.93, 42.96, 42.47, 42.81, 43.1, 42.59, 42.89, 43.31, 
43.62, 43.7, 44.22, 44.12, 44.59, 44.55, 44.56, 44.41, 44.25, 
43.81, 42.19, 41.88, 41.83, 41.43, 41.41, 41.52, 41.73, 41.54, 
41.64, 41.61, 41.44, 41.99, 41.46, 41.77, 41.49, 41.73, 41.42, 
41.25, 41.39, 41.42, 41.24, 40.97, 40.33, 40.61, 40.85, 41.01, 
41.22, 40.95, 40.07, 40.04, 40.54, 40.69, 40.09, 39.76, 39.94, 
39.87, 39.85, 40.1, 39.43, 39.5, 39.58, 39.35, 39.99, 40.17, 
39.44, 39.02, 39.12, 38.9, 38.55, 38.91, 39.17, 39.47, 39.87, 
39.98, 40.33, 39.38, 39.34, 39.17, 39.46, 39.41, 39.48, 39.87, 
39.23, 38.66, 38.69, 38.84, 39.94, 39.3, 39.28, 39.34, 40.47, 
40.81, 40.87, 40.45, 39.77, 38.84, 39.27, 39.81, 39.97, 39.63, 
39.8, 38.75, 39.03, 37.55, 37.2, 37.39, 37.77, 37.52, 37.32, 
37.4, 37.65, 37.61, 37.9, 37.28, 37.81, 37.36, 36.98, 37.05, 
37.19, 37.48, 37.25, 37.02, 36.93, 36.85, 36.84, 36.7, 36.41, 
36.05, 35.81, 35.44, 35.09, 35.6, 35.73, 37.06, 36.1, 35.91, 
35.53, 35.29, 36.05, 35.32, 35.19, 35.43, 35.63, 36.13, 36.01, 
35.05, 34.26, 35.3, 34.8, 35.03, 35.66, 35.39, 36.15, 36.4, 36.64, 
36.53, 36.53, 36.67, 36.32, 35.87, 36.05, 35.51, 35.83, 35.77, 
36.13, 35.94, 36.46, 36.84, 37.33, 37.92, 37.57, 37.22, 38.14, 
37.52, 37.66, 37.35, 36.83, 36.58, 36.87, 36.8, 36.63, 36.32, 
35.99, 36.16, 36.78, 36.96, 37.1, 36.32, 36.54, 36.73, 36.45, 
37.12, 35.62, 34.94, 34.54, 34.42, 34.55, 34.53, 34.58, 34.73, 
32.78, 32.82, 33.62, 34.01, 33.99, 33.95, 33.67, 33.53, 33.49, 
33.18, 32.82, 32.15, 32.09, 32.37, 32.94, 32.92, 32.97, 32.64, 
32.35, 32.34, 31.86, 31.6, 31.55, 31.83, 31.88, 32.7, 32.39, 
32.01, 31.89, 32.11, 31.78, 31.83, 31.49, 30.78, 30.28, 30.36, 
30.33, 30.99, 32.47, 32.61, 32.1, 32.33, 33.2, 33.78, 31.49, 
30.73, 30.74, 30.51, 30.91, 30.9, 31.45, 31.33, 31.73)), .Names = c("Date", 
"Adj.Close"), class = "data.frame", row.names = c(NA, -288L))


# see https://dev59.com/cOo6XIcBkEYKwwoYIAkf#26172503
# based on https://raw.githubusercontent.com/iascchen/VisHealth/master/R/calendarHeat.R
calendarHeat2 <- 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"))
  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$dom <- as.numeric(format(caldat$date.seq, "%d"))
  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)
  r2b <- c("#0571B0", "#92C5DE", "#F7F7F7", "#F4A582", "#CA0020")
  r2g <- c("#D61818", "#FFAE63", "#FFFFBD", "#B5E384")
  w2b <- c("#045A8D", "#2B8CBE", "#74A9CF", "#BDC9E1", "#F1EEF6")
  g2r <- c("#B5E384", "#FFFFBD", "#FFAE63", "#D61818")
  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 = 0.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, dom = caldat$dom, dotw = caldat$dotw,
                              panel = function(x, y, subscripts, dom, dotw, ...) {
                                panel.levelplot(x, y, subscripts = subscripts, ...)
                                sunday <- 0
                                flag<-dotw[subscripts]==rep(sunday,length(dotw))
                                dom <- mapply(function(value,flag){if(flag){as.character(value)}else{""}},dom,flag)
                                panel.text(x[subscripts], y[subscripts], labels = dom[subscripts])

                              }))
  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)
}


calendarHeat2(stock.data$Date, stock.data$Adj.Close, varname="MSFT Adjusted Close")

- Alessandro Jacopson

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- MrFlick · Accepted Answer

这个函数不是很可扩展。但是，您可以进行一些操作以插入所需的行为。假设您在能够从https地址获取文件的系统上，您可以执行以下操作：

source("https://raw.githubusercontent.com/iascchen/VisHealth/master/R/calendarHeat.R")

或者您可以使用httr库。

library(httr)
cat(content(GET("https://raw.githubusercontent.com/iascchen/VisHealth/master/R/calendarHeat.R"), "text"), file="calendarHeat.R")
source("calendarHeat.R")

那将为您获取文件的原始版本。现在我们可以进行一些更改。

#copy
calendarHeat2<-calendarHeat

#insert line to calulate day number
bl<-as.list(body(calendarHeat2))
body(calendarHeat2) <- as.call(c(
    bl[1:14], 
    quote(caldat$dom <- as.numeric(format(caldat$date.seq, "%d"))),
    bl[-(1:14)]
))

#change call to level plot
lp<-as.list(body(calendarHeat2)[[c(32,2,3)]])
lp$dom <- quote(caldat$dom)
lp$panel <- quote(function(x,y,subscripts,dom,...) {
    panel.levelplot(x,y,subscripts=subscripts,...)
    panel.text(x[subscripts],y[subscripts],labels=dom[subscripts])
})
body(calendarHeat2)[[c(32,2,3)]]<-as.call(lp)

现在，我们可以使用这个新版本的函数来添加日期名称。

calendarHeat2(stock.data$Date, stock.data$Adj.Close, varname="MSFT Adjusted Close")

你可以通过修改我们上面创建的自定义面板函数来调整日期名称的打印方式，任意调整代码以满足需求。

输入图像描述

当然，这种编辑操作非常脆弱。如果源函数发生变化，我们提取代码块的索引可能会导致失败。因此，为了安全起见，在满足您的要求后，您应该dump()您的calendarHeat2版本，并根据需要进行source()。