rm(list=ls())
options(width = 120)

# read from clipboard
d <- read.table(pipe("xclip -selection clipboard -o", open="r"), sep = "\t", header = TRUE)
d[is.na(d)] <- 0
str(d)
head(d)
d[1,]
colnames(d)

d2 <- d # duplicate
d <- d2

# clean
sel <- which(colnames(d) %in% c("ID_SECCION","CASILLA"))
d <- d[,-sel]

# turn characters into NAs
sel <- c(2,4,6,7,10,12)
tmp <- d[,-sel]
tmp <- lapply(tmp, as.numeric)
tmp <- as.data.frame(do.call(cbind,tmp))
tmp[is.na(tmp)] <- 0
head(tmp)
d[,-sel] <- tmp

d[2,]
colnames(d)

d <- within(d, expr = {
PAN <- ave(PAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PRI <- ave(PRI, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PRD <- ave(PRD, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT <- ave(PT, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PVEM <- ave(PVEM, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
MC <- ave(MC, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
MORENA <- ave(MORENA, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
NAN <- ave(NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
VIVA <- ave(VIVA, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
MLN <- ave(MLN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PES <- ave(PES, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
RSP <- ave(RSP, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
FXM <- ave(FXM, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
CI <- ave(CI, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PAN_PRI_PRD <- ave(PAN_PRI_PRD, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PAN_PRI <- ave(PAN_PRI, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PAN_PRD <- ave(PAN_PRD, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PRI_PRD <- ave(PRI_PRD, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_PVEM_MORENA_NAN <- ave(PT_PVEM_MORENA_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_PVEM_MORENA <- ave(PT_PVEM_MORENA, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_PVEM_NAN <- ave(PT_PVEM_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_MORENA_NAN <- ave(PT_MORENA_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PVEM_MORENA_NAN <- ave(PVEM_MORENA_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_PVEM <- ave(PT_PVEM, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_MORENA <- ave(PT_MORENA, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PT_NAN <- ave(PT_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PVEM_MORENA <- ave(PVEM_MORENA, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
PVEM_NAN <- ave(PVEM_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
MORENA_NAN <- ave(MORENA_NAN, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
nr <- ave(nr, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
nul <- ave(nul, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
tot <- ave(tot, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
lisnom <- ave(lisnom, as.factor(paste(munn,demn,sep=".")), FUN=sum, na.rm=TRUE);
}
)

# drop redundant rows
d <- d[duplicated(as.factor(paste(d$munn,d$demn,sep=".")))==FALSE,]
dim(d)
head(d)

# rename some cols
sel <- grep("LISTA", colnames(d))
colnames(d)[sel] <- "lisnom"
sel <- grep("NO.REG", colnames(d))
colnames(d)[sel] <- "nr"
sel <- grep("NULOS", colnames(d))
colnames(d)[sel] <- "nul"
sel <- grep("ID_ESTADO", colnames(d))
colnames(d)[sel] <- "edon"
sel <- grep("ID_DISTRITO", colnames(d))
colnames(d)[sel] <- "disn"
sel <- grep("NOMBRE_DIS", colnames(d))
colnames(d)[sel] <- "cabecera"

# add coals

# write to clipboard to export to excel
clipboard <- function(x, sep=",", row.names=FALSE, col.names=TRUE){
     con <- pipe("xclip -selection clipboard -i", open="w")
     write.table(x, con, sep=sep, row.names=row.names, col.names=col.names)
     close(con)
}

clipboard(d)

######################
## mich excel files ##
######################

library(xlsx)
source("~/Dropbox/data/useful-functions/notin.r")
setwd("/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/mic2021ayca")

all.f <- dir()

# get all colnames
all.n <- c()
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #d[1,]
    all.n <- c(all.n, colnames(d))
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[-which(all.n %in% c("Distrito","Cabecera.distrital","Sección","Casilla","Recuento"))]
all.n <- all.n[order(all.n)]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$Municipio <- "drop this obs"
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #str(d)
    #d[1,]
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("Municipio"))] # keep mun
    tmp2 <- d[1,which(colnames(d) %in% c("Cve..Municipio"))] # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("Municipio","Cve..Municipio","Distrito","Cabecera.distrital","Sección","Casilla","Recuento"))], na.rm=TRUE)
    d <- c(Municipio=tmp, Cve..Municipio=tmp2, d) # paste mun
    d <- d[order(names(d))]
    new.o <-
        rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard(new.o)

new.o[1,]

#####################
## cua excel files ##
#####################
rm(list = ls())
#library(xlsx)
library(readxl)
source("~/Dropbox/data/useful-functions/notin.r")
f <- "/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/cua2021ay-casilla.xlsx"

# get all colnames
all.n <- c()
for (i in 1:67){
    #i <- 11
    message(sprintf("loop %s", i))
    #d <- read.xlsx(f, sheetIndex = i)
    #d <- read.xlsx(f, sheetIndex = i, header = FALSE, startRow = 1, endRow = 1)
    d <- read_excel(f, sheet = i)
    #d[1,]
    all.n <- c(all.n, colnames(d))
    rm(d)
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[order(all.n)]
all.n <- all.n[-which(all.n %in% c("Seccion","Casilla","Eleccion"))]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$Municipio <- "drop this obs"
#new.o <- new.o[,-which(colnames(new.o) %in% c("Seccion","Casilla","Eleccion"))]
for (i in 1:67){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read_excel(f, sheet = i)
    d <- as.data.frame(d) # chg tibble to data frame
    #d[1,]
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("Municipio"))] # keep mun
    tmp2 <- d[1,which(colnames(d) %in% c("NoMpio"))] # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("Municipio","NoMpio","Seccion","Casilla","Eleccion"))])
    d <- c(Municipio=tmp, NoMpio=tmp2, d) # paste mun
    d <- d[order(names(d))]
    table(colnames(new.o)==names(d))
    new.o <- rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard <- function(x, sep=",", row.names=FALSE, col.names=TRUE){
     con <- pipe("xclip -selection clipboard -i", open="w")
     write.table(x, con, sep=sep, row.names=row.names, col.names=col.names)
     close(con)
}
clipboard(new.o)

new.o[2,]

#####################
## san excel files ##
#####################

library(xlsx)
source("~/Dropbox/data/useful-functions/notin.r")
setwd("/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/san2021ayca")

all.f <- dir()

# get all colnames
all.n <- c()
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #d[1,]
    all.n <- c(all.n, colnames(d))
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[-which(all.n %in% c("Municipio","Casilla","Dto..Local","No..Mpo"))]
all.n <- c(all.n, "mun", "ife")
all.n <- all.n[order(all.n)]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$mun <- "drop this obs"
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.xlsx(all.f[i], sheetIndex = 1)
    #d[1,]
    #str(d)
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("Municipio"))] # keep mun
    tmp2 <- as.numeric(d[1,which(colnames(d) %in% c("No..Mpo"))]) # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("Municipio","Casilla","Dto..Local","No..Mpo"))])
    d["mun"] <- tmp   # paste mun
    d["ife"] <- tmp2  # paste ife
    d <- d[order(names(d))]
    new.o <-
        rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard(new.o)

new.o[1,]

###################
## oax csv files ##
###################

source("~/Dropbox/data/useful-functions/notin.r")
setwd("/home/eric/Downloads/Desktop/MXelsCalendGovt/elecReturns/datosBrutos/not-in-git/resultCasillas/subnat/oax2021ayca")
all.f <- dir()

# get all colnames
all.n <- c()
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.csv(file = all.f[i], skip = 2, nrows = 1, header = TRUE)
    #d[1,]
    all.n <- c(all.n, colnames(d))
}
all.n <- all.n[duplicated(all.n)==FALSE]
all.n <- all.n[-which(all.n %in% c("ID_ESTADO","NOMBRE_ESTADO","ID_DISTRITO_LOCAL","CABECERA_DISTRITO_LOCAL","SECCION","ID_CASILLA","TIPO_CASILLA","EXT_CONTIGUA","ID_TIPO_CANDIDATURA","ESTATUS_ACTA","CASILLA_INSTALADA","ESTATUS_PAQUETE","ID_INCIDENTE","NUM_ACTA_IMPRESO"))]
#all.n <- c(all.n, "mun", "ife")
all.n <- all.n[order(all.n)]

# get all files, colSums into new object
new.o <- matrix(rep(0, length(all.n)), nrow = 1)
new.o  <- data.frame(new.o); colnames(new.o)  <- all.n; new.o$MUNICIPIO_LOCAL <- "drop this obs"
for (i in 1:length(all.f)){
    #i <- 1
    message(sprintf("loop %s", i))
    d <- read.csv(file = all.f[i], skip = 2, header = TRUE)
    sel <- which(colnames(d) %in% c("ID_ESTADO","NOMBRE_ESTADO","ID_DISTRITO_LOCAL","CABECERA_DISTRITO_LOCAL","SECCION","ID_CASILLA","TIPO_CASILLA","EXT_CONTIGUA","ID_TIPO_CANDIDATURA","ESTATUS_ACTA","CASILLA_INSTALADA","ESTATUS_PAQUETE","ID_INCIDENTE","NUM_ACTA_IMPRESO"))
    d <- d[,-sel]
    #d[1,]
    #str(d)
    tmp.n <- which(all.n %notin% colnames(d)) # missing columns
    tmp.x <- matrix(0, nrow=nrow(d), ncol=length(tmp.n))
    tmp.x <- data.frame(tmp.x); colnames(tmp.x) <- all.n[tmp.n]
    d <- cbind(d, tmp.x)
    tmp <- d[1,which(colnames(d) %in% c("MUNICIPIO_LOCAL"))] # keep mun
    tmp1 <- d[1,which(colnames(d) %in% c("ID_MUNICIPIO_LOCAL"))] # keep ife
    d <- colSums(d[,-which(colnames(d) %in% c("MUNICIPIO_LOCAL"))])
    d["MUNICIPIO_LOCAL"] <- tmp   # paste mun
    d["ID_MUNICIPIO_LOCAL"] <- tmp1   # paste ife
    d <- d[order(names(d))]
    new.o <-
        rbind(new.o, d)
#    assign(d, paste0("f", sub("^([0-9]+)[,].+", "\\1", all.f[i]))) # rename object
}

clipboard(new.o)

new.o[1,]


# settings ----------------------------------------------------------------
path_to_vocabulary <- r"(C:\Users\javier\WorkSpace\OMOP_vocab_for_finngen\16042021)"
path_to_repo <- r"(C:\Users\javier\OneDrive - TUNI.fi\Documents\TAYS\ENVIROMENTS\DEV_GREEN\FINNGEN_GITHUB\mapping_finland)"
path_output <- r"(C:\Users\javier\WorkSpace\OMOP_vocab_for_finngen_extended\16042021)"

library(tidyverse)
source(file.path(path_to_repo, "lib", "read_tables.r"))

# check max concept_id ----------------------------------------------------

concept <-  read_table_concept(path_to_vocabulary)
vocabulary <- read_tsv(file.path(path_to_vocabulary, "VOCABULARY.csv"))
concept_class <- read_tsv(file.path(path_to_vocabulary, "CONCEPT_CLASS.csv"))
concept_synonym <- read_tsv(file.path(path_to_vocabulary, "CONCEPT_SYNONYM.csv"), quote = "")
concept_relationship <- read_tsv(file.path(path_to_vocabulary, "CONCEPT_RELATIONSHIP.csv"), quote = "",
  col_type = cols(
   concept_id_1 = col_double(),
   concept_id_2 = col_double(),
   relationship_id = col_character(),
   valid_start_date =  col_date("%Y%m%d"),
   valid_end_date =  col_date("%Y%m%d"),
   invalid_reason = col_character()
  )
)

max(concept$concept_id)

# set offset for concept_id -----------------------------------------------

append_vocabs <- tribble(
  ~vocabulary_name, ~offset_concept_id,
  "ICD8fi",          7*10^8L,
  "ICD9fi",          8*10^8L,
  "ICD10fi",         9*10^8L,
  "ICPC",           10*10^8L,
  "NOMESCOfi",      11*10^8L,
  "REIMB",           12*10^8L,
  "SPAT",           13*10^8L,
  "FHL",           14*10^8L,
  "HPN",           15*10^8L,

)

# append ------------------------------------------------------------------
concept_fg_info <- tibble()

for (i in 1:nrow(append_vocabs)) {

  vocabulary_name <- append_vocabs[i,]$vocabulary_name
  offset_concept_id <- append_vocabs[i,]$offset_concept_id

  ## concept
  concept_vocab <- read_csv(
    file.path(path_to_repo, vocabulary_name, "1_source_vocabulary", str_c("CONCEPT_", vocabulary_name, ".csv")),
    col_types = cols(
      concept_id = col_integer(),
      valid_start_date = col_date(format = ""),
      valid_end_date = col_date(format = ""),
      .default = col_character()
    )
  ) %>%
    mutate(concept_id = concept_id + offset_concept_id)

  concept <- bind_rows(concept, concept_vocab %>% select(-starts_with("tmp_")) )

  ## concept extra finngen info
  concept_fg_info <- bind_rows(concept_fg_info, concept_vocab %>% select( concept_id, starts_with("tmp_")) )

  ## vocabulary
  vocabulary_vocab <- read_csv(
    file.path(path_to_repo, vocabulary_name, "1_source_vocabulary", str_c("VOCABULARY_", vocabulary_name, ".csv")),
    col_types = cols(
      vocabulary_concept_id = col_integer(),
      .default = col_character()
    )
  ) %>%
    select(-starts_with("tmp_")) %>%
    mutate(vocabulary_concept_id = vocabulary_concept_id + offset_concept_id)

  vocabulary <- bind_rows(vocabulary, vocabulary_vocab)

  ## concept class
  concept_class_vocab <- read_csv(
    file.path(path_to_repo, vocabulary_name, "1_source_vocabulary", str_c("CONCEPT_CLASS_", vocabulary_name, ".csv"))
  ) %>%
    select(-starts_with("tmp_")) %>%
    mutate(concept_class_concept_id = concept_class_concept_id + offset_concept_id)

  concept_class <- bind_rows(concept_class, concept_class_vocab)

  ## concept_synonym
  file_path_syn <- file.path(path_to_repo, vocabulary_name, "1_source_vocabulary", str_c("CONCEPT_SYNONYM_", vocabulary_name, ".csv"))

  if(file.exists(file_path_syn)){
    concept_synonym_vocab <- read_csv(file_path_syn) %>%
      select(-starts_with("tmp_")) %>%
      mutate(concept_id  = concept_id  + offset_concept_id)

    concept_synonym <- bind_rows(concept_synonym, concept_synonym_vocab)
  }

  ## concept_relationship
  file_path_relationship <- file.path(path_to_repo, vocabulary_name, "2_mapping_to_standard", str_c("CONCEPT_RELATIONSHIP_", vocabulary_name, ".csv"))

  if(file.exists(file_path_relationship)){
    concept_relationship_vocab <- read_csv(file_path_relationship,
       col_type = cols(
         concept_id_1 = col_double(),
         concept_id_2 = col_double(),
         relationship_id = col_character(),
         valid_start_date =  col_date(),
         valid_end_date =  col_date(),
         .default = col_character()
       )
    ) %>%
      select(-starts_with("tmp_")) %>%
      mutate(concept_id_1   = concept_id_1   + offset_concept_id)

    concept_relationship <- bind_rows(concept_relationship, concept_relationship_vocab)
  }

}

# FIX TABLES ----------------------------------------------------------------
# Fix 1:  Somoe finnish concepts were mapped to concept in vocabularies that we dont include
#         Moslty, bcs mapping is wrong, eg Cast
concept_id_2_to_remove <- left_join(
  concept_relationship %>% filter(relationship_id=="Maps to"),
  concept %>% rename(concept_id_2 = concept_id),
  by="concept_id_2"
) %>%
  filter(is.na(concept_name)) %>%
  .$concept_id_2

concept_id_2_to_remove

concept_relationship <- concept_relationship %>%
  filter(!(concept_id_2 %in% concept_id_2_to_remove)) %>%
  distinct()

# Fix 2: some data in SYNONIMS is NA
concept_synonym <- concept_synonym %>% filter(!is.na(concept_synonym_name))

# Fix 3: vocabulary_version and vocabulary_reference cant be NA
vocabulary <- vocabulary %>% mutate(vocabulary_version = if_else(is.na(vocabulary_version), "", vocabulary_version))
vocabulary <- vocabulary %>% mutate(vocabulary_reference = if_else(is.na(vocabulary_reference), "", vocabulary_reference))

# Fix 4 : concept name is na
concept <- concept %>% mutate(concept_name = if_else(is.na(concept_name),concept_code,concept_name))

# checking ----------------------------------------------------------------

# vocabulary
v <- vocabulary %>% filter(vocabulary_id %in% append_vocabs$vocabulary_name)
v
concept %>% filter(concept_id %in% v$vocabulary_concept_id)

# concept class
cc <- concept_class %>% tail(21)
cc %>% print(n=1000)
concept %>% filter(concept_id %in% cc$concept_class_concept_id) %>% print(n=1000)

concept_synonym %>% tail()
concept_relationship %>% tail()

# save as feather --------------------------------------------------------------------
library(feather)
write_feather(concept, file.path(path_output, "CONCEPT.feather"))
write_feather(vocabulary, file.path(path_output, "VOCABULARY.feather"))
write_feather(concept_class, file.path(path_output, "CONCEPT_CLASS.feather"))
write_feather(concept_synonym, file.path(path_output, "CONCEPT_SYNONYM.feather"))
write_feather(concept_relationship, file.path(path_output, "CONCEPT_RELATIONSHIP.feather"))
write_feather(concept_fg_info, file.path(path_output, "concept_fg_info.feather"))

# CONCEPT_ANCESTOR
col_types <- cols(
  ancestor_concept_id  = col_integer(),
  descendant_concept_id  = col_integer(),
  min_levels_of_separation  = col_integer(),
  max_levels_of_separation = col_integer()
)
read_tsv(file.path(path_to_vocabulary, "CONCEPT_ANCESTOR.csv"), col_types=col_types) %>%
write_feather(file.path(path_output, "CONCEPT_ANCESTOR.feather"))

# DRUG_STRENGTH
col_types <- cols(
  drug_concept_id = col_integer(),
  ingredient_concept_id = col_integer(),
  amount_value = col_double(),
  amount_unit_concept_id = col_integer(),
  numerator_value = col_double(),
  numerator_unit_concept_id = col_integer(),
  denominator_value = col_double(),
  denominator_unit_concept_id = col_integer(),
  box_size = col_integer(),
  valid_start_date = col_date("%Y%m%d"),
  valid_end_date = col_date("%Y%m%d"),
  invalid_reason = col_character()
)
read_tsv(file.path(path_to_vocabulary, "DRUG_STRENGTH.csv"), col_types=col_types) %>%
  write_feather(file.path(path_output, "DRUG_STRENGTH.feather"))

# DOMAIN
col_types <- cols(
  domain_id = col_character(),
  domain_name = col_character(),
  domain_concept_id = col_integer()
)
read_tsv(file.path(path_to_vocabulary, "DOMAIN.csv"), col_types=col_types) %>%
  write_feather(file.path(path_output, "DOMAIN.feather"))

# RELATIONSHIP
col_types <- cols(
  relationship_id = col_character(),
  relationship_name = col_character(),
  is_hierarchical = col_character(),
  defines_ancestry = col_character(),
  reverse_relationship_id = col_character(),
  relationship_concept_id = col_integer()
)
read_tsv(file.path(path_to_vocabulary, "RELATIONSHIP.csv"), col_types=col_types) %>%
  write_feather(file.path(path_output, "RELATIONSHIP.feather"))

# # save as csv --------------------------------------------------------------------
# write_csv(concept, file.path(path_output, "CONCEPT.csv"))
# write_csv(vocabulary, file.path(path_output, "VOCABULARY.csv"))
# write_csv(concept_class, file.path(path_output, "CONCEPT_CLASS.csv"))
# write_csv(concept_synonym, file.path(path_output, "CONCEPT_SYNONYM.csv"))
# write_csv(concept_relationship, file.path(path_output, "CONCEPT_RELATIONSHIP.csv"))
# write_csv(concept_fg_info, file.path(path_output, "concept_fg_info.csv"))
#
#
# file.copy(file.path(path_to_vocabulary, "CONCEPT_ANCESTOR.csv"), file.path(path_output, "CONCEPT_ANCESTOR.csv"))
# file.copy(file.path(path_to_vocabulary, "DRUG_STRENGTH.csv"), file.path(path_output, "DRUG_STRENGTH.csv"))
# file.copy(file.path(path_to_vocabulary, "DOMAIN.csv"), file.path(path_output, "DOMAIN.csv"))
# file.copy(file.path(path_to_vocabulary, "RELATIONSHIP.csv"), file.path(path_output, "RELATIONSHIP.csv"))


##########################################################################
plot.OP.HCR<-function(file.name="HCR-OP", HCR=1,my.device='png',first.year.on.plot=2012,last.year.on.plot=2050,scenario.dir=data.path,tit='',used.penalty='no',portrait=TRUE) {
  incl.yield<-T
  incl.mean.values<-F
  cat('plotting results in dir: ',scenario.dir,'\n')
  file.name<-paste(file.name,ifelse((portrait),'P','L'),sep='_')
  plotfile<-function(dev='screen',out) {
    cleanup()
    if (portrait) {
      if (dev=='screen') X11(width=8, height=8, pointsize=12)
      if (dev=='wmf') win.metafile(filename = file.path(scenario.dir,paste(out,'.wmf',sep='')), width=8, height=8, pointsize=12)
      if (dev=='png') png(filename =file.path(scenario.dir,paste(out,'.png',sep='')), width = 1200, height = 1600,units = "px", pointsize = 25, bg="white")
      if (dev=='pdf') pdf(file =file.path(scenario.dir,paste(out,'.pdf',sep='')),width = 12, height = 16,pointsize = 12)
      par(mfcol=c(5,2))
      par(mar=c(4,4,4,6))  # c(bottom, left, top, right)
      par(oma=c(0,0,3,0))
    }
    if (!portrait) {
      if (dev=='screen') X11(width=8, height=8, pointsize=12)
      if (dev=='wmf') win.metafile(filename = file.path(scenario.dir,paste(out,'.wmf',sep='')), width=8, height=8, pointsize=12)
      if (dev=='png') png(filename =file.path(scenario.dir,paste(out,'.png',sep='')), width = 1700, height = 1200,units = "px", pointsize = 25, bg="white")
      if (dev=='pdf') pdf(file =file.path(scenario.dir,paste(out,'.pdf',sep='')),width = 18, height = 12,pointsize = 12)
      par(mfcol=c(3,3))
      par(mar=c(4,4,4,6))  # c(bottom, left, top, right)
      par(oma=c(0,0,3,0))
    }
  }

  a<-Read.OP.par(dir=scenario.dir)
  b<-Read.OP.condensed(dir=scenario.dir)
  b<-subset(b,Year>=first.year.on.plot & Year<=last.year.on.plot)
  plot.no<-0

  ref<-Read.reference.points()
  Blim<-as.vector(ref[,'Blim'])
  Bpa<-as.vector(ref[,'Bpa'])

  plotfile(dev=my.device,out=file.name);
  #for (sp in (first.VPA:nsp)){
  for (sp in (first.VPA:26)){
    sp.name<-sp.names[sp]

    bb<-droplevels(subset(b,Species.n==sp))
    bb$SSB<-bb$SSB/1000
    bb$TSB<-bb$TSB/1000
    bb$yield<-bb$yield/1000
    aa<-subset(a,Species.n==sp)

    if (aa[1,'HCR']==22) bb$SSB<-bb$TSB
    maxSSB<-max(bb$SSB)
    maxF<-max(bb$Fbar)
    T1<-aa[1,'T1']/1000
    T2<-aa[1,'T2']/1000
    Ftarget<-aa[1,'Ftarget']

    if (HCR != 1) stat<-paste("median F=",round(median(bb$Fbar),2)) else stat<-'Median'
    stat<-paste(stat," Yield:",round(median(bb$yield),0),"kt ",ifelse(aa[1,'HCR']==22,'TSB:','SSB:'),round(median(bb$SSB),0),'kt\n')
    if (incl.mean.values)    stat<-paste(stat,"mean F=",round(mean(bb$Fbar),2)," Yield:",round(mean(bb$yield),0),"kt SSB:",round(mean(bb$SSB),0),'kt')
    stat<-paste(stat,'Target F:',formatC(Ftarget,format='f',digits=2),sep='')
    if (F) {
      if (plot.no%%noxy==0){
        newplot(dev,nox,noy,filename=paste(file.name,'_',sp.name,sep=''),Portrait=Portrait)
        par(mar=c(4,4,4,6))  # c(bottom, left, top, right)
        plot.no<-0
      }
    }
    if (aa[1,'HCR']==22)  x.lab<-"TSB (1000 t)" else  x.lab<-"SSB (1000 t)"
    dim(bb)[[1]]
    plot(bb$SSB,bb$Fbar,type='p',cex=2,xlab=x.lab,ylab="Fbar",xlim=c(0,max(maxSSB,c(T2*1.1))),ylim=c(0,Ftarget*1.2),main=list(paste(sp.name,': ',stat,sep=''),cex=1.25))
    points(bb[dim(bb)[[1]],'SSB'],bb[dim(bb)[[1]],'Fbar'],type='p',cex=3,pch=19,col='black')
    #if (aa[1,'penaltyUse']==1) abline(v=aa[1,'penaltySSB']/1000,col='green',lty=2)
    if (aa[1,'penaltyUse']==1) {
      if (used.penalty=='Blim')  abline(v=Blim[sp]/1000,col='green',lty=2)
      if (used.penalty=='Bpa')  abline(v=Bpa[sp]/1000,col='green',lty=2)
    }
    if (sp==first.VPA) {
       mtext(tit,line=0, adj=0.5, cex=1.0, col="red", outer=TRUE)
    }
    plot.no<-plot.no+1

    # 1: Target F
    #      F=Ftarget
    # 2: Target F, and known trigger T1 and T2
    #      F=0                        for     SSB<T1
    #      F=Ftarget*(SSB-T1)/(T2-T1) for  T1<SSB<T2
    #      F=Ftarget                  for  T2<SSB
    # 3: Target F and Fslope, and known trigger T1 and T2
    #      F=0                          for     SSB<T1
    #      F=Ftarget*(SSB-T1)/(T2-T1)   for  T1<SSB<T2
    #      F=Ftarget+(SSB-T2)/T2*Fslope for  T2<SSB
    #  4: Logistic curve
    #      F=Ftarget / (1+exp(S1 - S1/SSB50%*SSB)
    #          Ftarget, S1 and SSB50% (SSB for which F is 50% of Ftarget)

    if (aa[1,'HCR']==1) { #constant F
      abline(h=aa[1,"Ftarget"],lwd=2,col='red')

    }
    else if (aa[1,'HCR']==2 | aa[1,'HCR']==22) {
      x<-c(0,aa[1,'T1']/1000)
      y<-c(0,0)
      lines(x,y,col='red',lwd=2)
      x<-c(aa[1,'T1']/1000,aa[1,'T2']/1000)
      y<-c(0,aa[1,'Ftarget'])
      lines(x,y,col='red',lwd=2)
      x<-c(aa[1,'T2']/1000,max(maxSSB,aa[1,'T2']/1000*1.1))
      y<-c(aa[1,'Ftarget'],aa[1,'Ftarget'])
      lines(x,y,col='red',lwd=2)
      abline(v=T1,lty=2)
      abline(v=T2,lty=2)
    }
    else if (aa[1,'HCR']==3) {
      x<-c(0,aa[1,'T1']/1000)
      y<-c(0,0)
      lines(x,y,col='red',lwd=2)
      x<-c(aa[1,'T1']/1000,aa[1,'T2']/1000)
      y<-c(0,aa[1,'Ftarget'])
      lines(x,y,col='red',lwd=2)
      x<-c(aa[1,'T2']/1000,maxSSB)
      y<-c(aa[1,'Ftarget'],aa[1,'Ftarget']+((maxSSB*1000-aa[1,'T2'])/aa[1,'T2']*aa[1,'Fslope']))
      lines(x,y,col='red',lwd=2)
      abline(v=T1,lty=2)
      abline(v=T2,lty=2)
    }
    else if (aa[1,'HCR']==4) {
      x<-seq(0,maxSSB,1)
      y<-aa[1,'Ftarget'] / (1+exp(aa[1,'S1'] - aa[1,'S1']/aa[1,'SSB50']*x))
      lines(x,y,col='red',lwd=2)
      abline(v=aa[1,'SSB50'],lty=2)
    }

    if (incl.yield) {
      par(new=T)

      plot( bb$SSB,bb$yield,axes=F,xlab=x.lab, ylab=' ',col='blue',pch=2,ylim=c(0,max(bb$yield)),xlim=c(0,max(maxSSB,c(T2*1.1))),type='p')
        points(bb[dim(bb)[[1]],'SSB'],bb[dim(bb)[[1]],'yield'],type='p',cex=3,pch=17,col='blue')

      axis(side=4)
      mtext(side=4,line=3.0,"Yield (1000 t)",cex=0.75,col='blue')
      par(xaxs="r")

    }

  }
  if (my.device %in% c('png','wmf','pdf')) dev.off()
}


LC_GapFilling <- function(FilePath, Output_Name) {

# R Functions to process dataset from Load Cell Array
# It pads missing timestamps and measurements and column names
#
# Author : Kuo-Hsine Chang, Ph.D. Dept. of Plant Agricuture, University of Guelph
# Contact: changks.github.io
# Version: 04162018

  # setup system time zone
    Sys.setenv(tz="Canada/Eastern")
  # include library
    library(zoo)
  # read the csv file
    dt = read.csv(FilePath, header=TRUE);
  # provide the column name
    names(dt) <- c("Time", "LC1", "LC2", "LC3", "LC4", "LC5", "LC6", "LC7", "LC8", "LC9", "LC10", "LC11", "LC12")
  # reformat timestamp
    dt$Time<-as.POSIXct(dt$Time,format="%Y-%m-%d %H:%M", tz = "Canada/Eastern")
  # set date to Index
    dt.zoo<-zoo(dt[,-1],dt[,1]);
  # merge two datasets
    dt_m <- merge(dt.zoo,zoo(,seq(start(dt.zoo),end(dt.zoo),by="min")), all=TRUE)
  # export to a csv file
    write.zoo(dt_m, file = Output_Name, index.name = 'Time', sep = ',', col.names = T)
}


#####################################################################################
##    Sample analysis script for linguistic surveys run on Mechanical Turk         ##
##    For surveys cosntructed using the tools described in Erlewine&Kotek (2013)   ##
##    May 2013 Hadas Kotek, licensed under the MIT license                         ##
#####################################################################################

# file prep ----

# read in the file
results <- read.csv("xxxxxxxxxxxxxx.decoded.csv",header=TRUE)

# reject non-native speakers
results <- subset(results, english == 1)

# reject non mono-lingual speakers?
#results <- subset(results, foreign == 1)

# reject participants who completed more than one survey or did not finish the survey
# mark unanswered questions with 0, all answered questions with 1
results$isNA <- ifelse(is.na(results$Choice) | results$Choice == '', 0, 1)

# count how many questions were answered by each participant
howMany <- aggregate(results$isNA, list(results$WorkerId), sum)

# compute the length of a survey in your study
SurveyLength <- as.numeric(aggregate(results$AssignmentId, by=list(results$AssignmentId), length)$x[1])

# set the completion rate below which submissions should be rejected
NotEnough <- 0.8*SurveyLength

# compute how many participants answered too many surveys or not enough questions in the survey
didTooMany <- subset(howMany, x > SurveyLength)$Group.1
didntDoEnough <- subset(howMany, x < NotEnough)$Group.1

# remove these participants from the analysis
results <- subset(results, !(WorkerId %in% didTooMany))
results <- subset(results, !(WorkerId %in% didntDoEnough))

# reject participants with low accuracy. ----
# compute accuracy for any question that had expected values such as filler items, comprehension questions and filler items
# here: we assume that the correct response to the item was saved in a hidden field, field_5
# the field number should be modified according to its number in your items file
results$isCorrect <- ifelse(is.na(results$field_5), NA, ifelse(results$field_5 == results$Choice, 1, 0))
Accuracy <- aggregate(results$isCorrect, by=list(results$WorkerId), mean, na.rm = T)
lowAcc <- subset(Accuracy, x < 0.75)$WorkerId
results <- subset(results, !(WorkerId %in% lowAcc))

# create a dataframe for target items ---
# here, assuming all non-fillers are target sections
targets <- subset(results, results$Section != 'filler')

#remane factors, give columns meaningful names
#code below assumes two factors, change as needed
library(plyr)
targets <- rename(targets, c("Factor1"="XXXX", "Factor2"="YYYY"))

# data visualization ----
# plot histograms by the different factors in your experiment for each condition
library(lattice)
histogram(~ Choice | Factor1 * Factor2, data=targets)
histogram(~ Choice | Factor1, data=targets)
histogram(~ Choice | Factor2, data=targets)
histogram(~ Choice, data=targets)

# basic aggregation (for ratings or binary forced choice coded as 0-1)----
aggregate(targets$Choice, by=list(targets$WorkerId), mean)
aggregate(targets$Choice, by=list(targets$WorkerId, targets$Factor1, targets$Factor2), mean)

# basic aggregation (for completions)
aggregate(targets$WorkerId, by=list(targets$Choice), length)
aggregate(targets$WorkerId, by=list(targets$Choice, targets$Factor1, targets$Factor2), length)

# looking at individual items ----
#target items (for ratings or binary forced choice coded as 0-1)
aggregate(targets$Choice, by=list(targets$Item), mean)
aggregate(targets$Choice, by=list(targets$Condition, targets$Item), mean)

# target items (for completions)
aggregate(targets$WorkerId, by=list(targets$Choice, targets$Condition), length)

# filler items with expected answers
aggregate(results$isCorrect, by=list(results$Item), mean, na.rm = T)

# slow vs. fast workers
# perform analysis separately on these groups instead of on all of targets.
meanTime <- mean(targets$WorkTimeInSeconds)
fastWorkers <- subset(targets, targets$WorkTimeInSeconds < MeanTime)
slowWorkers <- subset(targets, targets$WorkTimeInSeconds >= MeanTime)


# In RStudio, click on 'Run App' on the top right in order to run the app
# in a test version in your own browser.
library(shiny)
library(dplyr)
library(ggplot2)
data <- final_data
#data <- read.csv("./TOTAL.csv")
test <- unique(data$SiteID)
filtered <- filter(data, SiteID == "GWP")
View(filtered)
# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("Survey Questions"),

    # Sidebar with a slider input for number of bins
        sidebarPanel(
            radioButtons("question",
                        "Select Question",
                        choices = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14"),
                        selected = "1"),
            selectInput(
                "select",
                label = h3("Filter on site"),
                choices = c("All", "ACRS", "Greenwood", "IDIC", "PMSC", "Sunshine Garden", "Wallingford", "CISC", "South Park", "GWP", "Southeast")
            )
            ),
        mainPanel(
           plotOutput("bar"),
           plotOutput("income")
        )
    )

server <- function(input, output) {
    output$bar <- renderPlot({
        if (input$question == "1") {
            tbl <- with(data, table(data$Do.more.volunteer.work))
        }
        else if (input$question == "2") {
            tbl <- with(data, table(data$See.friends.more.often.make.new.friends))
        }
        else if (input$question == "3") {
            tbl <- with(data, table(data$Take.better.care.of.my.health))
        }
        else if (input$question == "4") {
            tbl <- with(data, table(data$Eat.meals.that.are.better.for.me))
        }
        else if (input$question == "5") {
            tbl <- with(data, table(data$Have.more.energy))
        }
        else if (input$question == "6") {
            tbl <- with(data, table(data$Feel.happier.or.more.satisfied.with.my.life))
        }
        else if (input$question == "7") {
            tbl <- with(data, table(data$Have.something.to.look.forward.to.each.day))
        }
        else if (input$question == "8") {
            tbl <- with(data, table(data$Know.where.to.ask.if.I.need.a.service.such.as.a.ride.to.a.doctor.or.an.aide))
        }
        else if (input$question == "9") {
            tbl <- with(data, table(data$Feel.more.able.to.stay.independent))
        }
        else if (input$question == "10") {
            tbl <- with(data, table(data$Feel.that.the.senior.center.has.had.a.positive.effect.on.my.life))
        }
        else if (input$question == "11") {
            tbl <- with(data, table(data$Learn.new.things))
        }
        else if (input$question == "12") {
            tbl <- with(data, table(data$Have.learned.about.services.and.benefits))
        }
        else if (input$question == "13") {
            tbl <- with(data, table(data$Am.more.physically.active))
        }
        else if (input$question == "14") {
            tbl <- with(data, table(data$Would.recommend.the.senior.center.to.a.friend.or.family.member))
        }

        barplot(tbl, beside = TRUE, legend = TRUE)
    })
    output$income <- renderPlot({
        if (input$select == "ACRS") {
            filtered <- filter(data, SiteID == "ACRS")
        }
        else if (input$select == "Greenwood") {
            filtered <- filter(data, SiteID == "Greenwood")
        }
        else if (input$select == "IDIC") {
            filtered <- filter(data, SiteID == "IDIC")
        }
        else if (input$select == "PMSC") {
            filtered <- filter(data, SiteID == "PMSC")
        }
        else if (input$select == "Sunshine Garden") {
            filtered <- filter(data, SiteID == "Sunshine Garden")
        }
        else if (input$select == "Wallingford") {
            filtered <- filter(data, SiteID == "Wallingford")
        }
        else if (input$select == "CISC") {
            filtered <- filter(data, SiteID == "CISC")
        }
        else if (input$select == "South Park") {
            filtered <- filter(data, SiteID == "South Park")
        }
        else if (input$select == "GWP") {
            filtered <- filter(data, SiteID == "GWP")
        }
        else if (input$select == "Southeast") {
            filtered <- filter(data, SiteID == "Southeast")
        }
        else {
            filtered <- data
        }
        filtered <- filter(filtered, !is.na(filtered$What.is.your.estimated.annual.income))
        ggplot(filtered, aes(filtered$What.is.your.estimated.annual.income), y = count()) + geom_bar() +
            coord_flip()
    })

}

# Run the application

# shinyApp(ui = ui, server = server)


# 06. Alpha Diversity
# Figure 3b, Figure 5b, Figure S5, Figure S9
# Ref for phyloseq: McMurdie, P. J. & Holmes, S. phyloseq: An R Package for Reproducible Interactive Analysis and Graphics of Microbiome Census Data. PLOS ONE 8, e61217 (2013).
# Ref for picante: Kembel, S. W. et al. Picante: R tools for integrating phylogenies and ecology. Bioinformatics 26, 1463–1464 (2010).
# Water and sediment sequences were analyzed separately

#### Phyloseq Object ####
ps.noncontam.tree

#### Set Directory ####
alpha <- file.path(paste(path_phy, "/alpha_diversity", sep=""))
dir.create(alpha, showWarnings=FALSE)
setwd(alpha)

#### Get many alpha diversity incides ####
alpha.div <- microbiome::alpha(ps.noncontam.tree, index = "all")
alpha.div.phyloseq <- estimate_richness(ps.noncontam.tree, split = TRUE, measures = NULL)
head(alpha.div)
head(alpha.div.phyloseq)

write.table(alpha.div,paste("alpha.div.pkgmicrobiome.csv", sep=""), sep=",", row.names = T)
write.table(alpha.div.phyloseq,paste("alpha.div.pkgphyloseq.csv", sep=""), sep=",", row.names = T)

#### Calculate Faith's PD ####
obj_ps.pd <- pd(t(otu_table(ps.noncontam.tree)), filt_tree, include.root=T)
head(obj_ps.pd)
write.table(obj_ps.pd,paste("alpha.div.faithsPD.csv", sep=""), sep=",", row.names = T)

#### Preliminary plots ####
# Function for plotting multiple parameters (Water samples)
parameters <- c("Depth_cat", "Location_description", "Season", "Strat_group", "Sequence_batch")

# Function for plotting multiple parameters (Sediment samples)
parameters <- c("Depth_cat", "Location_description", "Depth_desc")

func_richness <- llply(as.list(parameters), function(para, x) {
    plot_alpha <- plot_richness(physeq = x, x = para) +
                    geom_boxplot(notch=FALSE) +
                    geom_jitter(shape=16, position=position_jitter(0.2))
    save_file_plot <- paste("alpha_div.barplot.", para,".pdf", sep="")
    ggsave(save_file_plot, path = alpha, scale = 1, width = 20, height = 6, units = c("in"), dpi = 300)
}, ps.noncontam.tree)

#### Statistical tests (Repeat 1-6 for every variable combinations) ####
# 1. Anova
aov.obs = aov(Observed ~ Depth_cat, data=alpha.div.metadata2)
summary.lm(aov.obs)

# 2. Extract the residuals & Run Shapiro-Wilk test
aov_residuals <- residuals(object = aov.obs)
shapiro.test(x = aov_residuals)

# 3. Check homogeneity
leveneTest(Observed ~ Loc_sec, data = alpha.div.metadata2)

# 4. Kruskal-Wallis test
kruskal.test(Observed ~ Loc_sec, data=alpha.div.metadata2)

# 5. To do all the pairwise comparisons between groups and correct for multiple comparisons
pairwise.wilcox.test(alpha.div.metadata2$Observed, alpha.div.metadata2$Loc_sec, p.adjust.method="fdr", exact=FALSE, paired=FALSE)

# 6. Plot
par(mfrow=c(2,2))
plot(aov.obs)

#### Prepare for plots Figure S5 and S9 ####

# Combine data
combo_plot <- as.data.frame(as.matrix(sample_data(ps.noncontam.tree)))
combo_plot$Observed <- alpha.div$observed[match(rownames(alpha.div), rownames(combo_plot))]
combo_plot$Shannon <- alpha.div$diversity_shannon[match(rownames(alpha.div), rownames(combo_plot))]
combo_plot$diversity_inverse_simpson <- alpha.div$diversity_inverse_simpson[match(rownames(alpha.div), rownames(combo_plot))]
combo_plot$PD <- obj_ps.pd$PD[match(rownames(obj_ps.pd), rownames(combo_plot))]

head(combo_plot)

### Melt the dataframe and fix the variable and value column
# Water samples
combo_plot$Season <- gsub("Spring", "Incipient Stratification", combo_plot$Season)
combo_plot$Season <- gsub("Summer", "Stratification (~3 months)", combo_plot$Season)
combo_plot$Season <- gsub("Fall", "Stratification (~7 months)", combo_plot$Season)
combo_plot$Strat_group <- gsub("Unstratified", "Incipient Stratification2", combo_plot$Strat_group)
combo_plot_melt <- reshape2::melt(combo_plot, id=c("SampleID", "Observed", "Shannon", "diversity_inverse_simpson", "PD"))
combo_plot_melt <- subset(combo_plot_melt, variable=="Location_description" | variable=="Strat_group" | variable=="Season")
combo_plot_melt$value = factor(combo_plot_melt$value, levels=c("Incipient Stratification", "Stratification (~3 months)", "Stratification (~7 months)", "Inlet", "Inlet-Middle", "Middle", "Middle-Outlet", "Outlet", "Incipient Stratification2", "Epilimnion", "Thermocline", "Hypolimnion"), ordered = TRUE)
combo_plot_melt$variable <- gsub("Location_description", "Location", combo_plot_melt$variable)
combo_plot_melt$variable <- gsub("Strat_group", "Stratification Layer", combo_plot_melt$variable)
combo_plot_melt$variable <- gsub("Season", "Stratification Time", combo_plot_melt$variable)
combo_plot_melt$variable <- gsub("Sequence_batch", "Sequence batch", combo_plot_melt$variable)
combo_plot_melt$variable = factor(combo_plot_melt$variable, levels=c("Location", "Stratification Time", "Stratification Layer", "Sequence batch"))
combo_plot_melt$variable2 = combo_plot_melt$variable
combo_plot_melt$variable <- NULL
head(combo_plot_melt)
write.csv(combo_plot_melt, paste0("combo_plot_melt.csv"))

# Sediment samples grouped by Location and Depth
combo_plot_select <- combo_plot[, c("SampleID", "Observed", "Shannon", "diversity_inverse_simpson", "PD", "Location_description", "Depth_desc")]
combo_plot_melt <- reshape2::melt(combo_plot_select, id=c("SampleID", "Observed", "Shannon", "diversity_inverse_simpson", "PD", "Location_description"))
combo_plot_melt$value = factor(combo_plot_melt$value, levels=c("Top 5 cm", "5-10 cm", "10-21 cm"), ordered = TRUE)
head(combo_plot_melt)
write.csv(combo_plot_melt, paste0("combo_plot_melt_LocDepth.csv"))

### Wilcoxon rank sum test
# For Sediment samples grouped by Location and Depth, change 'group_by(variable2)' to 'group_by(Location_description)'
stat.test_Obj <- combo_plot_melt %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(Observed ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_Obj
write.csv(stat.test_Obj, paste0("wilcox_test_Observed.csv"))

stat.test_PD <- combo_plot_melt %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(PD ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_PD
write.csv(stat.test_PD, paste0("wilcox_test_FaithsPD.csv"))

stat.test_Shannon <- combo_plot_melt %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(Shannon ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_Shannon
write.csv(stat.test_Shannon, paste0("wilcox_test_Shannon.csv"))

stat.test_InvSimpson <- combo_plot_melt %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(diversity_inverse_simpson ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_InvSimpson
write.csv(stat.test_InvSimpson, paste0("wilcox_test_InvSimpson.csv"))

#### Plot Figure S5 and S9 ####
# Set up theme
plot_theme <- theme(panel.background = element_rect(fill = "white", colour = "black", size = 1, linetype = "solid"),
    panel.border = element_rect(colour="black", size=1, fill=NA),
    strip.background=element_rect(fill='white', colour='white', size = 0),
    strip.text = element_text(face="bold", size=15),
    panel.spacing.x=unit(0.5, "lines"),
    panel.grid.major = element_line(size = 0),
    panel.grid.minor = element_line(size = 0),
    axis.text = element_text(size=15, colour="black"),
    axis.title = element_text(face="bold", size=15),
    axis.title.x = element_blank(),
    axis.text.x = element_text(angle = 45, vjust = 1, hjust=1),
    legend.position="right",
    legend.key = element_rect(fill = "white"),
    legend.title = element_text(face="bold", size=15),
    legend.text = element_text(size=15))

# Plot all the indices

### Observed
# Water samples
plot_nomargins_Obs <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(200,3200), breaks=c(500, 1000, 1500, 2000, 2500, 3000))
stat.test_Obj <- stat.test_Obj %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13, comparisons = list(c("Incipient Stratification2", "Epilimnion"), c("Incipient Stratification2", "Hypolimnion"),c("Epilimnion", "Thermocline"), c("Epilimnion", "Hypolimnion"), c("Thermocline", "Hypolimnion")))

# Sediment samples (pound out 'stat_pvalue_manual' for grouping by Sediment and Depth)
plot_nomargins_Obs <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,4200), breaks=c(0, 500, 1000, 1500, 2000, 2500, 3000, 3500, 4000))

# Plot Observed
alpha_plot_Obs <- ggplot(combo_plot_melt, aes(x=value, y=Observed)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Observed") +
    facet_grid(. ~ variable2, scales="free") +
    stat_pvalue_manual(stat.test_Obj, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7, step.group.by="variable2") +
    plot_theme + plot_nomargins_Obs
alpha_plot_Obs

### PD
# Water samples
plot_nomargins_PD <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(40,250), breaks=c(50, 100, 150, 200, 250))
stat.test_PD <- stat.test_PD %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13, comparisons = list(c("Incipient Stratification", "Stratification (~3 months)"), c("Incipient Stratification", "Stratification (~7 months)"), c("Incipient Stratification2", "Thermocline"), c("Incipient Stratification2", "Hypolimnion"),c("Epilimnion", "Thermocline"), c("Epilimnion", "Hypolimnion"), c("Thermocline", "Hypolimnion")))

# Sediment samples (pound out 'stat_pvalue_manual' for grouping by Sediment and Depth)
plot_nomargins_PD <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,310), breaks=c(0, 50, 100, 150, 200, 250, 300))

# Plot PD
alpha_plot_PD <- ggplot(combo_plot_melt, aes(x=value, y=PD)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Faith's PD") +
    facet_grid(. ~ variable2, scales="free") +
    stat_pvalue_manual(stat.test_PD, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7, step.group.by="variable2") +
    plot_theme + plot_nomargins_PD
alpha_plot_PD

### Shannon
# Water samples
plot_nomargins_Shannon <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(3,8.8), breaks=c(4, 5, 6, 7, 8))
stat.test_Shannon <- stat.test_Shannon %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13, comparisons = list(c("Incipient Stratification", "Stratification (~3 months)"), c("Incipient Stratification", "Stratification (~7 months)"), c("Inlet", "Middle"), c("Incipient Stratification2", "Thermocline"), c("Incipient Stratification2", "Hypolimnion"), c("Epilimnion", "Thermocline"), c("Epilimnion", "Hypolimnion"), c("Thermocline", "Hypolimnion")))

# Sediment samples (pound out 'stat_pvalue_manual' for grouping by Sediment and Depth)
plot_nomargins_Shannon <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(3.7,7.5), breaks=c(4, 4.5, 5, 5.5, 6, 6.5, 7))

# Plot Shannon
alpha_plot_Shannon <- ggplot(combo_plot_melt, aes(x=value, y=Shannon)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Shannon") +
    facet_grid(. ~ variable2, scales="free") +
    stat_pvalue_manual(stat.test_Shannon, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7, step.group.by="variable2") +
    plot_theme + plot_nomargins_Shannon
alpha_plot_Shannon

### Inverse Simpson
# Water Samples
plot_nomargins_InvSimpson <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,325), breaks=c(0, 100, 200, 300))
stat.test_InvSimpson <- stat.test_InvSimpson %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13, comparisons = list(c("Incipient Stratification2", "Epilimnion"), c("Incipient Stratification2", "Hypolimnion"), c("Epilimnion", "Thermocline"), c("Epilimnion", "Hypolimnion"), c("Thermocline", "Hypolimnion")))

# Sediment samples (pound out 'stat_pvalue_manual' for grouping by Sediment and Depth)
plot_nomargins_InvSimpson <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,475), breaks=c(0, 100, 200, 300, 400))

# Plot Inverse Simpson
alpha_plot_InvSimpson <- ggplot(combo_plot_melt, aes(x=value, y=diversity_inverse_simpson)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Inverse Simpson") +
    facet_grid(. ~ variable2, scales="free") +
    stat_pvalue_manual(stat.test_InvSimpson, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7, step.group.by="variable2") +
    plot_theme + plot_nomargins_InvSimpson
alpha_plot_InvSimpson

# Combine
both <- plot_grid(alpha_plot_Obs + theme(axis.text.x = element_blank(), legend.position="none"),
                  alpha_plot_Shannon + theme(axis.text.x = element_blank(), legend.position="none", strip.text = element_blank()),
                  alpha_plot_InvSimpson + theme(axis.text.x = element_blank(), legend.position="none", strip.text = element_blank()),
                  alpha_plot_PD + theme(legend.position="none", strip.text = element_blank()),
                  ncol=1, align = "v", axis="b", rel_heights = c(0.7,0.7,0.7,1))
both
save_file <- paste("alpha.div.shannon.simpson.pd.obs.variables.svg", sep="")
ggsave(save_file, path = alpha, plot = both, scale = 1, width = 10, height = 16, units = c("in"), dpi = 300)

#### Prepare for plotting only Stratification Layer (Figure 3b, Figure 5b)  ####
# Water samples
combo_plot_melt_sub <- subset(combo_plot_melt, variable2=="Stratification Layer")
combo_plot_melt_sub$value <- gsub('Incipient Stratification2', 'Incipient Stratification', combo_plot_melt_sub$value)
combo_plot_melt_sub$value = factor(combo_plot_melt_sub$value, levels=c("Incipient Stratification", "Epilimnion", "Thermocline", "Hypolimnion"), ordered = TRUE)

head(combo_plot_melt_sub)

# Sediment samples grouped by Location
combo_plot_melt_sub <- reshape2::melt(combo_plot_select, id=c("SampleID", "Observed", "Shannon", "diversity_inverse_simpson", "PD"))
combo_plot_melt_sub <- subset(combo_plot_melt_sub, variable=="Location_description")
combo_plot_melt_sub$value = factor(combo_plot_melt_sub$value, levels=c("Inlet", "Outlet"), ordered = TRUE)
head(combo_plot_melt_sub)
write.csv(combo_plot_melt, paste0("combo_plot_melt_Loc.csv"))

### Wilcoxon rank sum test
# For Sediment samples grouped by Location, pound out 'group_by(variable2)' and change 'value' to 'Location_description'
stat.test_Obj <- combo_plot_melt_sub %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(Observed ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_Obj
write.csv(stat.test_Obj, paste0("wilcox_test_Observed.csv"))

stat.test_PD <- combo_plot_melt_sub %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(PD ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_PD
write.csv(stat.test_PD, paste0("wilcox_test_FaithsPD.csv"))

stat.test_Shannon <- combo_plot_melt_sub %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(Shannon ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_Shannon
write.csv(stat.test_Shannon, paste0("wilcox_test_Shannon.csv"))

stat.test_InvSimpson <- combo_plot_melt_sub %>%
  group_by(variable2) %>%
  rstatix::wilcox_test(diversity_inverse_simpson ~ value) %>%
  rstatix::adjust_pvalue(method = "fdr") %>%
  rstatix::add_significance()
stat.test_InvSimpson
write.csv(stat.test_InvSimpson, paste0("wilcox_test_InvSimpson.csv"))

#### Plot Figure 3b, Figure 5b ####

# Set up theme
plot_theme <- theme(panel.background = element_rect(fill = "white", colour = "black", size = 1, linetype = "solid"),
    panel.border = element_rect(colour="black", size=1, fill=NA),
    strip.background=element_rect(fill='white', colour='white', size = 0),
    strip.text = element_text(face="bold", size=15),
    panel.spacing.x=unit(0.5, "lines"),
    panel.grid.major = element_line(size = 0),
    panel.grid.minor = element_line(size = 0),
    axis.text = element_text(size=15, colour="black"),
    axis.title = element_text(face="bold", size=15),
    axis.title.x = element_blank(),
    axis.text.x = element_text(angle = 45, vjust = 1, hjust=1),
    legend.position="right",
    legend.key = element_rect(fill = "white"),
    legend.title = element_text(face="bold", size=15),
    legend.text = element_text(size=15),
    plot.margin=unit(c(t = 0.5, r = 0.2, b = 0, l = 0.2),"cm"))

### Observed
# Water samples
plot_nomargins_Obs <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(200,3200), breaks=c(200, 1000, 2000, 3000))
stat.test_Obj <- stat.test_Obj %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13)

# Sediment samples
plot_nomargins_Obs <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,4200), breaks=c(0, 500, 1000, 1500, 2000, 2500, 3000, 3500, 4000))
stat.test_Obj <- stat.test_Obj %>% rstatix::add_y_position(fun = "max", scales = "free")

# Plot Observed
alpha_plot_Obs <- ggplot(combo_plot_melt_sub, aes(x=value, y=Observed)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Observed") +
    stat_pvalue_manual(stat.test_Obj, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7) +
    plot_theme + plot_nomargins_Obs
alpha_plot_Obs

### PD
# Water samples
plot_nomargins_PD <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(40,250), breaks=c(50, 100, 150, 200, 250))
stat.test_PD <- stat.test_PD %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13)

# Sediment samples
plot_nomargins_PD <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,310), breaks=c(0, 50, 100, 150, 200, 250, 300))
stat.test_PD <- stat.test_PD %>% rstatix::add_y_position(fun = "max", scales = "free")

# Plot PD
alpha_plot_PD <- ggplot(combo_plot_melt_sub, aes(x=value, y=PD)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Faith's PD") +
    stat_pvalue_manual(stat.test_PD, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7) +
    plot_theme + plot_nomargins_PD
alpha_plot_PD

### Shannon
# Water samples
plot_nomargins_Shannon <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(3,8.8), breaks=c(4, 5, 6, 7, 8))
stat.test_Shannon <- stat.test_Shannon %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13)

# Sediment samples
plot_nomargins_Shannon <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(3.7,7.5), breaks=c(4, 4.5, 5, 5.5, 6, 6.5, 7))
stat.test_Shannon <- stat.test_Shannon %>% rstatix::add_y_position(fun = "max", scales = "free")

# Plot Shannon
alpha_plot_Shannon <- ggplot(combo_plot_melt_sub, aes(x=value, y=Shannon)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Shannon") +
    stat_pvalue_manual(stat.test_Shannon, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7) +
    plot_theme + plot_nomargins_Shannon
alpha_plot_Shannon

### Inverse Simpson
# Water Samples
plot_nomargins_InvSimpson <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,350), breaks=c(0, 100, 200, 300))
stat.test_InvSimpson <- stat.test_InvSimpson %>% rstatix::add_y_position(fun = "max", scales = "free", step.increase=0.13)

# Sediment Samples
plot_nomargins_InvSimpson <- scale_y_continuous(expand = expansion(mult = c(0, 0)), limits=c(0,475), breaks=c(0, 100, 200, 300, 400))
stat.test_InvSimpson <- stat.test_InvSimpson %>% rstatix::add_y_position(fun = "max", scales = "free")

alpha_plot_InvSimpson <- ggplot(combo_plot_melt_sub, aes(x=value, y=diversity_inverse_simpson)) +
    stat_boxplot(geom = "errorbar", width = 0.2) +
    geom_boxplot(outlier.size=0, outlier.colour="white", fill="gray88") +
    geom_jitter(size=2, position=position_jitter(0.2), alpha=0.8, shape=21, fill="grey88") +
    ylab("Inverse Simpson") +
    stat_pvalue_manual(stat.test_InvSimpson, hide.ns=TRUE, label="p.adj.signif", tip.length=0.01, label.size = 7, bracket.size=0.7) +
    plot_theme + plot_nomargins_InvSimpson
alpha_plot_InvSimpson

### Combine plots
both <- plot_grid(alpha_plot_Obs,
                  alpha_plot_Shannon,
                  alpha_plot_InvSimpson,
                  alpha_plot_PD,
                  ncol=4, align = "v", axis="b", rel_widths=c(0.8,0.8,0.8,0.8)) + theme(plot.margin=unit(c(t = 0, r = 0.5, b = 0, l = 1.5),"cm"))
both

save_file <- paste("alpha.div.shannon.simpson.pd.obs.variables.svg", sep="")
ggsave(save_file, path = alpha, plot = both, scale = 1, width = 10, height = 5, units = c("in"), dpi = 300)


########################################################
# The MIT License (MIT)
#
# Copyright (c) 2014 Florian D. Schneider & Sonia Kéfi
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
#
########################################################

######################
## mapping function ##
######################

# required to vectorise the counting and plotting.
# returns a map of the landscape to translate it into a vector with boundaries and another one to back-translate it to a vector without boundaries into the global environment. Needs to be called only once for the dimensions of the lattice.

mapping <- function(width, height, boundary = "periodic", i_matrix = matrix(c(0,1,0,1,NA,1,0,1,0), ncol = 3, byrow = TRUE)) {

  # derive helper vectors for counting:
  # transformation vector for evaluation at the border of the grid
  # set evaluation matrix
  X <- matrix(as.integer(1:(width*height)), ncol = width, byrow =TRUE)
  # setting the border of the evaluation matrix X
  X <- cbind(X[,width], X, X[,1] )
  X <- rbind(X[height,], X, X[1,] )
  # transformation vector which adds the border to the lattice:
  x_with_border <- as.integer(t(X))

  assign("x_with_border", as.integer(t(X))  , envir = .GlobalEnv )

  # from the matrix X (with copied border cells), which cells are the actual cells (reverse transformation vector of the previous lines)
  #x_to_evaluate <- sort(matrix(1:prod(dim(X)), ncol = dim(X)[2], byrow =TRUE)[-c(1, dim(X)[1]), -c(1,dim(X)[2])]  )

  assign("x_to_evaluate", sort(matrix(1:prod(dim(X)), ncol = dim(X)[2], byrow =TRUE)[-c(1, dim(X)[1]), -c(1,dim(X)[2])]  )	, envir = .GlobalEnv )

  # defining the neighborhood which is to be evaluated
  # set interaction matrix
  I <- i_matrix
  # coordinates of neighbours in Interaction matrix I:
  neighbours_in_I <- which(is.finite(abs(I)/abs(I)), arr.in = TRUE)
  # coordinates relative to the evaluated cell (=  which(is.na(I) )
  relrow <- neighbours_in_I[,1]-which(is.na(I), arr.ind = TRUE)[1]
  relcol <- neighbours_in_I[,2]-which(is.na(I), arr.ind = TRUE)[2]

  # relative position of the four direct neighbours of a cell
  #interact <- (relrow * dim(X)[2] + relcol)

  assign("interact", relrow * dim(X)[2] + relcol, envir = .GlobalEnv )

}

####################
## count function ##
####################

count  <- function(x, neighbor) {

  neighbors <- numeric(length = prod(x$dim))
  x_logical_with_border <- (x$cells %in% neighbor)[x_with_border]
  for(k in interact) {
    neighbors <- neighbors + x_logical_with_border[x_to_evaluate+k]
  }
  return(neighbors)
}

##################################
## initialise a new "landscape" ##
##################################

init_landscape <- function(states, cover, width = 50, height = 50) {
  if(length(states)!=length(cover)) warning("length of vector 'states' and vector 'cover' differs. I am distributing cover at random!")
  cover <- cover/sum(cover) #normalizing total cover to 1
  cells <- factor(rep(states[1], times = width*height), levels = states) # vector of empty cells in state "0"
  for(i in 2:length(states)) {
    s <- floor(width*height*cover[i]) #how many cells are in state[i]
    cells[sample(which(cells %in% states[1:(i-1)]), s, replace = FALSE)] <- states[i]  # replace s cells, randomly drawn, with state[i]
    ## BUG: this does not distribute cells correctly!!!
  }

  # wrap landscape object:
  initial <- list(
    dim = c(width = as.integer(width), height = as.integer(height)),  # first element contains the dimensions of the landscape
    cells = cells  #contains a random row-wise, factorial vector to fill the grid
  )
  levels(initial$cells) <- states  #assign cell states
  class(initial) <- c("list","landscape") # set class of object (required for plotting)
  return(initial)
}

############################################
## summary output for a landscape object  ##
############################################

summary.landscape <- function(x) {
  mapping(x$dim[1],x$dim[2])
  out <- list()
  out$dim <- x$dim
  out$n <- sapply(levels(x$cells), function(y) {sum(x$cells == y)})
  out$cover <- out$n/sum(out$n)
  out$local <- sapply(levels(x$cells), function(y) {mean(  (count(x,y)/4)[x$cells == y]  )})
  return(out)
}

print.landscape <- function(x) {
  return(summary(x))
}

########################################################
## plotting function for objects of class "landscape" ##
########################################################
grayscale <- colorRampPalette(c("black", "white"), space = "rgb")

plot.landscape <- function(x, grid = FALSE, axis = FALSE, cols = "auto", add = FALSE, ani = FALSE, ...) {
  lvls <- levels(x$cells)
  nlev <- length(lvls)
   if(cols[1] == "auto") cols = grayscale(nlev)  # default color value

  if(ani & Sys.info()[['sysname']] == "Windows") adj = -0.5 else adj = 0 #this adjustment constant is added when producing a pixel accurate png or gif file, requires TRUE when the function is used to plot animated figures.

  if(!add) plot(NA,NA, xlim = c(0.5+adj, x$dim[1]+0.5+adj), ylim = c( x$dim[2]+0.5+adj, 0+0.5+adj), bty = c("n", "o")[grid+1], xaxs = "i", yaxs = "i",xlab = "", ylab = "", xaxt = "n", yaxt = "n", asp = 1, ... )

  if(axis && !add) axis(3)
  if(axis && !add) axis(2)

  if(grid) border = "grey80" else border = cols[as.numeric(x$cells)]

  rect(rep(1:x$dim[1], times = x$dim[2])-.5, rep(1:x$dim[2], each = x$dim[1])-.5, rep(1:x$dim[1], times = x$dim[2])+.5, rep(1:x$dim[2], each = x$dim[1])+.5, col = cols[as.numeric(x$cells)], border = border)

  if(grid) box()
}

###################################################
## animated plot for objects of class "caresult" ##
###################################################

animateCA <- function(result, filename) {
  # FIGURE 3 -- animated gif
  library(animation)
  if(Sys.info()[['sysname']] == "Linux") X11.options(antialias = "none") #for Linux Systems to enable pixel-wise plotting in (animated) gif-files.
  if(Sys.info()[['sysname']] == "Windows") windows.options(antialias = "none") #for Windows Systems to enable pixel-wise plotting in (animated) gif-files.
  width = result$timeseries[[1]]$dim[1]
  height = result$timeseries[[1]]$dim[2]

  saveGIF(
    for(i in 1:length(result$timeseries) ) {
      par(mar = c(0,0,0,0))
      plot(result$timeseries[[i]], grid = FALSE, ani = TRUE)
    }
    , movie.name = filename, img.name = "grid", convert = "convert", interval = 0.01/1,
    cmd.fun = system, clean = TRUE, ani.width = width, ani.height = height, outdir = getwd())
}

##################################
## load specs for different CA model ##
##################################

source("R/grazing.r")
source("R/musselbed.r")

################################
## run simulation of CA model ##
################################

ca <- function(x, parms = "default", delta = 0.1, t_max = 1000, t_min = 500, t_eval = 200, isstable = 0.00001, saveeach = 50, model = musselbed )  {

  if(parms[1] != "default") {
    if(!all(names(model$parms) %in% names(parms))) {
      stop(paste("missing parameter(s): ", names(parms)[all(names(model$parms) %in% names(parms))] , "! please specify!"    ) )
    }
  } else {
    parms <- model$parms
    warning("you did not specify 'parms'! using default parameters of model!")
  }

  mapping(x$dim[1], x$dim[2])
  xstats <- summary(x)
  states <- levels(x$cells)
  # calculate timesteps for snapshots:
  n_snaps <- length(seq(t_min-2*t_eval,t_min,saveeach)) # number of snapshots over t_eval
  t_snaps <-  ceiling(t_max/(saveeach*n_snaps))*(n_snaps*saveeach)
  snapshots <- data.frame(time = seq(t_min-2*t_eval, t_max, saveeach), i= seq(t_min-2*t_eval, t_max, saveeach)+1, pos = c(rep(1:n_snaps,2),1) )
  ### BUG: this is not dynamically adjusting to t_min, t_max, t_eval, saveeach !!!

  # initialise result object:
  result <- list()  # generate list object
  result$model <- model
  result$model$parms <- parms
  result$time <- seq(0, t_min) # add vector of realized timesteps
  result$evaluate <- c(t_min, t_min+2*t_eval)+1

  result$cover <- as.data.frame(t(xstats$cover))
  result$cover <- result$cover[rep(1, t_min+1),] # preallocating memory

  result$local <- as.data.frame(t(xstats$local))
  result$local <- result$local[rep(1, t_min+1),] # preallocating memory

  result$snapshots <- snapshots
  result$timeseries <- list()
  result$timeseries <- lapply(1:n_snaps, function(i) x) # preallocating memory

  # --------------- simulation -----------------

  parms_temp <- parms   # set temporary parameter object

  # initialise simulation variables:
  x_old <- x  # ghost matrix at t_i
  x_new <- x_old
  stability <- 1  # check value for stability
  i = 0  # iterator for simulation timesteps

  # starting iterations:
  while(stability > isstable & i <= t_max ) {

    i <- i +1  # increase iterator

    model$update(x_old, parms, 10) -> x_new

    xstats <- summary(x_new)
    result$cover[i,] <- xstats$cover
    result$local[i,] <- xstats$local

    x_old <- x_new # replace ghost matrix for next iteration

    if(i %in% snapshots$i) {
      result$timeseries[[match(i, snapshots$i)]] <- x_new
    }

    if(i > t_min) { # if we are over the minimal timespan
      t_1 <- (i-2*t_eval):(i-t_eval)-1 # vector of t_eval timesteps previous to the last t_eval timesteps
      t_2 <- (i-t_eval):(i) # vector of the last t_eval timesteps

      if(result$cover[[1]][i] > 0) {
        stability <- (abs(mean(result$cover[[1]][t_1]) - mean(result$cover[[1]][t_2])))/(mean(result$cover[[1]][t_1])) # calculate stability, i.e. difference between the mean cover in the two evaluation periods t_1 and t_2
      } else {
        stability <- 0 # set stability to 0 if cover is 0, immediate stop of simulation
      }
      result$evaluate <- c(min(t_1), max(t_2))
      result$time[i] <- i # save timestep to results

    }

  }

  class(result) <- "ca_result"
  return(result)
}

print.ca_result <- function(x) {
  cat("Model run of", x$model$name, " over ", tail(x$time,1)," timesteps. \n")
  cat("final cover:")
}

################################
## plot function for 'ca_result' ##
################################

plot.ca_result <- function(x, plotstates = c(TRUE, FALSE, FALSE), snapshots = FALSE, cols = x$model$cols , lwd = 1, ...) {

  if(snapshots) {

  }

  plot(NA,NA,
       type = "l",
       col = x$model$cols[1],
       xlab = "time", ylab = paste("cover of", x$model$states[1]) ,
       xlim = c(1, max(x$time)), ylim = c(0,1),
       ...)

  if(length(plotstates) == length(x$model$states)  ) {
    for(i in (1:length(plotstates))[plotstates]) {
      lines(x$time,x$cover[[i]], col = cols[i], lwd = lwd)

    }

  }

}

###################################
## run ca() over parameter array ##
###################################

ca_array <- function(x, parms, delta = 0.1, t_max = 1000, t_min = 500, t_eval = 200, isstable = 0.00001, saveeach = 50, model = musselbed) {
  require(foreach)
  iterations <- expand.grid(parms)
  iterations <- cbind(ID = 1:nrow(iterations),iterations)

  foreach(i = iterations$ID, .combine = rbind) %dopar% {

    source("R/functions.r")

    run <- ca(x, iterations[i,, drop = TRUE], delta = delta, t_max = t_max, t_min = t_min, t_eval = t_eval, isstable = isstable, saveeach = saveeach, model = model)

    return(summary(run)$mean_cover)
  } -> out

  return(cbind(iterations , out) )
}

################################
## get indicators of ca_result ##
################################

summary.ca_result <- function(x) {
  out <- list()
  class(out) <- "ca_summary"
  eval <- x$evaluate[1]:x$evaluate[2]
  out$name <- x$model$name
  out$time <- c(min(x$time), max(x$time))
  out$mean_cover <- colMeans(x$cover[eval,])
  out$sd_cover <- sapply(x$cover[eval,], sd)

  return(out)
}

indicators <- function(x, spatial = TRUE, temporal = TRUE) {
  require(moments)
  i_out <- list()
  class(i_out) <- "ca_indicators"
  i_out$model <- x$model
  eval <- x$evaluate[1]:x$evaluate[2]
  i_out$mean_cover <- colMeans(x$cover[eval,])
  i_out$sd_cover <- sapply(x$cover[eval,], sd)
  i_out$skewness_cover <- sapply(x$cover[eval,], skewness)
  i_out$mean_local <- colMeans(x$local[eval,])
  i_out$sd_local <- sapply(x$local[eval,], sd)
  i_out$skewness_local <- sapply(x$local[eval,], skewness)
  i_out$mean_clustering <- colMeans(x$local[eval,]/x$cover[eval,])
  i_out$sd_clustering <- sapply(x$local[eval,]/x$cover[eval,], sd)
  #i_out$autocorrelation
  i_out$patches <- lapply(x$timeseries, patches)
  #i_out$cpd <- data.frame(n = unique())
  i_out$largest <- sapply(i_out$patches, max)
  #i_out$...

  return(i_out)
}

#########################################
## count patches of a landscape object ##
#########################################

# get patch size and patchsize distribution
patches <- function(x, state = levels(x$cells)[1], cumulative = TRUE) {
  pattern <- x$cells
  pattern <- pattern %in% state
  map <- rep(NA, times = prod(x$dim))
  old <- rep(99, times = prod(x$dim))

  while(!identical(old[pattern], map[pattern])) {
    old <- map
    count = as.integer(1)
    for(i in which(pattern)) {
      neighbors <- map[x_with_border][x_to_evaluate[i]+interact]
      if(all(is.na(neighbors)) ) {
        map[i] <- count
      } else {
        map[i] <- min(neighbors, na.rm = TRUE)
      }
      count <- count +1
    }

  }

  map <- as.factor(map)
  patchvec <- as.vector(sapply(levels(map), function(i) length(which(map == i) ) ))

  out <- vector()
  if(length(patchvec) > 0) out <- sort(patchvec) else out <- NA
  #out <- data.frame(size = unique(out), freq = sapply(unique(out), function(i) length(which(out >= i)) ))
  return(out)

}

###################################
## fit power laws on patch count ##
###################################

fitPL <- function(psd, p_spanning, n = NULL) {

  # code of fitted classes

  n_plants <- sum(psd$size * psd$n)/n

  out <- list()
  out$best <- NA
  out$AIC <- vector("numeric", length = 3)
  out$dAIC <- vector("numeric", length = 3)

  # criteria for vegetated state & desert state

  ##### linear power law model for parameter estimation
  PLlm <- lm(I(log(p)) ~  1 - I(log(size)) , data = psd)

  ###########

  try( {out$TPLdown <- nls(I(log(p)) ~ I( alpha*log(size)-size*Sx ),
                           data = psd,
                           start = list(alpha =  PLlm$coefficients, Sx = 1/200),
                           #algorithm = "port",
                           trace = FALSE
  )}, silent = TRUE
  )

  if(!is.null(out$TPLdown) & !coefficients(out$TPLdown)["Sx"] <= 0 ) {
    out$AIC[1] <- AIC(out$TPLdown)
  } else {
    out$TPLdown <- list(NA)
    out$AIC[1] <- NA
  }

  #####

  try({out$PL <- nls(I(log(p)) ~ alpha * log(size),
                     data = psd,
                     start = list( alpha =  PLlm$coefficients ),
                     trace = FALSE,
                     nls.control(maxiter = 50)
  )}, silent = TRUE
  )

  if(!is.null(out$PL)) {
    out$AIC[2] <- AIC(out$PL)
  } else {
    out$PL  <- list(NA)
    out$AIC[2] <- NA
  }

  ###########

  try({out$TPLup <- nls(I(log(p)) ~  log(b) + log(1+(size^(alpha))/b ) ,
                        data = psd,
                        start = list( alpha =  PLlm$coefficients, b = p_spanning ) ,
                        nls.control(maxiter = 50)
  )}, silent = TRUE
  )

  if(!is.null(out$TPLup)) {
    out$AIC[3] <- AIC(out$TPLup)
  } else {
    #result$fit$summary$TPLup  <- list(NA)
    out$TPLup  <- list(NA)
    out$AIC[3] <- NA
  }

  ###########

  out$dAIC <-   out$AIC -min(out$AIC, na.rm = TRUE)

  out$best <- which.min(out$AIC)+1

  return(out)
}


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(patchwork))
suppressPackageStartupMessages(library(ComplexHeatmap))

source("viz_themes.R")
source("plotting_functions.R")
source("data_functions.R")

output_figure_base <- file.path("figures", "figure3")
extensions <- c(".png", ".pdf")

results_dir <- file.path("../1.Data-exploration/Profiles_level4/")

cp_df <- load_embeddings_data(assay="cellpainting", results_dir = results_dir)
l1000_df <- load_embeddings_data(assay="l1000", results_dir = results_dir)

# Create compounds to highlight
moa_targets_size_values <- c(rep(1, length(moa_targets) -1), 0.1)
names(moa_targets_size_values) <- names(moa_targets)

moa_targets_alpha_values <- c(rep(0.5, length(moa_targets) - 1), 0.1)
names(moa_targets_alpha_values) <- names(moa_targets)

cp_df <- cp_df %>% dplyr::mutate(highlight_moa = tolower(moa))
cp_df$highlight_moa[!(cp_df$highlight_moa %in% names(moa_targets))] <- "other"

l1000_df <- l1000_df %>% dplyr::mutate(highlight_moa = tolower(moa))
l1000_df$highlight_moa[!(l1000_df$highlight_moa %in% names(moa_targets))] <- "other"

cp_umap_gg <- (
    ggplot(data = NULL, aes(x = UMAP_0, y = UMAP_1, color = highlight_moa, size = highlight_moa, alpha = highlight_moa))
    + geom_point(data = cp_df %>% dplyr::filter(highlight_moa == "other"))
    + geom_point(data = cp_df %>% dplyr::filter(dmso_label == "DMSO"), size = 2, color = "red", alpha = 0.1, aes(shape = dmso_label))
    + geom_point(data = cp_df %>% dplyr::filter(highlight_moa != "other"))
    + ggtitle("Cell Painting UMAP")
    + figure_theme
    + scale_size_manual("MOA", labels = moa_targets, values = moa_targets_size_values)
    + scale_alpha_manual("MOA", values = moa_targets_alpha_values)
    + scale_color_manual("MOA", labels = moa_targets, values = moa_colors)
    + scale_shape_manual("Control", values = c("DMSO" = 3))
    + xlab("UMAP X")
    + ylab("UMAP Y")
    + guides(alpha = FALSE, shape = guide_legend(override.aes = list(alpha = 0.8)))
)

cp_umap_gg

l1000_umap_gg <- (
     ggplot(data = NULL, aes(x = UMAP_0, y = UMAP_1, color = highlight_moa, size = highlight_moa, alpha = highlight_moa))
    + geom_point(data = l1000_df %>% dplyr::filter(highlight_moa == "other"))
    + geom_point(data = l1000_df %>% dplyr::filter(dmso_label == "DMSO"), size = 2, color = "red", alpha = 0.1, aes(shape = dmso_label))
    + geom_point(data = l1000_df %>% dplyr::filter(highlight_moa != "other"))
    + ggtitle("L1000 UMAP")
    + figure_theme
    + scale_size_manual("MOA", labels = moa_targets, values = moa_targets_size_values)
    + scale_alpha_manual("MOA", values = moa_targets_alpha_values)
    + scale_color_manual("MOA", labels = moa_targets, values = moa_colors)
    + scale_shape_manual("Control", values = c("DMSO" = 3))
    + xlab("UMAP X")
    + ylab("UMAP Y")
    + guides(alpha = FALSE, shape = guide_legend(override.aes = list(alpha = 0.8)))
)

l1000_umap_gg

# Load level 5 consensus signatures
consensus_dir <- file.path("..", "1.Data-exploration", "Consensus")

cp_df <- load_consensus_signatures(assay = "cellpainting", data_dir = consensus_dir, all_compounds = TRUE)
l1000_df <- load_consensus_signatures(assay = "l1000", data_dir = consensus_dir, all_compounds = TRUE)

# Select DMSO samples and compound treatments with >=10uM
cp_subset_df <- cp_df %>%
    dplyr::filter((Metadata_dose_recode >= 4) | (pert_iname == "dmso"))

cp_corr_df <- cp_subset_df %>%
    dplyr::select(starts_with(c("Cells", "Cytoplasm", "Nuclei"))) %>%
    as.matrix() %>%
    t() %>%
    Hmisc::rcorr(type = "pearson")

cp_corr_df <- cp_corr_df$r

cp_subset_metadata_df <- cp_subset_df %>%
    dplyr::select(Metadata_dose_recode, pert_iname, moa) %>%
    dplyr::mutate(id_number = row_number()) %>%
    dplyr::mutate(dmso_label = "DMSO")

cp_subset_metadata_df$dmso_label[cp_subset_metadata_df$pert_iname != "dmso"] = "compound"

cp_subset_metadata_df <- cp_subset_metadata_df %>% dplyr::mutate(highlight_moa = tolower(moa))
cp_subset_metadata_df$highlight_moa[!(cp_subset_metadata_df$highlight_moa %in% c("proteasome inhibitor"))] <- "other"
cp_subset_metadata_df$highlight_moa[cp_subset_metadata_df$pert_iname == "dmso"] <- "DMSO"

dim(cp_corr_df)

cp_heat_gg <- grid::grid.grabExpr(
    draw(
        Heatmap(
            cp_corr_df,
            col = legend_scale_cols,
            column_title = "Cell Painting consensus signatures",

            top_annotation = HeatmapAnnotation(
                Perturbation = cp_subset_metadata_df$highlight_moa,
                col = list(Perturbation = heatmap_pert_colors),
                annotation_legend_param = list(
                    Perturbation = list(
                        title_gp = gpar(fontsize = lgd_title_fontsize),
                        labels_gp = gpar(fontsize = lgd_label_fontsize),
                        title = ""
                    )
                )
            ),

            heatmap_legend_param = list(
                    title = "Pearson\ncorrelation",
                    color_bar = "continuous",
                    col_fun = legend_scale_cols,
                    title_gp = gpar(fontsize = lgd_title_fontsize),
                    title_position = "topleft",
                    labels_gp = gpar(fontsize = lgd_label_fontsize),
                    legend_height = unit(3, "cm")
            )
        ),
        merge_legend = TRUE
    )
)

l1000_subset_df <- l1000_df %>%
    dplyr::filter((dose >= 4) | (pert_iname == "dmso"))

l1000_corr_df <- l1000_subset_df %>%
    dplyr::select(ends_with("at")) %>%
    as.matrix() %>%
    t() %>%
    Hmisc::rcorr(type = "pearson")

l1000_corr_df <- l1000_corr_df$r

l1000_subset_metadata_df <- l1000_subset_df %>%
    dplyr::select(dose, pert_iname, moa) %>%
    dplyr::mutate(id_number = row_number()) %>%
    dplyr::mutate(dmso_label = "DMSO")

l1000_subset_metadata_df$dmso_label[l1000_subset_metadata_df$pert_iname != "dmso"] = "compound"

l1000_subset_metadata_df <- l1000_subset_metadata_df %>% dplyr::mutate(highlight_moa = tolower(moa))
l1000_subset_metadata_df$highlight_moa[!(l1000_subset_metadata_df$highlight_moa %in% c("proteasome inhibitor"))] <- "other"
l1000_subset_metadata_df$highlight_moa[l1000_subset_metadata_df$pert_iname == "dmso"] <- "DMSO"

dim(l1000_corr_df)

l1000_heat_gg <- grid::grid.grabExpr(
    draw(
        Heatmap(
            l1000_corr_df,
            col = legend_scale_cols,
            column_title = "L1000 consensus signatures",

            top_annotation = HeatmapAnnotation(
                Perturbation = l1000_subset_metadata_df$highlight_moa,
                col = list(Perturbation = heatmap_pert_colors),
                annotation_legend_param = list(
                    Perturbation = list(
                        title_gp = gpar(fontsize = lgd_title_fontsize),
                        labels_gp = gpar(fontsize = lgd_label_fontsize),
                        title = ""
                    )
                )
            ),

            heatmap_legend_param = list(
                title = "Pearson\ncorrelation",
                color_bar = "continuous",
                col_fun = legend_scale_cols,
                title_gp = gpar(fontsize = lgd_title_fontsize),
                title_position = "topleft",
                labels_gp = gpar(fontsize = lgd_label_fontsize),
                legend_height = unit(3, "cm")
            )
        ),
        merge_legend = TRUE
    )
)

heatmap_panels <- cowplot::plot_grid(
    cp_heat_gg,
    l1000_heat_gg,
    ncol = 2,
    labels = c("", "")
)

figure3_gg <- cowplot::plot_grid(
    cowplot::plot_grid(
        cp_umap_gg,
        l1000_umap_gg,
        ncol = 2,
        labels = c("a", "")
    ),
    heatmap_panels,
    rel_heights = c(1, 1),
    ncol = 1,
    labels = c("", "b")
)

figure3_gg

for (extension in extensions) {
    output_file <- paste0(output_figure_base, extension)
    cowplot::save_plot(output_file, figure3_gg, base_width = 12, base_height = 11, dpi = 500)
}


#!/usr/bin/Rscript
library("cgdsr")
library("gplots")
library("RColorBrewer")
# open an instance and test
mycgds <- CGDS("http://www.cbioportal.org/public-portal/")
test(mycgds)
# view and print all cancer studies
studies <- getCancerStudies(mycgds)
# select breast cancer study from query menu name
cancer_study <- "Breast Invasive Carcinoma (TCGA, Provisional)"
study_id <- studies[studies$name==cancer_study, "cancer_study_id"]
# view and print all patient cases
cases <- getCaseLists(mycgds, study_id)
# view and print all genetic profiles
profiles <- getGeneticProfiles(mycgds, study_id)
# select mass spec cases
case_id <- cases[cases$case_list_name=="Protein Quantification (Mass Spec)", "case_list_id"]
profile_id <- profiles[profiles$genetic_profile_name=="Protein levels (mass spectrometry by CPTAC)", "genetic_profile_id"]
# get genetic profile data from PAM50
genes <- c("UBE2T", "BIRC5", "NUF2", "CDC6", "CCNB1", "TYMS", "MYBL2", "CEP55", "MELK", "NDC80", "RRM2", "UBE2C", "CENPF", "PTTG1", "EXO1", "ORC6L", "ANLN", "CCNE1", "CDC20", "MKI67", "KIF2C", "ACTR3B", "MYC", "EGFR", "KRT5", "PHGDH", "CDH3", "MIA", "KRT17", "FOXC1", "SFRP1", "KRT14", "ESR1", "SLC39A6", "BAG1", "MAPT", "PGR", "CXXC5", "MLPH", "BCL2", "MDM2", "NAT1", "FOXA1", "BLVRA", "MMP11", "GPR160", "FGFR4", "GRB7", "TMEM45B", "ERBB2")
ms_data <- getProfileData(mycgds, genes, profile_id, case_id)
# filter out uninformative genes
ms_data[is.na(ms_data)] <- 0
# transpose and convert to matrix
ms_scaled <- as.matrix(t(ms_data))
# fetch TCGA subtypes
# URL: https://tcga-data.nci.nih.gov/docs/publications/brca_2012/BRCA.547.PAM50.SigClust.Subtypes.txt
subtypes <- read.table("BRCA.547.PAM50.SigClust.Subtypes.txt", sep="\t", header=TRUE, colClasses="character")
for (i in 1:nrow(subtypes)) {
    sample <- toString(subtypes[i, "Sample"])
    samp_vec <- strsplit(sample, "-", fixed=TRUE)[[1]]
    samp_end <- substr(samp_vec[4], 1, 2)
    sub_vec <- c(samp_vec[1:3], c(samp_end))
    rename <- paste(sub_vec, collapse=".")
    subtypes[i, "Sample"] <- rename
}
# map samples to subtypes, translate to colors
sample_colors <- rep("", length(colnames(ms_scaled)))
for (i in 1:ncol(ms_scaled)) {
    sample <- colnames(ms_scaled)[i]
    subtype <- subtypes[subtypes["Sample"]==sample, "PAM50"]
    if (subtype=="Basal") {
            sample_colors[i] <- "#ffd400" # yellow
    } else if (subtype=="Her2") {
            sample_colors[i] <- "#441500" # brown
    } else if (subtype=="LumA") {
            sample_colors[i] <- "#00a802" # green
    } else if (subtype=="LumB") {
            sample_colors[i] <- "#ad00aa" # purple
    }
}
# visualize in heatmap
colormap <- colorRampPalette(c("#007fff", "#007fff", "#000000", "#ff0000", "#ff0000"))(25)
png("heatmap.png", height=600, width=610)
heatmap.2(ms_scaled,
    dendrogram="both",
    distfun=function(x) dist(x, method="euclidean"),
    hclustfun=function(x) hclust(x, method="ward.D2"),
    col=colormap,
    trace="none",
    scale="none",
    labCol=rep("", nrow(ms_subset)),
    ColSideColors=sample_colors
)
dev.off()