02_plot_heatmap_n1ATP.Rmd

---
title: "02_heatmap_n1_ATP"
author: "Duc-Quang Nguyen"
date: "26 June 2016"
output: html_document
---

```{r setup, include=FALSE}
library(zoo)
library(dplyr)
library(magrittr)
library(tidyr)
library(ggplot2)
library(scales)
library(swiTheme)
library(htmltools)
library(swiRcharts)
library(RColorBrewer)

hackLastDate <- T
hackRepeatLastWeek <- T
atpRanking.file <- "input/alln1_ATP_ranking.csv"
n1_nationality.file <- "input/alln1_nationlity.csv"
trad.file <- "input/All n°1 ATP ranking heatmap - Sheet1.csv"
annotation.file <- "input/All n°1 ATP ranking heatmap - annotations.csv"

if(exists("trad.file")) {
  txt <- read.csv(trad.file, row.names = 1, stringsAsFactors = F)
  # discard incomplete translations
  cidx <- unique(which(txt =="" | is.na(txt), T)[,2])
  if(length(cidx > 0)) {
    warning(paste(colnames(txt)[cidx], collapse = "\t"), " languages will be discarded!", "\n")
    txt <- txt[,-cidx, drop = F]
  }
  colnames(txt)  
}

if(exists("annotation.file")) {
    annot <- read.csv(annotation.file, row.names = 1, stringsAsFactors = F)  
    stopifnot(all(rownames(annot) %in% rownames(txt)))
    annot$x <- as.Date(paste0(annot$x, "-01-01"))
    annot$x0 <- as.Date(paste0(annot$x0, "-06-01"))
    annot$x1 <- as.Date(paste0(annot$x1, "-06-01"))
 }
```

```{r shape data}
# load data
n1rank <- read.csv(atpRanking.file, check.names = F, row.names = 1)

nat <- read.csv(n1_nationality.file, stringsAsFactors = F)
nat <- structure(nat[,2], names = nat[,1])
# convert to zoo
zn1 <- zoo(as.matrix(n1rank), as.Date(row.names(n1rank), format = "%m/%d/%Y"))
dates <- index(zn1)
date.reg <- c(seq(min(dates), max(dates), 7))
date.reg <- date.reg[order(date.reg)]

## hack the last date!!
if(hackLastDate) date.reg <- c(date.reg, max(dates))

idx <- findInterval(date.reg, index(zn1), rightmost.closed = FALSE, all.inside = FALSE)
eq.zn1 <- zoo(unclass(zn1)[idx,], date.reg)

stopifnot(!any(duplicated(index(eq.zn1))) )
ranks <- max(eq.zn1, na.rm =T)

# ugly hack to fill ranking before 1985
dateLabel <- rep("", length(date.reg))
ii <- which(!duplicated(format(date.reg, format = "%Y")))
dateLabel[ii[-1]] <- format(date.reg[ii[-1]], "%Y")
dateLabel[ii[1]] <- format(date.reg[ii[1]], "%Y-%m-%d")

# tranform back zoo to data.frame for ggplot2
n1 <- as.data.frame(eq.zn1)
n1 <- cbind(dates = as.Date(as.character(rownames(n1))), n1)
rownames(n1) <- NULL

n1 %<>% gather(player, rank, -dates)
n1$lrank <- log10(n1$rank)

# order data.frame by chronological order of players when they reached n1
n1.dates <- n1 %>% 
  group_by(player) %>% summarise(first1 = dates[min(which(rank == 1))]) %>% 
  ungroup() %>% arrange(first1)
#  make ordered factor player
n1$player <- factor(n1$player, levels = rev(n1.dates$player))

# check dates spacing
if(!hackLastDate) stopifnot(all(diff(unique(n1$dates))==7))

narow <- n1 %>% group_by(dates) %>% 
  summarise(narow = all(is.na(rank))) %>% ungroup()
naidx <- which(narow %>% select(narow) %>% unlist())
if(length(naidx)>0) {
  warning(narow[naidx,], " hack will ensue")
  naDates <- as.Date(unlist(narow[naidx,'dates']), use.names = F)
  
  n1$dates.end <- n1$dates + 7
  # for NA dates, discard data and add a week to dates.end
  n1 %<>% filter(!dates %in% naDates)
  n1[which(n1$dates %in% (naDates-7)), 'dates.end'] <- n1[which(n1$dates %in% (naDates-7)), 'dates.end'] + 7
}

if(hackRepeatLastWeek) {
  n1.rep <- n1 %>% filter(dates == max(dates))
  n1.rep %<>% mutate(
    dates = dates + 7,
    dates.end = dates.end + 7
  )
  n1 <- bind_rows(n1, n1.rep) %>%
    arrange(dates)
}

```

## Plot

* Check this use of [geom_rect](https://nsaunders.wordpress.com/2015/04/15/project-tycho-ggplot2-and-the-shameless-stealing-of-blog-ideas/)

```{r heatmap}
## Helpers and settings
htheme <- function(base_family = "OpenSans-CondensedLight", subtitle.size = 15) {
  swi_theme(y_gridlines = F, base_family = base_family) + 
    theme(
      plot.subtitle = element_text(size=subtitle.size, margin=margin(b = 10)),
      plot.title = element_text(size = 19, margin=margin(b = 10)),
      axis.ticks.length = unit(1.7, "pt"),
      axis.ticks.y = element_blank(),
      axis.text.y = element_blank(),
      axis.line = element_blank(),
      axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5, size = 11, colour = "#1a1a1a" ),
      axis.title = element_blank(),
      legend.text = element_text(size = 11, vjust = 0),
      legend.title = element_text(size = 12, hjust = 0.5, vjust = 1, colour = "#595959"),
      legend.position = c(1, 1.08),
      legend.justification = c(1,1),
      legend.key.height = unit(2.4, "lines"),
      legend.key.width = unit(1.6, "lines"),
      plot.margin = unit(c(0.1, 0.1, 0.1, 0.15), "cm")
    )
}

rect.h <- 9.5
rect.spacing <- 0.5
rect.y <- rect.h + rect.spacing
plab.offset <- 7 * 23

# define ymin & ymax for geom_rect
n1r <- do.call(rbind, lapply(1:nlevels(n1$player), function(i) {
  cbind(
    n1 %>% filter(player == levels(n1$player)[i]), 
    ymin = rect.y * (i-1),
    ymax = (rect.y * (i-1)) + rect.h
  )
}))
n1r %<>% group_by(player) %>% mutate(y = (ymin + ymax + rect.spacing) / 2) %>% ungroup()

# define the rect labels, player name
player.lab <- n1r %>% group_by(player, y) %>% 
  summarise(x = dates[max(which(!is.na(rank)))] + plab.offset) %>% ungroup()
# hack to manually aligned some player names vertically
player.lab.aligned <- player.lab
player.lab.aligned[26:25, 'x'] <- player.lab[26, 'x']
player.lab.aligned[24:19, 'x'] <- player.lab[player.lab$player == "Stefan Edberg", 'x']
player.lab.aligned[18:17, 'x'] <- player.lab[player.lab$player == "Jim Courier", 'x']
player.lab.aligned[14:8, 'x'] <- player.lab[14, 'x']
player.lab.aligned[1:7, 'x'] <- player.lab[1, 'x']
player.lab.aligned$key <- gsub(" ", "\\.", player.lab.aligned$player)
# tmp <- data.frame(key = gsub(" ", "\\.", player.lab.aligned$player), value = paste0(player.lab.aligned$player, " (", nat[match(player.lab.aligned$player, names(nat))], ")"))
# write.csv(tmp, file = "input/number1Player_names.csv", row.names = F)

years <- unique(format(unique(n1r$dates), "%Y"))

## PLOT ##
lang <- 'ZH'

for (lang in colnames(txt)) {
  png.outfile <- paste0("heatmap_alln1ATP_", lang, ".png")
  html.outfile <-  paste0("heatmap_alln1ATP_", lang, ".html")
  teaser.outfile <- "teaser_alln1ATP.png"
  
  # ugly hack for Japanese
  if(lang == "JA") {player.lab.aligned$x <- player.lab.aligned$x - (7 * 16)}
  
  # get the annotations and player name translations
  anno <- cbind(annot, txt = txt[rownames(annot), lang], stringsAsFactors = F)
  player.lab.aligned$player <- txt[player.lab.aligned$key, lang]
  
  # apply linebreaks to each text chunk
  for(i in 1:nrow(anno)) {
    anno[i, 'txt'] <- paste0(strwrap(anno[i, 'txt'], width = anno[i, 'lineLength']), collapse ="\n")
  }

  hatp <- ggplot(n1r) + 
    geom_rect(
      aes(xmin = dates, xmax = dates.end, ymin = ymin, ymax = ymax, fill = lrank)) + 
   htheme(base_family = txt["base.typeface", lang], subtitle.size = as.numeric(txt['subtitle.size', lang])) +
    # to overwrite colour label scale legend
    scale_fill_gradientn(
      name = txt["legend.title", lang],
      colours = rev(colorRampPalette(brewer.pal(9,"RdPu"))(255)),
      na.value = "transparent",
      labels = as.character(c(10^0, 10^1, 10^2, 10^3))
    ) + 
    scale_x_date(
      name = "",
     # position = "top",
      breaks = c(min(n1r$dates), as.Date(paste0(years[-c(1)], "-01-01")), max(n1r$dates)),
      labels =  c(as.character(min(n1r$dates)), 
                  gsub("(1974|2018)", "", years[-c(1)]), 
                  ifelse(hackRepeatLastWeek, as.character(max(n1r$dates)-7), as.character(max(n1r$dates)))),
      expand = c(0, 0), 
      limits = c(min(n1r$dates), max(n1r$dates) + as.numeric(txt['xaxis.offset', lang]))
    ) +
    scale_y_continuous(expand = c(0.002, 0)) + 
    geom_text(
      data = player.lab.aligned,
      aes(x = x, y = y, label = player), 
      hjust = 0, vjust = 0.5,
      family = txt["base.typeface", lang],
      size = as.numeric(txt['player.size', lang]), color="#1a1a1a") +
    labs(title = txt["main.title", lang], subtitle = txt["descr", lang]) +
    theme(
      plot.title = element_text(family = txt["title.typeface", lang]),
      legend.title = element_text(family = txt["title.typeface", lang]),
      plot.subtitle = element_text(family = txt["subtitle.typeface", lang])
    )
  
  if(!file.exists(teaser.outfile)) {
    png(teaser.outfile, width = 3478 / 3, height = 2000 / 3, res = 260, pointsize = 9)
    print(hatp)
    dev.off()    
  }
  
  hatp2 <- hatp + geom_text(
    data = anno, 
    aes(x = x, y = y, label = txt, hjust = hjust, vjust = vjust), lineheight = 0.94,
    family = txt["base.typeface", lang], size = as.numeric(txt['annot.size', lang]), color="#262626"
  ) + geom_segment(
    data = anno, 
    aes(x = x0, xend = x1, y = y0, yend = y1),
    colour = '#404040', alpha = 0.5, size = 0.2,
    arrow = arrow(angle = 20, length = unit(0.01, "npc"), type = "closed")
  )
  
  #png(png.outfile, width = 3478, height = 2000, res = 270, pointsize = 9)
  #png(png.outfile, width = 1739, height = 1000, res = 135, pointsize = 9)
  png(png.outfile, width = 1800, height = 1100, res = 135, pointsize = 9)
  print(hatp2)
  dev.off()
  source <- paste0(
    txt['source', lang], ": ", 
    htmlLink(txt['source.link', lang], txt['source.name', lang]), " | ", 
    htmlLink("http://www.swissinfo.ch", "swissinfo.ch"), " | ",
    htmlLink("https://twitter.com/duc_qn", "@duc_qn")
  )
  
  save_html(
    tags$html(
      tags$head(includeHTML("styles.html")),
      tags$body(    
        div(class="graphic", 
            img(src = png.outfile, width= "100%")
        ),
        div(id = "cite", HTML(source)),
        HTML(iframeresizer)  
      )), file = html.outfile
  )
}

```