---
title: "cgMLST cluster report from joined allele database"
date: "`r Sys.time()`"
output:
  html_document:
    toc: true
    toc_depth: 2
editor_options: 
  chunk_output_type: console
---

<style type="text/css">
.main-container {
  max-width: 3600px;
  margin-left: auto;
  margin-right: auto;
}
</style>

<style>
  tbody tr:hover {
  background: yellow;
} 

</style>



```{r setup, include=FALSE}
knitr::opts_chunk$set(out.width = '80%',fig.asp= 0.5,fig.align='center', dpi = 192,echo=FALSE, warning=FALSE, message=FALSE, fig.height = 20, fig.width = 20, fig.align = "center")
options(markdown.HTML.header = system.file("misc", "datatables.html", package = "knitr"))

```

```{r load_packages, echo=FALSE}

suppressPackageStartupMessages(library(magrittr))
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(reshape2)) # for converting matrix
suppressPackageStartupMessages(library(ggplot2)) # for plotting (which?)
suppressPackageStartupMessages(library(ape)) # read/write data
suppressPackageStartupMessages(library(DT)) # datatable 
suppressPackageStartupMessages(library(plotly)) # interactive plots/trees
suppressPackageStartupMessages(library(dendextend)) ##  get_nodes_attr
suppressPackageStartupMessages(library(RColorBrewer)) ## for color picking

#suppressPackageStartupMessages(library(ggtree)) ## nice trees


```


```{r define_Data, echo=FALSE}

#debug_mode <- T # params from file report_parameters
debug_mode <- F # params from snakemake

if(debug_mode){
   #setwd(dir = "/home/brendy/data/git/chewieSnake/scripts")
   #setwd(dir = "/cephfs/abteilung4/Projects_NGS/GenoSalmSurv/realtime_cgmlst/chewieSnake_repo/scripts")
   warning("Calling parameters from file parameters_cluster_report.R")
   source("parameters_cluster_report.R")
} else {
        samples2cluster.file <- snakemake@input[["samples2cluster"]]
        distance_matrix.file <- snakemake@input[["distance_matrix_tsv"]]
        subclusters.file <- snakemake@input[["subclusters"]]
        mapping_sample2externalclustername.file <- snakemake@input[["mapping_sample2externalclustername_file"]]
        # serovar file
        mapping_sample2serovar.file <- snakemake@params[["mapping_sample2serovar"]]
        sender_info.file <- snakemake@input[["sender_info"]]
        timestamps.file <- snakemake@input[["timestamps"]]

        #params
        distance_threshold = snakemake@params[["distance_threshold"]]
        clustering_method = snakemake@params[["clustering_method"]]
        workdir = snakemake@params[["workdir"]]
        cluster = snakemake@params[["cluster"]]
        do_export = snakemake@params[["export"]]
        functions_file <- file.path(snakemake@params[["functions_file"]],"scripts/functions.R")
  
  log <- file(snakemake@log[[1]], open="wt")
  
  # redirect output to log file
  sink(log)
  sink(log, type="message")

        
  }

param_color_thr = c(0,1,5,10,20)
#param_color_thr = c(20,10,5,1,0)

# define extra output
nwk.file <- file.path(workdir,"merged_db","clustering",cluster,"clustering_tree.nwk")

cluster_information.file <- file.path(workdir,"merged_db","clustering",cluster,"cluster_information.tsv")

#treeplot.pdf <- file.path(workdir,"merged_db","clustering",cluster,"clustering_tree.pdf")

#distancematrix.pdf <- file.path(workdir,"merged_db","clustering",cluster,"distance_matrix.pdf")

type = "png"

treeplot.pdf <- file.path(workdir,"merged_db","clustering",cluster,"clustering_tree.png")

distancematrix.pdf <- file.path(workdir,"merged_db","clustering",cluster,"distance_matrix.png")


```


```{r load_functions, echo=FALSE}

# load
source(functions_file)

```


```{r load_data, echo=F}

samples2cluster <- read.delim(samples2cluster.file, stringsAsFactors = F)

distance_matrix <- read_distance_matrix(distance_matrix.file, sep="\t", header = T)

subclusters <- read.delim(subclusters.file, stringsAsFactors = F)

mapping_sample2externalclustername <- read.delim(mapping_sample2externalclustername.file, stringsAsFactors = F)

# serovar mapping
if(length(mapping_sample2serovar.file) > 0){ # if option is not set value is of length 0
  if (file.info(mapping_sample2serovar.file)$size == 0) {
    warning("File",mapping_sample2serovar.file,"is empty")
    mapping_sample2serovar <- data.frame(sample=NA)
  } else {
    mapping_sample2serovar <- read.delim(mapping_sample2serovar.file, stringsAsFactors = F)
  }
} else {
  warning("File",mapping_sample2serovar.file,"does not exist")
  mapping_sample2serovar <- data.frame(sample=NA)
}
sender_info <- read.delim(sender_info.file, stringsAsFactors = F, header = F, col.names=c("sample","sender"))
timestamps <- read.delim(timestamps.file, stringsAsFactors = F, header = F, col.names=c("sample","date"), colClasses = c("character","Date"))


```


```{R color function}

# define colors

senders <- unique(sender_info$sender)

#### Color coding
senders_color <- brewer.pal(length(senders), "Dark2") #"RdYlBu","RdBu"
names(senders_color) <- senders



  colorize <- function(x, color) {
    if (knitr::is_latex_output()) {
      sprintf("\\textcolor{%s}{%s}", color, x)
    } else if (knitr::is_html_output()) {
      sprintf("<span style='color: %s;'>%s</span>", color, 
              x)
    } else x
  }

  
color14="red"
color30="orange"
color90="pink"


# matrix with sample color matching
sender_info$Color <-apply(sender_info,1,function(x){ 
  mysender <- x[2]
  senders_color[mysender]
})

# overall labels
label_color <- sender_info$Color


# subcluster colors

#### Color coding
make_color_coding <- function(subclusters, i){

  subclusters_uniq <- sort(unique(subclusters[,i]))
  
  if(length(subclusters_uniq) == 1){
    subclusters_color <- "gray"
  } else if(length(subclusters_uniq) == 2){
    subclusters_color <- c("red","blue")
  } else if (length(subclusters_uniq) > 12) { # handle cases where more clusters than palette by adding second palette
    subclusters_color_1 <- brewer.pal(12, "Set3") #,"RdBu"  
    subclusters_color_2 <- brewer.pal(length(subclusters_uniq)-12, "Set1")
    subclusters_color <- c(subclusters_color_1,subclusters_color_2)
  } else if (length(subclusters_uniq) > 2) {
    subclusters_color <- brewer.pal(length(subclusters_uniq), "Set3") #,"RdBu"  
  } else {
    subclusters_color <- "black"
  }
  
  names(subclusters_color) <- subclusters_uniq[1:length(subclusters_color)]
  
  # table of sample and color
  subclusters_color_table <- subclusters_color[subclusters[,i]]
  names(subclusters_color_table) <- subclusters[,1]
  
  return(subclusters_color_table)
}

#display.brewer.all(n=length(subclusters_uniq), type="all", select=NULL, exact.n=F, colorblindFriendly=FALSE)

# subcluster threshold ist hard coded!
#subclusters_color_table_10 <- make_color_coding (subclusters, 2)
#subclusters_color_table_3 <- make_color_coding (subclusters, 3)
subclusters_color_table_3 <- make_color_coding (subclusters, 2)

# Available colors:
# Accent	 8
# Dark2	 8
# Paired	 12
# Pastel1	 9
# Pastel2	 8
# Set1	 9
# Set2	 8
# Set3	 12

```



```{r subset_data, echo=F}

samples <- samples2cluster$sample


timestamps.cluster <- timestamps[timestamps$sample %in% samples,]
latest_sample <- timestamps.cluster[order(timestamps.cluster$date, decreasing = T)[1],]
oldest_sample <- timestamps.cluster[order(timestamps.cluster$date, decreasing = F)[1],]

sender_info.cluster <- sender_info[sender_info$sample %in% samples,]
mapping_sample2externalclustername.cluster <- mapping_sample2externalclustername[mapping_sample2externalclustername$sample %in% samples,]

# TODO handle if NA?
mapping_sample2serovar.cluster <- mapping_sample2serovar[mapping_sample2serovar$sample %in% samples,]

# melt matrix, # TODO no longer needed
distance_matrix.m <- reshape2::melt(distance_matrix)
colnames(distance_matrix.m) <- c("Sample1","Sample2","Distance")


# cluster_information

cluster_information <- merge(timestamps.cluster,sender_info.cluster)
#cluster_information$age <- as.numeric(difftime(Sys.Date(), cluster_information$date, units = "day"))
cluster_information <- cluster_information[,colnames(cluster_information) != "Color"]
cluster_information$cluster_name <- cluster
cluster_information <- merge(cluster_information,subclusters)


cluster_information$cluster_code <- apply(cluster_information[,grep("cluster_name",colnames(cluster_information))],1,function(x) paste(x, collapse = "."))

```


```{r clustering, echo=F}

# cluster
clustering <- distance_matrix %>% as.dist %>% hclust(., method = clustering_method) %>% as.dendrogram

```

# Cluster report for cluster `r cluster`


## Basic information

This is a report for a single cluster

* Cluster name `r cluster`

* Related external names are `r if(nrow(mapping_sample2externalclustername.cluster) == 0) NA else { unique(mapping_sample2externalclustername.cluster$external_cluster_name) }`

* Serotype/clade information `r if(length(mapping_sample2serovar.cluster) == 0) NA else if(nrow(mapping_sample2serovar.cluster) == 0) NA else { unique(mapping_sample2serovar.cluster$external_cluster_name) }`

* Last update on `r strsplit(as.character(file.info(distance_matrix.file)$mtime[1]), split = " ")[[1]][1]`

* Latest sample in cluster is `r latest_sample$sample`: `r latest_sample$date`  (date of analysis)

* Oldest sample in cluster is `r oldest_sample$sample`: `r oldest_sample$date` (date of analysis)

* Duration: `r latest_sample$date - oldest_sample$date`

* Cluster samples originate from `r unique(sender_info.cluster$sender)` 

* Cluster contains `r length(samples)` samples


* The cluster can be divided into the following number of subclusters: at `r paste(sapply(2:ncol(subclusters),function(i){
  count = length(unique(subclusters[,i]))
  name = colnames(subclusters)[i]
  name = sub("$"," allele differences",sub("cluster_name_","",name))
  paste(name, count, sep=":")
}),collapse = " and at ")
`

## Cluster stats


```{r tables}

cluster_information.print <- cluster_information
colnames(cluster_information.print) <- gsub("_"," ",colnames(cluster_information.print))

DT::datatable(cluster_information.print, filter = 'top',rownames= FALSE, escape = FALSE, 
          extensions = list("ColReorder" = NULL, "Buttons" = NULL, "FixedColumns" = list(leftColumns=1)),
    options = list(
                dom = 'BRrltpi',
                autoWidth=FALSE,
                scrollX = TRUE,
                order = list(list(1, 'desc')), # order by date, most recent first
                fixedColumns = TRUE,
                lengthMenu = list(c(10, 50, -1), c('10', '50', 'All')),
                ColReorder = TRUE,
                buttons =
                  list(
                    'copy',
                    'print',
                    list(
                      extend = 'collection',
                      buttons = c('csv', 'excel', 'pdf'),
                      text = 'Download'
                    ),
                    I('colvis')
                  )
              ))

```

## Information about subclusters


```{r subcluster_info, results='asis'}

# make table:
# subcluster name, number of members, list of members
# only for > 1

subcluster_cols <- grep("cluster_name_",colnames(cluster_information))

#knitr::kable(table(cluster_information[,subcluster_cols[1]]))

for(mysubclustertype in subcluster_cols){
 
  #subcluster_counts <- as_tibble(table(cluster_information[,mysubclustertype]))
  subcluster_counts <- as.data.frame(table(cluster_information[,mysubclustertype]))
  colnames(subcluster_counts) <- c("subcluster","n")
  subcluster_counts <- subcluster_counts %>% filter(n > 1)
 
  subcluster_names <- subcluster_counts$subcluster
  
  if(nrow(subcluster_counts) > 0){
  #if(length(subcluster_counts) != 0){
    #cat("Subcluster info")
    #cat(paste("Count of subcluster members for",colnames(cluster_information)[mysubclustertype]))
    cat(paste("Count of subcluster members for samples clustered at",sub("cluster_name_","",colnames(cluster_information)[mysubclustertype]),"allele differences."))
    
    print(knitr::kable(subcluster_counts, "html"))
    #print(knitr::kable(subcluster_counts))
    # , caption = paste("Count of subcluster members for",colnames(cluster_information)[mysubclustertype])

    
        cat("Note that sub-clusters containing only a single sample are omitted here.")    
  } else {
    cat(paste("No subclusters found for",colnames(cluster_information)[mysubclustertype]))
    cat("Note that sub-clusters containing only a single sample are omitted here.")    
  } 
  
  
}



```


## Provided samples per date

```{r plot_epicurveclustering, echo=F, fig.width=10,fig.height=5}

cluster_info_table <- table(Date=cluster_information$date,Sender=cluster_information$sender)

cluster_info_table_df <- as.data.frame(cluster_info_table)
cluster_info_table_df$Date2 <- as.Date(as.character(cluster_info_table_df$Date))

p2<-ggplot(data=cluster_info_table_df, aes(x=Date2, y=Freq, fill = Sender)) +
  geom_bar(stat="identity") + xlab("Date (of analysis)") + ylab("Number of samples") +
  scale_x_date(date_labels ="%b %y", date_breaks = "2 month") + scale_fill_manual(values=senders_color) # Define colors

#print(p2)


#interactive with ggplotly

ggplotly(p2)

```



## Distance matrix


```{r plot_distancematrix, echo=F}

label_color_selected <- sender_info.cluster$Color
names(label_color_selected) <- sender_info.cluster$sample

if (nrow(distance_matrix) > 30){
  param_size = 1.5
  param_legendsize = 6
} else {
  param_size = 3
  param_legendsize = 12
}


p1b <- plot_distance_matrix(distance_matrix, label_color = label_color_selected, param_color_thr = param_color_thr, param_size = param_size, param_legendsize = param_legendsize)

print(p1b)


# # TODO interactive if too big --------------------------------------------
# 
# if (length(samples) <= 50) {
#   p1b <- plot_distance_matrix(distance_matrix, label_color = label_color_selected, param_color_thr = param_color_thr, param_size = param_size, param_legendsize = param_legendsize)
#   p1b
# } else {
# 
# 
# a <- list(
#   title = "Sample",
#   showticklabels = TRUE,
#   tickangle = 45
# )
# 
# # interactive allele distance matrix
# 
# # melt matrix
# distance_matrix.m <- reshape2::melt(distance_matrix)
# colnames(distance_matrix.m) <- c("Sample1","Sample2","Distance")
# 
# distance_matrix_noself.m <- distance_matrix.m[distance_matrix.m$Sample1 != distance_matrix.m$Sample2,]
# 
# # add information, (how to display?)
# distance_matrix_info.m <- merge(distance_matrix_noself.m,cluster_information[,c("sample","sender","date")], by.x = "Sample1",by.y = "sample")
# distance_matrix_info.m <- merge(distance_matrix_info.m,cluster_information[,c("sample","sender","date")], by.x = "Sample2",by.y = "sample", suffixes = c("_1","_2"))
# #
# print("Interactive distance matrix")
# print(head(distance_matrix_info.m))
# 
# #p2 <- plot_ly(x=distance_matrix_noself.m$Sample1,y=distance_matrix_noself.m$Sample2,z=distance_matrix_noself.m$Distance, type = "heatmap") %>%
# p2 <- plot_ly(x=distance_matrix_info.m$Sample1,y=distance_matrix_info.m$Sample2,z=distance_matrix_noself.m$Distance, type = "heatmap") %>%
#  layout(xaxis = a, yaxis = a, showlegend = TRUE)
# 
# print(p2)
# 
# }

```



## `r clustering_method`-linkage tree

```{r plot_clustering, echo=F}

# need timing info
timestamps_selected <- cluster_information$date

age_selected <- difftime(Sys.Date(), timestamps_selected, units = "day")

age_coloring <- sapply(age_selected, function(age){
  if ( age < 14){
    return(color14)
  } else if(age < 30){
    return(color30)
  } else if(age < 90){
    return(color90)
  } else {
    return("white")
  }
})


# add subcluster info


# set label size
if (nrow(cluster_information) > 500) {
    my_cex_tiplabel <- 0.1
    my_cex_edgelabel <- 0.1
    } else if (nrow(cluster_information) > 50) {
    my_cex_tiplabel <- 0.5
    my_cex_edgelabel <- 0.4
    } else{
    my_cex_tiplabel <- 0.8
    my_cex_edgelabel <- 0.7
  }

# plot
par(mar=c(7,1,1,12), cex = my_cex_tiplabel)
plot(clustering, horiz = T)
# cluster 10 and cluster 3 is hard coded!!!
colored_bars(colors = cbind(label_color_selected,age_coloring,subclusters_color_table_3), dend = clustering, rowLabels = c("sender","recency","cluster_3"), horiz = TRUE, cex.rowLabels = 0.9)
#colored_bars(colors = cbind(label_color_selected,age_coloring,subclusters_color_table_10,subclusters_color_table_3), dend = clustering, rowLabels = c("sender","recency","cluster_10","cluster_3"), horiz = TRUE, cex.rowLabels = 0.9)


#color_branches(dend = clustering, k = 3)

# clustering %>% set("labels_col","red") %>% # change color
#   set("labels_cex", 0.5) %>% # Change size
#   plot(horiz = T) # plot
# colored_bars(colors = cbind(label_color_selected,age_coloring,subclusters_color_table_10,subclusters_color_table_3), dend = clustering, rowLabels = c("sender","recency","cluster_10","cluster_3"), horiz = TRUE)


```


```{r export}


if(do_export){
  #print("Exporting plots and data")
  
  write.table(cluster_information, cluster_information.file, sep="\t", row.names = F, quote = F)
 
  ggsave(distancematrix.pdf,p1b, device = "png")
  
  ape::write.tree(as.phylo(clustering), file = nwk.file) 

# export as pdf, png

#pdf(file = treeplot.pdf)
png(file = treeplot.pdf, width = 1800, height = 1200)
par(mar=c(7,1,1,12), cex = my_cex_tiplabel*2)

plot(clustering, horiz = T)
colored_bars(colors = cbind(label_color_selected,age_coloring,subclusters_color_table_3), dend = clustering, rowLabels = c("sender","recency","cluster_3"), horiz = TRUE)
#colored_bars(colors = cbind(label_color_selected,age_coloring,subclusters_color_table_10,subclusters_color_table_3), dend = clustering, rowLabels = c("sender","recency","cluster_10","cluster_3"), horiz = TRUE)

dev.off()

} 
```


### Link to files


```{r file_info}
# The exported clustering files are in `r exportpath`

# #relative paths
 if(do_export){
   exportpath <- file.path(workdir,"merged_db/clustering",cluster)
   file_timestamps_2 <- data.frame(
  name=list.files(exportpath, full.names = F),
  file= list.files(exportpath, full.names = F))

   file_timestamps_2$Link <- paste0("<a href=",file_timestamps_2$file,">",file_timestamps_2$name,"</a>")

      knitr::kable(file_timestamps_2, caption = "Overview of files found in folder, relative paths")
 }

```


### Subcluster details

```{r subcluster_details, results='asis'}

# for all subclusters with > 2 members
# viz tree

subcluster_cols <- grep("cluster_name_",colnames(cluster_information))

for(mysubclustertype in subcluster_cols){
 
  subcluster_counts <- table(cluster_information[,mysubclustertype]) 
  subcluster_counts <- subcluster_counts[which(subcluster_counts > 2)]
 
  subcluster_names <- names(subcluster_counts)
  

  if(length(subcluster_names) != 0){
    for(subcluster_name in subcluster_names){
      # subset distance matrix

      
      samples_selected <- cluster_information$sample[cluster_information[,mysubclustertype] == subcluster_name]
      
      
      distance_matrix_selected <- distance_matrix[samples_selected,samples_selected]
            
      # cluster 

      label_color_selected_sub <- label_color_selected[samples_selected]
            
      # cluster
clustering_selected <- distance_matrix_selected %>% as.dist %>% hclust(., method = clustering_method) %>% as.dendrogram

cat(paste("#### Subcluster",subcluster_name))

      # plot
par(mar=c(7,1,1,12), cex = my_cex_tiplabel)
      plot(clustering_selected, horiz = T)
      # plot

# cluster 10 and cluster 3 is hard coded!!!
colored_bars(colors = cbind(label_color_selected_sub), dend = clustering_selected, rowLabels = c("sender"), horiz = TRUE, cex.rowLabels = 0.9)

      #colored_bars(colors = cbind(label_color_selected,age_coloring,subclusters_color_table_3), dend = clustering, rowLabels = c("sender","recency","cluster_3"), horiz = TRUE, cex.rowLabels = 0.9)

      
      
    }
    
    
    
  } 
  
  
}



```




### Color coding

The following color code is applied:

* `r colorize(names(senders_color)[1], senders_color[1])`
* `r colorize(names(senders_color)[2], senders_color[2])`
* `r colorize(names(senders_color)[3], senders_color[3])`


For the recency of samples, the color code is:

* `r colorize("Sample added in < 14 days", color14)`
* `r colorize("Sample added in < 30 days", color30)`
* `r colorize("Sample added in < 90 days", color90)`
* no color (white) denotes samples added before 90 days


Furhermore, subclusters are marked in different colors.
