Close

Photo calender using R

Create an elegant photo calendar completely using R.

I had this idea of using some of my travel photos to create a photo calendar. I would normally go about it using Adobe Photoshop or Adobe Illustrator. But, that would involve a lot of manual work placing dates and days for each month. I would also like to mark some public holidays and friend’s birthdays. So, I wondered if it might be possible to do it with R. After fiddling about with it over the weekend, I managed to make it work. It went better than I expected. And here I am recreating the calendar using some stock photos. All stock photos are royalty-free from Pexels. For the impatient ones, the whole code and images are available at this Github repository. For detailed guide, keep reading.

The calendar is designed in A3 size format. Twelve photos are selected, labelled 1.jpg to 12.jpg. The photos are first sized to exactly A3 size using an image editing software and placed in a directory labelled ‘images’. A text file is prepared with important dates and description such as holidays, birthdays etc. Another text file is prepared with month and photo caption.

The packages required are loaded.

# load libraries
library(ggplot2) # for plotting
library(stringr) # for text processing
library(Cairo) # for graphics
library(extrafont) # for custom fonts
library(png) # read png
library(jpeg) # read jpeg

I use the font Gidole for the calendar. This was installed on my system and imported using the package ‘extrafont’. I follow the workflow for Windows OS. Mac and linux users might need different commands for configuring font.

# prepare fonts
font_import(pattern="Gidole",prompt=FALSE)
loadfonts(device="win")
windowsFonts(sans="Gidole")

Export image size is set as A3. An extra 6 mm bleed edges is added to aid in trimming the print.

img_bleed <- 6
img_height <- 297+(img_bleed*2)
img_width <- 420+(img_bleed*2)
img_dpi <- 300
img_units <- "mm"
export <- "png"

The raw calendar dates are prepared.

# PREPARE CALENDAR DATA.FRAME
dates <- seq(as.Date("2018-01-01"),as.Date("2018-12-31"),"days")
df_raw <- data.frame(fulldate=as.character(dates),
                  date=as.numeric(strftime(dates,format="%d")),
                  month=as.numeric(strftime(dates,format="%m")),
                  year=strftime(dates,format="%Y"),
                  day=strftime(dates,format="%a"),
                  week=strftime(dates,format="%W"),
                  stringsAsFactors=F)

Marked dates with description are read in.

# read marked dates and description
marked <- read.delim("marked.txt",sep="\t",header=T,stringsAsFactors=F)<br>
> head(marked)
    date                 description           type
1 Jan 01              New Year's Day public holiday
2 Mar 20              Spring Equinox           none
3 Mar 25 Daylight Saving Time Starts           none
4 Mar 30                 Good Friday public holiday
5 Mar 31               Holy Saturday   half holiday
6 Apr 01                  Easter Day public holiday

Multi word descriptions are split to two lines. New line character ‘\n’ is added to the last space in the description. Character dates is converted to actual R dates.

# add newline to last space in the description
marked$description <- str_replace(marked$description," [:alnum:]+$",str_replace(str_extract(marked$description," [:alnum:]+$")," ","\n"))
# create R dates
marked$fulldate <- as.character(strftime(as.Date(str_replace_all(paste0(marked$date," 2018")," ","-"),format="%b-%d-%Y"),format="%Y-%m-%d"))
# identify duplicate dates if any
marked[which(duplicated(marked$fulldate)),]
# remove character date
marked$date <- NULL
> head(marked)
                   description           type   fulldate
1              New Year's\nDay public holiday 2018-01-01
2              Spring\nEquinox           none 2018-03-20
3 Daylight Saving Time\nStarts           none 2018-03-25
4                 Good\nFriday public holiday 2018-03-30
5               Holy\nSaturday   half holiday 2018-03-31
6                  Easter\nDay public holiday 2018-04-01

Marked dates are merged with the calendar. Empty descriptions ‘NA’ are marked as ‘not important’. Weekends and public holidays are assigned the font colour red and birthdays are assigned the font colour blue. Start of week is marked. Based on the newline character added previously, descriptions are split into two for plotting on two lines.

# merge calendar and marked dates
df_cal <- merge(df_raw,marked,by="fulldate",all.x=T)
# mark NA descriptions as not important
df_cal$type[is.na(df_cal$type)] <- "not important"
# assign red colour to public holidays and weekends
df_cal$holiday <- ifelse(df_cal$day=="Sat"|df_cal$day=="Sun"|df_cal$type=="public holiday","#e41a1c","grey20")
# assign blue colour to birthdays
df_cal$holiday[df_cal$type=="birthday"] <- "steelblue"
# mark start of week
df_cal$week <- ifelse(df_cal$day=="Mon",df_cal$week,NA)
# alpha of background shape for week
df_cal$weekbgalpha <- ifelse(is.na(df_cal$week),0,1)
# split description into two lines
df_cal$description <- paste0(df_cal$description,"\nx")
df_cal$description1 <- sapply(strsplit(df_cal$description,"\n"),"[[",1)
df_cal$description2 <- sapply(strsplit(df_cal$description,"\n"),"[[",2)
df_cal$description1[df_cal$description1=="NA"] <- NA
df_cal$description2[df_cal$description2=="x"] <- NA
> head(df_cal)
    fulldate date month year day week        description           type
1 2018-01-01    1     1 2018 Mon   01 New Year's\nDay\nx public holiday
2 2018-01-02    2     1 2018 Tue <NA>              NA\nx  not important
3 2018-01-03    3     1 2018 Wed <NA>              NA\nx  not important
4 2018-01-04    4     1 2018 Thu <NA>              NA\nx  not important
5 2018-01-05    5     1 2018 Fri <NA>              NA\nx  not important
6 2018-01-06    6     1 2018 Sat <NA>              NA\nx  not important
  holiday weekbgalpha description1 description2
1 #e41a1c           1   New Year's          Day
2  grey20           0         <NA>         <NA>
3  grey20           0         <NA>         <NA>
4  grey20           0         <NA>         <NA>
5  grey20           0         <NA>         <NA>
6 #e41a1c           0         <NA>         <NA>

Image captions and caption colour file is read in.

# prepare image captions
cap <- read.delim("captions.txt",header=T,stringsAsFactors=F)
> head(cap)
  month               description textcol
1     1           Snowy landscape  grey20
2     2    Snowfall on the leaves  grey20
3     3 Blue waters and mountains  grey20
4     4              Flower macro  grey20
5     5         Lady in the woods  grey20
6     6           Field of barley  grey20

Positions of the various text elements are defined bottom-up. ‘basepos’ is an arbitrary base line position which helps to move all text up or down. ‘markpos1’ defines second line of marked date description, ‘markpos2’ defines first line of marked date description. ‘datepos’ defines the row of date numbers. ‘daypos’ defines the row of day text. ‘weekpos’ defines the row of week numbers. ‘monthpos’ defines the position of the month.

# set text position variables
basepos <- 0.35
df_cal$markpos1 <- basepos+0.08
df_cal$markpos2 <- df_cal$markpos1[1]+0.12
df_cal$datepos <- df_cal$markpos2[1]+0.20
df_cal$daypos <- df_cal$datepos[1]+0.25
df_cal$weekpos <- df_cal$daypos[1]+0.25
df_cal$monthpos <- df_cal$weekpos[1]+0.26
> head(df_cal)

    fulldate date month year day week        description           type
1 2018-01-01    1     1 2018 Mon   01 New Year's\nDay\nx public holiday
2 2018-01-02    2     1 2018 Tue <NA>              NA\nx  not important
3 2018-01-03    3     1 2018 Wed <NA>              NA\nx  not important
4 2018-01-04    4     1 2018 Thu <NA>              NA\nx  not important
5 2018-01-05    5     1 2018 Fri <NA>              NA\nx  not important
6 2018-01-06    6     1 2018 Sat <NA>              NA\nx  not important
  holiday weekbgalpha description1 description2 markpos1 markpos2
1 #e41a1c           1   New Year's          Day     0.43     0.55
2  grey20           0         <NA>         <NA>     0.43     0.55
3  grey20           0         <NA>         <NA>     0.43     0.55
4  grey20           0         <NA>         <NA>     0.43     0.55
5  grey20           0         <NA>         <NA>     0.43     0.55
6 #e41a1c           0         <NA>         <NA>     0.43     0.55
  datepos daypos weekpos monthpos
1    0.75      1    1.25     1.51
2    0.75      1    1.25     1.51
3    0.75      1    1.25     1.51
4    0.75      1    1.25     1.51
5    0.75      1    1.25     1.51
6    0.75      1    1.25     1.51

The loop reads the image for each month and converts to a grob. A ggplot object is created and the calendar along with the markings are printed. The ggplot object and the image grob are combined and exported.

# EXPORT LOOP
# loop to create and export monthwise
levs <- levels(factor(df_cal$month))
for(i in 1:length(levs))
{
  fullmonth <- month.name[i]
  message(paste0("Running ",fullmonth," ..."))
  
  # subset one month
  single <- subset(df_cal,df_cal$month==i)
  
  # read background image
  #pic <- readPNG(paste0("./images/",i,".png"))
  pic <- readJPEG(paste0("./images/",i,".jpg"))
  pic1 <- grid::rasterGrob(pic)
  pic1$width <- unit(1, "npc") 
  pic1$height <- unit(1, "npc")
  
  # create final image
  p <- ggplot(single)+
    # background image
    annotation_custom(pic1)+
    # background rectangle 1
    annotate("rect",xmin=-Inf,xmax=Inf,ymin=0,ymax=single$weekpos[1],alpha=1,fill="white")+
    # background rectangle 2
    annotate("rect",xmin=-Inf,xmax=Inf,ymin=single$weekpos[1],ymax=single$weekpos[1]+0.4,alpha=0.6,fill="white")+
    # month title text faded with year
    annotate("text",x=1,y=single$monthpos[1],label=paste0(fullmonth," 2018"),size=7,hjust=0,col="grey40",fontface="bold")+
    # month title text
    annotate("text",x=1,y=single$monthpos[1],label=fullmonth,size=7,hjust=0,col="grey20",fontface="bold")+
    # image description text
    annotate("text",x=single$date[nrow(single)],y=single$monthpos[1],label=cap$description[i],size=4,hjust=1,col=cap$textcol[i])+
    # week background circle
    geom_point(aes(x=date,y=weekpos),size=11,colour="grey90",alpha=single$weekbgalpha,shape=20)+
    # week text
    geom_text(aes(x=date,y=weekpos),label=single$week,size=3,col="grey20",fontface="bold")+
    # day text
    geom_text(aes(x=date,y=daypos),label=single$day,size=4.8,col=single$holiday)+
    # date text
    geom_text(aes(x=date,y=datepos),label=single$date,size=7.5,col=single$holiday)+
    # important information text line 1
    geom_text(aes(x=date,y=markpos1),label=single$description2,size=2.8,col="grey20",vjust=1)+
    # important information text line 2
    geom_text(aes(x=date,y=markpos2),label=single$description1,size=2.8,col="grey20",vjust=1)+
    # limit scales
    scale_x_continuous(limits=c(0,max(single$date)+1),expand=c(0,0.6))+
    scale_y_continuous(limits=c(0,10),expand=c(0,0))+
    labs(x=NULL,y=NULL)+
    theme_bw(base_family="Gidole")+
    # remove graph elements
    theme(plot.background=element_rect(fill="transparent",colour=NA),
          plot.margin = margin(c(0,0,0,0)),
          axis.title = element_blank(),
          axis.text = element_blank(),
          axis.ticks = element_blank(),
          axis.ticks.length = unit(0,"pt"),
          axis.line = element_blank(),
          panel.grid = element_blank(),
          panel.border = element_blank(),
          panel.background=element_rect(fill="transparent",colour=NA),
          panel.ontop=TRUE)
  
  # export image
  if(export=="png")
  {
    png(filename=paste0(single$month[1],".png"),height=img_height,
         width=img_width,res=img_dpi,units=img_units,family="Gidole",
         bg="transparent",type="cairo")
    print(p)
    dev.off()
    message(paste0("Exported ",single$month[1],".png"))
  }
  
  if(export=="tiff")
  {
    tiff(filename=paste0(single$month[1],".tiff"),height=img_height,
              width=img_width,res=img_dpi,units=img_units,family="Gidole",
              compression="lzw",type="cairo",bg="transparent")
    print(p)
    dev.off()
    message(paste0("Exported ",single$month[1],".tiff"))
  }
  
  if(export=="pdf")
  {
    pdf(file=paste0(single$month[1],".pdf"),height=round(img_height*0.039,0),
        width=round(img_width*0.039,0),family="Gidole")
    print(p)
    dev.off()
    message(paste0("Exported ",single$month[1],".pdf"))
  }
}

I created a cover page as well. If you are interested in the font, the script font is Bira and the slim sans-serif font is Gidole.

The images are exported in png format here. But for print, PNG is not an ideal format. Instead, JPEG or pdf might be better. I imported all the PNGs into Adobe Indesign and created a single print quality PDF. You can also set 6 mm of bleed edges in Indesign. I sent the PDF off to print and the results were glorious. Go forth and let your creativity flow. Make yourself a calendar for next year.

The full code along with images are available at this Github repository.

About the author Roy Francis

All posts by Roy Francis →

Leave a Reply

Your email address will not be published. Required fields are marked *