aggiungere date al calendario mappa di calore R

sto tracciando una mappa di calore calendario utilizzando Paul Bleicher's calenderHeat.R code e questo è il mio terreno: aggiungere date al calendario mappa di calore R

mi chiedevo come avrei potuto aggiungere date alla trama, al posto delle griglie vuote. Ecco il mio dati di esempio:

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

e il codice per produrre la trama:

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

Ho cercato ovunque su internet e ha cercato da sola, ma la soluzione più vicina che ho trovato era uno che aggiunge le lettere come così:

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

enter image description here

Ti prego, aiutami a aggiungere le date dei mesi. Grazie in anticipo.

fonte

2014-10-02 maryam

Si dovrebbe almeno postale un link a dove è arrivata la soluzione: http://stackoverflow.com/questions/15014595/how-to-use-black-and-white-fill-patterns-instead-of-color-coding-on-calendar-hea o alla funzione extra.caledarHeat stessa poiché non è definita qui: https://gist.github.com/agstudy/5024781 – MrFlick

@MrFlick oh sì ci siamo molte cose che ho dovuto aggiungere al mio post e che mi è sfuggita la mente scusa – maryam

Non è una funzione molto estendibile. Comunque, potresti fare un intervento chirurgico per inserire il comportamento che ti piace. Dando per scontato che in un sistema in cui è possibile fonte il file da un indirizzo HTTPS, si potrebbe fare

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

Oppure si potrebbe usare il httr libreria

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

che ti porterà la versione originale del file. Ora siamo in grado di fare alcuni cambiamenti

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

Ora possiamo usare questa nuova versione della funzione per aggiungere nomi Data

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

È possibile modificare il codice come mai ti piace di regolare la stampa della data nomi modificando la funzione del pannello personalizzato che abbiamo creato sopra.

enter image description here

Naturalmente questo Edit è molto fragile. Se la funzione sorgente cambia, la nostra chirurgia potrebbe rompersi perché stiamo tirando fuori pezzi di codice per indice. Quindi, per essere sicuro, dopo aver ottenuto il funzionamento della funzione nel modo che preferisci, dovresti probabilmente dump() la tua versione di calendarHeat2 e source() se necessario.

fonte

2014-10-03 02:32:59 MrFlick

Grazie Mr.Flick. Questo funziona perfettamente. mancava '[' nella prima riga di '#change call to level plot' e ho modificato per sistemarlo. Ma ovviamente il cambiamento doveva essere di almeno 6 caratteri, quindi ho aggiunto un commento fittizio da qualche parte.Grazie mille per questo!! Grande aiuto!! – maryam

Mi dispiace per l'errore di battitura. Sono contento che tu abbia funzionato. – MrFlick

@MrFlick come dici sulla fragilità :-) dopo https://github.com/iascchen/VisHealth/commit/fb1f09837a030f1ecc003b9d0332de0447f596a8#diff-83440baae13165ef7fb3118e5cf40237 indici 'c (32,2,3)' dovrebbe essere cambiato in 'c (33 , 2,3) '. –

mi è piaciuto il answer da MrFlick ma ero alla ricerca di qualcosa di meno ingombrante e quindi cerco di stampare solo il giorno del mese in caso di Domenica:

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://stackoverflow.com/a/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")

fonte

2017-10-20 09:55:48

aggiungere date al calendario mappa di calore R

risposta

Problemi correlati