trinker
10-28-2011, 09:17 PM
Saw this calendar function on stockoverflowtonight. Thought I'd pass this along. not sure of how I'll use it yet but something for the bag o tricks. I gave the link and the code. Slightly altered the code to return current month if no arguments are supplied.
http://stackoverflow.com/questions/7919998/basic-calendar-display-in-r
cal <- function(month, year) {
if(missing(year)& missing(month)){
month=as.numeric(which(month.abb==substr(date(),5,7)))
year=as.numeric(substr(date(),23,24))
}
if(!require(chron)) stop('Unable to load chron package')
if(missing(year) || missing(month)){ # year calendar
if(missing(year)) year <- month
par(mfrow=c(4,3))
tmp <- seq.dates( from=julian(1,1,year), to=julian(12,31,year) )
tmp2 <- month.day.year(tmp)
wd <- do.call(day.of.week, tmp2)
par(mar=c(1.5,1.5,2.5,1.5))
for(i in 1:12){
w <- tmp2$month == i
cs <- cumsum(wd[w]==0)
if(cs[1] > 0) cs <- cs - 1
nr <- max( cs ) + 1
plot.new()
plot.window( xlim=c(0,6), ylim=c(0,nr+1) )
text( wd[w], nr - cs -0.5 , tmp2$day[w] )
title( main=month.name[i] )
text( 0:6, nr+0.5, c('S','M','T','W','T','F','S') )
}
} else { # month calendar
ld <- seq.dates( from=julian(month,1,year), length=2, by='months')[2]-1
days <- seq.dates( from=julian(month,1,year), to=ld)
tmp <- month.day.year(days)
wd <- do.call(day.of.week, tmp)
cs <- cumsum(wd == 0)
if(cs[1] > 0) cs <- cs - 1
nr <- max(cs) + 1
par(oma=c(0.1,0.1,4.6,0.1))
par(mfrow=c(nr,7))
par(mar=c(0,0,0,0))
for(i in seq_len(wd[1])){
plot.new()
#box()
}
day.name <- c('Sun','Mon','Tues','Wed','Thur','Fri','Sat')
for(i in tmp$day){
plot.new()
box()
text(0,1, i, adj=c(0,1))
if(i < 8) mtext( day.name[wd[i]+1], line=0.5,
at=grconvertX(0.5,to='ndc'), outer=TRUE )
}
mtext(month.name[month], line=2.5, at=0.5, cex=1.75, outer=TRUE)
#box('inner') #optional
}
}
#==================
#EXAMPLES
#==================
cal(month=11,year=11)
cal(10,11)
cal(12)
cal()
http://stackoverflow.com/questions/7919998/basic-calendar-display-in-r
cal <- function(month, year) {
if(missing(year)& missing(month)){
month=as.numeric(which(month.abb==substr(date(),5,7)))
year=as.numeric(substr(date(),23,24))
}
if(!require(chron)) stop('Unable to load chron package')
if(missing(year) || missing(month)){ # year calendar
if(missing(year)) year <- month
par(mfrow=c(4,3))
tmp <- seq.dates( from=julian(1,1,year), to=julian(12,31,year) )
tmp2 <- month.day.year(tmp)
wd <- do.call(day.of.week, tmp2)
par(mar=c(1.5,1.5,2.5,1.5))
for(i in 1:12){
w <- tmp2$month == i
cs <- cumsum(wd[w]==0)
if(cs[1] > 0) cs <- cs - 1
nr <- max( cs ) + 1
plot.new()
plot.window( xlim=c(0,6), ylim=c(0,nr+1) )
text( wd[w], nr - cs -0.5 , tmp2$day[w] )
title( main=month.name[i] )
text( 0:6, nr+0.5, c('S','M','T','W','T','F','S') )
}
} else { # month calendar
ld <- seq.dates( from=julian(month,1,year), length=2, by='months')[2]-1
days <- seq.dates( from=julian(month,1,year), to=ld)
tmp <- month.day.year(days)
wd <- do.call(day.of.week, tmp)
cs <- cumsum(wd == 0)
if(cs[1] > 0) cs <- cs - 1
nr <- max(cs) + 1
par(oma=c(0.1,0.1,4.6,0.1))
par(mfrow=c(nr,7))
par(mar=c(0,0,0,0))
for(i in seq_len(wd[1])){
plot.new()
#box()
}
day.name <- c('Sun','Mon','Tues','Wed','Thur','Fri','Sat')
for(i in tmp$day){
plot.new()
box()
text(0,1, i, adj=c(0,1))
if(i < 8) mtext( day.name[wd[i]+1], line=0.5,
at=grconvertX(0.5,to='ndc'), outer=TRUE )
}
mtext(month.name[month], line=2.5, at=0.5, cex=1.75, outer=TRUE)
#box('inner') #optional
}
}
#==================
#EXAMPLES
#==================
cal(month=11,year=11)
cal(10,11)
cal(12)
cal()