library(tidyverse)
library(mosaic)
library(cli)

# pipe fn to import surveys and do light tidying
import_survey <- . %>%
  read_csv(na = c("", "NA", "N/A", "N / A"),
    col_types = cols(
      "OptIn Date" = col_date(format = "%d/%m/%Y"),
      HoursDay = col_integer(),
      Rooms = col_integer(),
      Windows = col_integer(),
      "People in House" = col_number(),
      Temperature = col_number(),
      "Temperature (C)" = col_number(),
      "Relative Humidity" = col_number(),
      "Heat Index" = col_number(),
      "Heat Index (C)" = col_number(),
      .default = col_factor(NULL, include_na = FALSE))) %>%
  clean_names() %>%
  slice(-n()) %>%
  select(-starts_with("x1")) %>%
  # normalise col names for weather in some surveys
  rename_with(~ str_replace(.x, "_c$", ""), .cols = ends_with("_c"))

# formatting fns for readable labels

label_risk <- function(x) {
  pct_risk <- scales::percent(abs(x - 1))
  moreless <- ifelse(x > 1, "more", "less")
  paste(pct_risk, moreless, "likely")
}

label_range <- function(x) {
  paste(
    scales::percent(attr(x, "lower.RR")), "to",
    scales::percent(attr(x, "upper.RR")))
}

rr_statsig <- function(x) {
  !between(1, attr(x, "lower.RR"), attr(x, "upper.RR"))
}

risk_subtitle <- function(risk, disadvantage, advantage, bad_outcome,
  statsig = FALSE, rr = FALSE) {

  statsig_emoji <- if_else(rr_statsig(risk), '☑', '❌')
  rr_text <- glue(
    " (RR: {label_risk(attr(risk, 'lower.RR'))}", " to",
    " {label_risk(attr(risk, 'upper.RR'))})")

  glue(
    "{if_else(statsig, statsig_emoji, '')}",
    "Surveyed respondents in Indonesia, Pakistan, India and Cameroon
",
    "{disadvantage} were **{label_risk(attr(risk, 'RR'))}** to {bad_outcome}
",
    "than people {advantage}.",
    "{if_else(rr, rr_text, '')}"
    # " (RR: {label_risk(attr(risk, 'lower.RR'))} to {label_risk(attr(risk, 'upper.RR'))})"
    )
}

rate_diff_plot <- function(df, predictor, outcome, bad_outcome, good_outcome,
  disadvantage, advantage, phrase_disadvantage, phrase_advantage,
  phrase_bad_outcome) {

  # build the contingency table:
  # "people w/ X disadvantage were Y% more/less likely to experience Z bad
  # outcome"
  contingency_table <- data.frame(
    bad_outcome = c(
      df %>% filter({{ bad_outcome }}, {{ advantage }}) %>% pull(n),
      df %>% filter({{ bad_outcome }}, {{ disadvantage }}) %>% pull(n)),
    good_outcome = c(
      df %>% filter({{ good_outcome }}, {{ advantage }}) %>% pull(n),
      df %>% filter({{ good_outcome }}, {{ disadvantage }}) %>% pull(n)))
  rownames(contingency_table) <- c("advantage", "disadvantage")
  print(contingency_table)

  # calculate the relative risk
  risk <- orrr(contingency_table)
  if (between(1, attr(risk, "lower.RR"), attr(risk, "upper.RR"))) {
    cli_bullets(c(
      "x" = "This risk difference is not statistically significant at 95% CI",
      "i" = paste("RR:", attr(risk, "lower.RR"), "to", attr(risk, "upper.RR"))
    ))
  }

  # ceate the plot
  risk_plot <- ggplot(filter(df, {{ bad_outcome }})) +
      aes(y = predictor_prop, x = {{ predictor }}, fill = {{ predictor }}) +
      geom_col() +
      geom_richtext(
        family = "Body 360info",
        aes(label = glue(
          "**{scales::percent(predictor_prop)} of respondents**
",
          "({n} of {predictor_n} surveyed)")),
        colour = "white", fill = NA, label.colour = NA,
        hjust = "inward", nudge_y = -0.01, size = 5.5) +
      scale_y_continuous(labels = scales::label_percent(accuracy = 1)) +
      scale_fill_manual(
        values = c(pal_360[["blue"]], pal_360[["darkblue"]])) +
      coord_flip() +
      labs(subtitle = risk_subtitle(risk, phrase_disadvantage, phrase_advantage,
        phrase_bad_outcome))

    return(risk_plot)
}


### Tool version
#- R v3.3.0: Used to analyze sequencing library results
#- DSS v2.14.0 :Used to call differentially methylated regions
#- DESeq2 v1.12.4: Used to call differentially expressed genes
#- DiffBind v 2.2.12: Used to call differentially accessible regions/peaks

####QC for individual WGBS Replicates####
setwd(<WGBS_folder>) # use the directory where outputs from convert_DSS.py are saved as working directory
# Setting up plotting basics
source("PlotSetUp.r")
## Load methylation profile
s15_R1 <- read.table("15somite_NCC_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
s15_R2 <- read.table("15somite_NCC_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
s24_R1 <- read.table("24hpf_NCC_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
s24_R2 <- read.table("24hpf_NCC_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Mel_R1 <- read.table("Mel_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Mel_R2 <- read.table("Mel_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Iri_R1 <- read.table("Iri_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Iri_R2 <- read.table("Iri_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
## Calculate methylation level at each CpG site, and round the resulting ratio to 2 digits to the right of decimal.
s15_R1$M <- round(s15_R1$X/s15_R1$N, digits = 2)
s15_R2$M <- round(s15_R2$X/s15_R2$N, digits = 2)
s24_R1$M <- round(s24_R1$X/s24_R1$N, digits = 2)
s24_R2$M <- round(s24_R2$X/s24_R2$N, digits = 2)
Mel_R1$M <- round(Mel_R1$X/Mel_R1$N, digits = 2)
Mel_R2$M <- round(Mel_R2$X/Mel_R2$N, digits = 2)
Iri_R1$M <- round(Iri_R1$X/Iri_R1$N, digits = 2)
Iri_R2$M <- round(Iri_R2$X/Iri_R2$N, digits = 2)

# Averge methylation
filter = 5 # Using 5 as cutoff. Only include CpGs with a coverage no less than 5.
## Calculate average methylation for each dataset
me <- data.frame(c("15somite Rep1","15somite Rep2","24hpf Rep1","24hpf Rep2","Mel Rep1","Mel Rep2","Iri Rep1","Iri Rep2"),c(mean(s15_R1[s15_R1$N >= filter,]$M),mean(s15_R2[s15_R2$N >= filter,]$M),mean(s24_R1[s24_R1$N >= filter,]$M),mean(s24_R2[s24_R2$N >= filter,]$M),mean(Mel_R1[Mel_R1$N >= filter,]$M),mean(Mel_R2[Mel_R2$N >= filter,]$M),mean(Iri_R1[Iri_R1$N >= filter,]$M),mean(Iri_R2[Iri_R2$N >= filter,]$M)))
colnames(me) <- c("Type", "Methylation")
me$Type <- factor(me$Type, levels = c("15somite Rep1","15somite Rep2","24hpf Rep1","24hpf Rep2","Mel Rep1","Mel Rep2","Iri Rep1","Iri Rep2"))
p <- ggplot(data=me, aes(x=Type, y=Methylation, fill=Type)) +geom_bar(stat="identity",colour = "black", position=position_dodge())+ggtitle("Average Methylation across samples (coverage filter >=5)")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      labs(x = "Library", y = "Average Methylation")+scale_y_continuous(lim = c(0,1))+scale_fill_manual(values = mypalette)+scale_color_manual(values=mypalette)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+geom_text(data=me,aes(x=Type,y=Methylation+0.03,label=paste(round(Methylation,3)*100,"%",sep ="")),size=8)+ theme(legend.position="none")
p

# Number of CpG covered
## Calculate number of CpGs covered in each sample with coverage cutoff at 0,5,10
co <- data.frame(c(rep("Mel-R1", 3),rep("Mel-R2", 3),rep("Iri-R1", 3),rep("Iri-R2", 3),rep("24hpf-R1",3),rep("24hpf-R2", 3),rep("s15-R1", 3),rep("s15-R2", 3)),c(nrow(Mel_R1[Mel_R1$N>0,]), nrow(Mel_R1[Mel_R1$N>=5,]), nrow(Mel_R1[Mel_R1$N>=10,]),nrow(Mel_R2[Mel_R2$N>0,]), nrow(Mel_R2[Mel_R2$N>=5,]), nrow(Mel_R2[Mel_R2$N>=10,]),nrow(Iri_R1[Iri_R1$N>0,]), nrow(Iri_R1[Iri_R1$N>=5,]), nrow(Iri_R1[Iri_R1$N>=10,]),nrow(Iri_R2[Iri_R2$N>0,]), nrow(Iri_R2[Iri_R2$N>=5,]), nrow(Iri_R2[Iri_R2$N>=10,]),nrow(s24_R1[s24_R1$N>0,]), nrow(s24_R1[s24_R1$N>=5,]), nrow(s24_R1[s24_R1$N>=10,]),nrow(s24_R2[s24_R2$N>0,]), nrow(s24_R2[s24_R2$N>=5,]), nrow(s24_R2[s24_R2$N>=10,]),nrow(s15_R1[s15_R1$N>0,]), nrow(s15_R1[s15_R1$N>=5,]), nrow(s15_R1[s15_R1$N>=10,]),nrow(s15_R2[s15_R2$N>0,]), nrow(s15_R2[s15_R2$N>=5,]), nrow(s15_R2[s15_R2$N>=10,])),c(rep(c(">0",">=5",">=10"),8)))
colnames(co) <- c("Type", "count","Filter")
co$Type <- factor(co$Type, levels = c("s15-R1","s15-R2","24hpf-R1","24hpf-R2","Mel-R1","Mel-R2","Iri-R1","Iri-R2"))
co$Filter <- factor(co$Filter, levels = c(">0",">=5",">=10"))
p <- ggplot(data=co, aes(x=Type, y=count, fill=Filter)) +geom_bar(stat="identity",colour = "black", position=position_dodge())+ggtitle(paste("CpG coverage cutoff",sep =""))+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      labs(x = "Library", y = "CpG count")+scale_fill_manual(values = mypalette2)+scale_color_manual(values=mypalette2)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))
p

# Methylation distribution
## Only include CpGs with a coverage no less than 5.
filter = 5
meth <- data.frame(c(rep("Mel-R1", nrow(Mel_R1[Mel_R1$N >= filter,])),rep("Mel-R2", nrow(Mel_R2[Mel_R2$N >= filter,])),rep("Iri-R1", nrow(Iri_R1[Iri_R1$N >= filter,])),rep("Iri-R2", nrow(Iri_R2[Iri_R2$N >= filter,])),rep("24hpf-R1", nrow(s24_R1[s24_R1$N >= filter,])),rep("24hpf-R2", nrow(s24_R2[s24_R2$N >= filter,])),rep("s15-R1", nrow(s15_R1[s15_R1$N >= filter,])),rep("s15-R2", nrow(s15_R2[s15_R2$N >= filter,]))), c(Mel_R1[Mel_R1$N >= filter,]$M,Mel_R2[Mel_R2$N >= filter,]$M,Iri_R1[Iri_R1$N >= filter,]$M,Iri_R2[Iri_R2$N >= filter,]$M,s24_R1[s24_R1$N >= filter,]$M,s24_R2[s24_R2$N >= filter,]$M,s15_R1[s15_R1$N >= filter,]$M,s15_R2[s15_R2$N >= filter,]$M))
colnames(meth) <- c("Type", "Meth")
a <-ggplot(meth, aes(Meth, fill = Type, colour = Type)) + geom_density(alpha = 0.05, adjust = 3)+ggtitle(paste("Pigment CpG methylation distribution (coverage filter >=",filter,")",sep =""))+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      labs(x = "Coverage", y = "Density")+scale_fill_manual(values = mypalette)+scale_color_manual(values=mypalette)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))
a

# Principal component analysis
## Only include CpGs with a coverage no less than 5.
filter = 5
m<-Reduce(function(x, y) merge(x, y, by=c("chr","pos")), list(Mel_R1[Mel_R1$N >= filter,c(1,2,5)],Mel_R2[Mel_R2$N >= filter,c(1,2,5)],Iri_R1[Iri_R1$N >= filter,c(1,2,5)],Iri_R2[Iri_R2$N >= filter,c(1,2,5)],s24_R1[s24_R1$N >= filter,c(1,2,5)],s24_R2[s24_R2$N >= filter,c(1,2,5)],s15_R1[s15_R1$N >= filter,c(1,2,5)],s15_R2[s15_R2$N >= filter,c(1,2,5)]))
names(m) <- c("chr","start","Mel-R1","Mel-R2","Iri-R1","Iri-R2","24hpf-R1","24hpf-R2","s15-R1","s15-R2")
m.pca <-prcomp(m[,3:10])
summary(m.pca)

#Importance of components:
#                          PC1     PC2    PC3     PC4     PC5     PC6     PC7     PC8
#Standard deviation     0.7544 0.16948 0.1023 0.07458 0.07282 0.06331 0.06319 0.05850
#Proportion of Variance 0.9025 0.04555 0.0166 0.00882 0.00841 0.00636 0.00633 0.00543
#Cumulative Proportion  0.9025 0.94805 0.9647 0.97347 0.98188 0.98824 0.99457 1.00000

# Plot samples on PC axes
loadings <- data.frame(m.pca$rotation, .names = row.names(m.pca$rotation))
a<-ggplot(loadings, aes(x = PC1, y = PC2))+geom_text(data=loadings,
             mapping=aes(x = PC1, y = PC2, label = .names, colour = .names), fontface = "bold", size = 8) +
    labs(x = "PC1 (Variance = 90.3%)", y = "PC2 (Variance = 4.6%)")+ggtitle("CpG Methylation PCA plot of replicates (Cov >=5): PC1 vs PC2")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      scale_fill_manual(values = mypalette)+scale_color_manual(values=mypalette)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+ theme(legend.position="none")
b<-ggplot(loadings, aes(x = PC1, y = PC3))+geom_text(data=loadings,
              mapping=aes(x = PC1, y = PC3, label = .names, colour = .names), fontface = "bold", size = 8) +
    labs(x = "PC1 (Variance = 90.3%)", y = "PC3 (Variance = 1.7%)")+ggtitle("CpG Methylation PCA plot of replicates (Cov >=5): PC1 vs PC3")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      scale_fill_manual(values = mypalette)+scale_color_manual(values=mypalette)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+ theme(legend.position="none")
c<-ggplot(loadings, aes(x = PC2, y = PC3))+geom_text(data=loadings,
              mapping=aes(x = PC2, y = PC3, label = .names, colour = .names), fontface = "bold", size = 8) +
    labs(x = "PC2 (Variance = 4.6%)", y = "PC3 (Variance = 1.7%)")+ggtitle("CpG Methylation PCA plot of replicates (Cov >=5): PC2 vs PC3")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      scale_fill_manual(values = mypalette)+scale_color_manual(values=mypalette)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+ theme(legend.position="none")
multiplot(a,b,c, cols = 3)

# Plot pair-wise correlation between samples
gsc_cor <- cor(m[,3:10])
corrplot(gsc_cor, order="hclust", addrect=4, method ="number")
corrplot.mixed(gsc_cor, order="hclust", addrect=4)
corrplot(gsc_cor, order="hclust", addrect=4)

#### QC for replicate-combined WGBS ####
# Combine replicates
## Combine 15somite NCC Rep1 with Rep2
s15pos_combined <- merge(s15_R1,s15_R2,by=c("chr","pos"), all = TRUE)
s15pos_combined[is.na(s15pos_combined)]<-0
s15pos_combined$N <- s15pos_combined$N.x+s15pos_combined$N.y
s15pos_combined$X <- s15pos_combined$X.x+s15pos_combined$X.y
s15pos_combined <-s15pos_combined[,c(1,2,9,10)]
write.table(s15pos_combined, "15somite_NCC_Combined_DSS.txt",col.names = T,row.names = F, sep = "\t", quote = F)

## Combine 24hpf NCC Rep1 with Rep2
s24pos_combined <- merge(s24_R1,s24_R2,by=c("chr","pos"), all = TRUE)
s24pos_combined[is.na(s24pos_combined)]<-0
s24pos_combined$N <- s24pos_combined$N.x+s24pos_combined$N.y
s24pos_combined$X <- s24pos_combined$X.x+s24pos_combined$X.y
s24pos_combined <-s24pos_combined[,c(1,2,9,10)]
write.table(s24pos_combined, "24hpf_NCC_Combined_DSS.txt",col.names = T,row.names = F, sep = "\t", quote = F)

## Combine Mel Rep1 with Rep2
Mel_combined <- merge(Mel_R1,Mel_R2,by=c("chr","pos"), all = TRUE)
Mel_combined[is.na(Mel_combined)]<-0
Mel_combined$N <- Mel_combined$N.x+Mel_combined$N.y
Mel_combined$X <- Mel_combined$X.x+Mel_combined$X.y
Mel_combined <-Mel_combined[,c(1,2,9,10)]
write.table(Mel_combined, "Mel_Combined_DSS.txt",col.names = T,row.names = F, sep = "\t", quote = F)

## Combine Iri Rep1 with Rep2
Iri_combined <- merge(Iri_R1,Iri_R2,by=c("chr","pos"), all = TRUE)
Iri_combined[is.na(Iri_combined)]<-0
Iri_combined$N <- Iri_combined$N.x+Iri_combined$N.y
Iri_combined$X <- Iri_combined$X.x+Iri_combined$X.y
Iri_combined <-Iri_combined[,c(1,2,9,10)]
write.table(Iri_combined, "Iri_Combined_DSS.txt",col.names = T,row.names = F, sep = "\t", quote = F)

# Calculate methylation level and round that to two digits to the right of decimal
s15pos_combined$M <- round(s15pos_combined$X/s15pos_combined$N, digits = 2)
s24pos_combined$M <- round(s24pos_combined$X/s24pos_combined$N, digits = 2)
Mel_combined$M <- round(Mel_combined$X/Mel_combined$N, digits = 2)
Iri_combined$M <- round(Iri_combined$X/Iri_combined$N, digits = 2)

# Average methylation
## Only include CpGs with a coverage no less than 5.
filter = 5
me <- data.frame(c("15somite","24hpf","Mel","Iri"),c(mean(s15pos_combined[s15pos_combined$N >= filter,]$M),mean(s24pos_combined[s24pos_combined$N >= filter,]$M),mean(Mel_combined[Mel_combined$N >= filter,]$M),mean(Iri_combined[Iri_combined$N >= filter,]$M)))
colnames(me) <- c("Type", "Methylation")
me$Type <- factor(me$Type, levels = c("15somite","24hpf","Mel","Iri"))
# Plot average methylation
p1 <- ggplot(data=me, aes(x=Type, y=Methylation, fill=Type)) +geom_bar(stat="identity",colour = "black", position=position_dodge())+ggtitle("Average Methylation across samples (coverage filter >=5)")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      labs(x = "Library", y = "Average Methylation")+scale_y_continuous(lim = c(0,1))+scale_fill_manual(values = mypalette[c(1,3,5,7)])+scale_color_manual(values=mypalette[c(1,3,5,7)])+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+geom_text(data=me,aes(x=Type,y=Methylation+0.03,label=paste(round(Methylation,3)*100,"%",sep ="")),size=8)+ theme(legend.position="none")
p1

# Number of CpG covered
## Coverage cutoff at 0, 5, 10.
co <- data.frame(c(rep("Mel", 3),rep("Iri", 3),rep("24hpf", 3),rep("s15", 3)),c(nrow(Mel_combined[Mel_combined$N>0,]), nrow(Mel_combined[Mel_combined$N>=5,]), nrow(Mel_combined[Mel_combined$N>=10,]),nrow(Iri_combined[Iri_combined$N>0,]), nrow(Iri_combined[Iri_combined$N>=5,]), nrow(Iri_combined[Iri_combined$N>=10,]),nrow(s24pos_combined[s24pos_combined$N>0,]), nrow(s24pos_combined[s24pos_combined$N>=5,]), nrow(s24pos_combined[s24pos_combined$N>=10,]),nrow(s15pos_combined[s15pos_combined$N>0,]), nrow(s15pos_combined[s15pos_combined$N>=5,]), nrow(s15pos_combined[s15pos_combined$N>=10,])),c(rep(c(">0",">=5",">=10"),4)))
colnames(co) <- c("Type", "count","Filter")
co$Type <- factor(co$Type, levels = c("s15","24hpf","Mel","Iri"))
co$Filter <- factor(co$Filter, levels = c(">0",">=5",">=10"))
# Plot CpG coverage cutoff
p2 <- ggplot(data=co, aes(x=Type, y=count, fill=Filter)) +geom_bar(stat="identity",colour = "black", position=position_dodge())+ggtitle(paste("CpG coverage cutoff",sep =""))+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      labs(x = "Library", y = "CpG count")+scale_fill_manual(values = mypalette2)+scale_color_manual(values=mypalette2)+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))
p2

# Methylation distribution
## Only include CpGs with a coverage no less than 5.
filter = 5
meth <- data.frame(c(rep("Mel", nrow(Mel_combined[Mel_combined$N >= filter,])),rep("Iri", nrow(Iri_combined[Iri_combined$N >= filter,])),rep("24hpf", nrow(s24pos_combined[s24pos_combined$N >= filter,])),rep("s15", nrow(s15pos_combined[s15pos_combined$N >= filter,]))), c(Mel_combined[Mel_combined$N >= filter,]$M,Iri_combined[Iri_combined$N >= filter,]$M,s24pos_combined[s24pos_combined$N >= filter,]$M,s15pos_combined[s15pos_combined$N >= filter,]$M))
colnames(meth) <- c("Type", "Meth")
meth$Type <- factor(meth$Type, levels = c("s15","24hpf","Mel","Iri"))
# Plot CpG methylation distribution
p3 <-ggplot(meth, aes(Meth, fill = Type, colour = Type)) + geom_density(alpha = 0.1, adjust = 4)+ggtitle(paste("Pigment CpG methylation distribution (coverage filter >=",filter,")",sep =""))+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      labs(x = "Coverage", y = "Density")+scale_fill_manual(values = mypalette[c(1,3,5,7)])+scale_color_manual(values=mypalette[c(1,3,5,7)])+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))
p3

# PCA
## Only include CpGs with a coverage no less than 5.
filter = 5
m<-Reduce(function(x, y) merge(x, y, by=c("chr","pos")), list(Mel_combined[Mel_combined$N >= filter,c(1,2,5)],Iri_combined[Iri_combined$N >= filter,c(1,2,5)],s24pos_combined[s24pos_combined$N >= filter,c(1,2,5)],s15pos_combined[s15pos_combined$N >= filter,c(1,2,5)]))
names(m) <- c("chr","start","Mel","Iri","24hpf","s15")
m.pca <-prcomp(m[,3:6])
summary(m.pca)

#Importance of components:
#                          PC1     PC2     PC3     PC4
#Standard deviation     0.5325 0.12170 0.07764 0.06329
#Proportion of Variance 0.9194 0.04802 0.01954 0.01299
#Cumulative Proportion  0.9194 0.96747 0.98701 1.00000

# PCA plot
loadings <- data.frame(m.pca$rotation, .names = row.names(m.pca$rotation))
a<-ggplot(loadings, aes(x = PC1, y = PC2))+geom_text(data=loadings,
             mapping=aes(x = PC1, y = PC2, label = .names, colour = .names), fontface = "bold", size = 8) +
    labs(x = "PC1 (Variance = 91.9%)", y = "PC2 (Variance = 4.8%)")+ggtitle("CpG Methylation PCA plot of replicates (Cov >=5): PC1 vs PC2")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      scale_fill_manual(values = mypalette[c(1,3,5,7)])+scale_color_manual(values=mypalette[c(1,3,5,7)])+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+ theme(legend.position="none")
b<-ggplot(loadings, aes(x = PC1, y = PC3))+geom_text(data=loadings,
              mapping=aes(x = PC1, y = PC3, label = .names, colour = .names), fontface = "bold", size = 8) +
    labs(x = "PC1 (Variance = 91.9%)", y = "PC3 (Variance = 2%)")+ggtitle("CpG Methylation PCA plot of replicates (Cov >=5): PC1 vs PC3")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      scale_fill_manual(values = mypalette[c(1,3,5,7)])+scale_color_manual(values=mypalette[c(1,3,5,7)])+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+ theme(legend.position="none")
c<-ggplot(loadings, aes(x = PC2, y = PC3))+geom_text(data=loadings,
              mapping=aes(x = PC2, y = PC3, label = .names, colour = .names), fontface = "bold", size = 8) +
    labs(x = "PC2 (Variance = 4.8%)", y = "PC3 (Variance = 2%)")+ggtitle("CpG Methylation PCA plot of replicates (Cov >=5): PC2 vs PC3")+theme(plot.title = element_text(hjust = 0.5, face = "bold",size = 16), axis.title=element_text(size=12,face = "bold"),axis.text.x = element_text(face = "bold",size = 12),axis.text.y = element_text(face = "bold",size = 12))+
      scale_fill_manual(values = mypalette[c(1,3,5,7)])+scale_color_manual(values=mypalette[c(1,3,5,7)])+ theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + theme(panel.background = element_rect(fill = 'white',colour = 'black'))+ theme(legend.position="none")
multiplot(a,b,c, cols = 3)
# Sample correlation plot
gsc_cor <- cor(m[,3:6])
corrplot(gsc_cor, order="hclust", addrect=4, method ="number")
corrplot.mixed(gsc_cor, order="hclust", addrect=4)
corrplot(gsc_cor, order="hclust", addrect=4)

#### Differential DNA methylation analysis with DSS####
# Load package for differential analysis
library(DSS)
# Create an object of BSseq class,
BSobj <-makeBSseqData(list(s15pos_combined,s24pos_combined,Mel_combined,Iri_combined), c("s15","24hpf","Mel","Iri"))

# Conduct differential methylation loci (DML) tests between each two samples
dml15v24 <- DMLtest(BSobj, group1 = c("s15"), group2 = c("24hpf"), smoothing = TRUE)
dml24vMel <- DMLtest(BSobj, group1 = c("24hpf"), group2 = c("Mel"), smoothing = TRUE)
dml24vIri <- DMLtest(BSobj, group1 = c("24hpf"), group2 = c("Iri"), smoothing = TRUE)
dmlMelvIri <- DMLtest(BSobj, group1 = c("Mel"), group2 = c("Iri"), smoothing = TRUE)
dml15vMel <- DMLtest(BSobj, group1 = c("s15"), group2 = c("Mel"), smoothing = TRUE)
dml15vIri <- DMLtest(BSobj, group1 = c("s15"), group2 = c("Iri"), smoothing = TRUE)

# get DMRs using delta 0.3 and p value 0.01
DMR15v24_d30_p0.01<- callDMR(dml15v24, delta = 0.30, p.threshold= 0.01)
DMR24vMel_d30_p0.01<- callDMR(dml24vMel, delta = 0.30, p.threshold= 0.01)
DMR24vIri_d30_p0.01<- callDMR(dml24vIri, delta = 0.30, p.threshold= 0.01)
DMRMelvIri_d30_p0.01<- callDMR(dmlMelvIri, delta = 0.30, p.threshold= 0.01)
DMR15vMel_d30_p0.01<- callDMR(dml15vMel, delta = 0.30, p.threshold= 0.01)
DMR15vIri_d30_p0.01<- callDMR(dml15vIri, delta = 0.30, p.threshold= 0.01)

# save called DMRs to files
write.table(DMR15v24_d30_p0.01, "DMR15v24_d30_p0.01_wSMOOTHING.txt", row.names = F, col.names = F, sep = "\t",quote =F)
write.table(DMR24vMel_d30_p0.01, "DMR24vMel_d30_p0.01_wSMOOTHING.txt", row.names = F, col.names = F, sep = "\t",quote =F)
write.table(DMR24vIri_d30_p0.01, "DMR24vIri_d30_p0.01_wSMOOTHING.txt", row.names = F, col.names = F, sep = "\t",quote =F)
write.table(DMRMelvIri_d30_p0.01, "DMRMelvIri_d30_p0.01_wSMOOTHING.txt", row.names = F, col.names = F, sep = "\t",quote =F)
write.table(DMR15vMel_d30_p0.01, "DMR15vMel_d30_p0.01_wSMOOTHING.txt", row.names = F, col.names = F, sep = "\t",quote =F)
write.table(DMR15vIri_d30_p0.01, "DMR15vIri_d30_p0.01_wSMOOTHING.txt", row.names = F, col.names = F, sep = "\t",quote =F)

## Generate WGBS signal bigwig files for Fig.3d and SupFig.7a ##
# Import "DSS.txt" WGBS profile files, which are generated from "WGBS/WGBS_01_preprocessing.sh"
## Notice! Please read the original output files but not use the variable above, otherwize the column information will be different
s15_R1 <- read.table("15somite_NCC_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
s15_R2 <- read.table("15somite_NCC_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
s24_R1 <- read.table("24hpf_NCC_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
s24_R2 <- read.table("24hpf_NCC_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Mel_R1 <- read.table("Mel_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Mel_R2 <- read.table("Mel_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Iri_R1 <- read.table("Iri_Rep1_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)
Iri_R2 <- read.table("Iri_Rep2_DSS.txt",sep = "\t", header = T, stringsAsFactors = F)

# Merge WGBS data from replicated experiment and create an object of BSseq class.
BSobj <-makeBSseqData(list(s15_R1[,c(1:4)],s15_R2[,c(1:4)],s24_R1[,c(1:4)],s24_R2[,c(1:4)],Mel_R1[,c(1:4)],Mel_R2[,c(1:4)],Iri_R1[,c(1:4)],Iri_R2[,c(1:4)]), c("s15_R1","s15_R2","24hpf_R1","24hpf_R2","Mel_R1","Mel_R2","Iri_R1","Iri_R2"))

dml15v24 <- DMLtest(BSobj, group1 = c("s15_R1","s15_R2"), group2 = c("24hpf_R1","24hpf_R2"), smoothing = TRUE)
dml24vMel <- DMLtest(BSobj, group1 = c("24hpf_R1","24hpf_R2"), group2 = c("Mel_R1","Mel_R2"), smoothing = TRUE)
dml24vIri <- DMLtest(BSobj, group1 = c("24hpf_R1","24hpf_R2"), group2 = c("Iri_R1","Iri_R2"), smoothing = TRUE)
dmlMelvIri <- DMLtest(BSobj, group1 = c("Mel_R1","Mel_R2"), group2 = c("Iri_R1","Iri_R2"), smoothing = TRUE)

dml15 <- dml15v24[,c(1,2,3)] #smoothed values
dml24 <- dml24vMel[,c(1,2,3)]
dmlMel <- dml24vMel[,c(1,2,4)]
dmlIri <- dml24vIri[,c(1,2,4)]

# Generate smoothed CpG methylation bed file
dml15$chr <- as.character(dml15$chr)
dml15$end <- as.integer(dml15$pos+1)
write.table(dml15[,c(1,2,4,3)],"SmoothedCpG_Methylation_s15.bed", sep = "\t", col.names = F, row.names =F, quote =F)

dml24$chr <- as.character(dml24$chr)
dml24$end <- as.integer(dml24$pos+1)
write.table(dml24[,c(1,2,4,3)],"SmoothedCpG_Methylation_s24.bed", sep = "\t", col.names = F, row.names =F, quote =F)

dmlMel$chr <- as.character(dmlMel$chr)
dmlMel$end <- as.integer(dmlMel$pos+1)
write.table(dmlMel[,c(1,2,4,3)],"SmoothedCpG_Methylation_Mel.bed", sep = "\t", col.names = F, row.names =F, quote =F)

dmlIri$chr <- as.character(dmlIri$chr)
dmlIri$end <- as.integer(dmlIri$pos+1)
write.table(dmlIri[,c(1,2,4,3)],"SmoothedCpG_Methylation_Iri.bed", sep = "\t", col.names = F, row.names =F, quote =F)

# Convert BedGraph to BigWig using UCSC tool in bash code
system("bedGraphToBigWig SmoothedCpG_Methylation_s15.bed danRer10.chrom.sizes SmoothedCpG_Methylation_s15.bw")
system("bedGraphToBigWig SmoothedCpG_Methylation_s24.bed danRer10.chrom.sizes SmoothedCpG_Methylation_s24.bw")
system("bedGraphToBigWig SmoothedCpG_Methylation_Mel.bed danRer10.chrom.sizes SmoothedCpG_Methylation_Mel.bw")
system("bedGraphToBigWig SmoothedCpG_Methylation_Iri.bed danRer10.chrom.sizes SmoothedCpG_Methylation_Iri.bw")


potFit <- function(data, day = NULL, month = NULL, year = NULL, initialYear = NULL, aggregation = "annual", nYears, nReplicates = 1, numPerYear = switch(aggregation, annual = 365, c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)), threshold = NULL, nCovariates = 0, covariatesByYear = NULL, propMissing = 0, thresholdByYear = NULL, dataScaling = 1, locationModel = NULL, scaleModel = NULL, shapeModel = NULL, returnParams = FALSE, rvInterval = 20, newData = NULL, rvDifference = NULL, multiDayEventHandling = NULL, upper.tail = TRUE, optimMethod = "Nelder-Mead"){

  # data, day, month, and year are 1-d arrays giving the observed values and corresponding day index and month and year for the exceedances; note that the day index is NOT the day of the year but a continuous index with arbitrary starting value for the first day of the first year. 'day' is required when 'multiDayEventHandling' is not NULL; 'month' is required for seasonal or monthly analyses. 'year' is required when using covariates as 'covariatesByYear' are matched to 'data' based on 'year' and 'initialYear'. With replicated data for which multiDayEventHandling is not NULL, these should be ordered in blocks such that all the exceedances for the first replicate are first, then for the second replicate, etc. That will prevent events from different replicates as being treated as the same event in all but unusual circumstances.
  # initialYear indicates the first year of the dataset; in some cases this may not be the minimum value in 'year', as no exceedances may have occurred in the first year; required when covariates are used
  # aggregation should be one of "annual", "seasonal", or "monthly", indicating the stratification. If monthly or seasonal, separate results will be reported for each stratum (i.e., each month or season)
  # nYears is the number of years (blocks) in the full dataset (the dataset before the exceedances are extracted)
    # nReplicates is the number of replicate data sets; primarily for use with model output where you can run the model multiple times to get independent replicates
  # numPerYear is the number of days in each year. For annual analyses this should be about 365 (i.e., the average of the number of days in the years, including leap years). For seasonal and monthly analyses, this should be a 1-d array with 12 values, one for each month; the default values assume leap years are one-quarter of the years in the full dataset, thus 28.25 days per February. Strictly speaking this should not vary by year as the interpretation of return values is affected, though the effect of leap years should be minimal.
  # threshold is a scalar for annual analyses, a 1-d array of 4 values for seasonal (winter, spring, summer, fall thresholds) or a 1-d array of 12 values for monthly analyses (Jan thru Dec thresholds). However, if the thresholds vary by year, threshold should be NULL and thresholdByYear should be specified
  # nCovariates indicates the number of covariates provided through 'covariatesByYear' (note that any subset of the covariates that are provided may be used in the location, scale, and shape modeling, as specified in locationModel, scaleModel, shapeModel)
  # covariatesByYear must be provided if 'nCovariates' is non-zero and must specify the covariate values by year (year x covariate x (optionally) stratum), with the year index varying fastest and stratum index varying slowest
  # thresholdByYear is an (optional) 1-d array of threshold values by year (year x (optionally) stratum), with the year index varying fastest. If the threshold changes over time, this must be included, in which case threshold should be NULL
 # propMissing is either 0 or a 1-d array indicating the proportion of missing values (year x month (for monthly/seasonal analyses)), with the year index varying fastest.  This should include values for all years between the first and last years - years that are entirely missing should have a value of 1
  # dataScaling is a positive-valued scalar used to scale the data values for more robust optimization performance. When multiplied by the values, it should produce values with magnitude around 1
  # locationModel, scaleModel, and shapeModel are vectors indicating the indices of the covariates to be used in the location, scale and shape parameterization. The values are used to select columns from the 'covariatesByYear' array after they are transformed to a multidimensional array with the second dimension indexing the covariates
  # returnParams is a boolean indicating whether to return the fitted parameter values and their standard errors; WARNINGS: (1) Parameter values for models with covariates must be interpreted based on transforming each covariate by subtracting the mean of the yearly values (from 'covariatesByYear') and dividing by the difference of the max and min of the yearly values. This scales the covariates for better numerical performance in the optimization. (2) parameter values for models with covariates for the scale parameter must interpreted based on the log transformation of the scale parameter
  # rvInterval: the timespan for which return values should be calculated. For example a rvInterval of 20 years corresponds to the value of an event that occurs with probability 1/20 in any year and therefore occurs on average every 20 years
  # newData should be a 1-d array of the same form as 'covariatesByYear', providing covariate values (observation x covariate) for which return values are desired. Values will be calculated for each stratum.
  # rvDifference should be a 1-d array of covariate values for two sets of covariates for which the difference in return values is desired (set x covariate), with the set index varying fastest; i.e. provide the first covariate for each set, then the second covariate for each set, etc. The difference is computed as the return value for the second set minus the return value for the first set. Values will be calculated for each stratum.
  # multiDayEventHandling should be NULL, "noruns", or a number. If 'noruns' is specified, only the maximum (or minimum if upper.tail = FALSE) value within a set of exceedances occuring on consecutive days is included. If a number, this should indicate the block size within which to allow only the largest (or smallest if upper.tail = FALSE) value
  # upper.tail indicates whether one is working with exceedances over a high threshold (TRUE) or exceedances under a low threshold (FALSE); in the latter case, the function works with the negative of the values and the threshold, changing the sign of the resulting location parameters
  # optimMethod is passed to the R's optimization routine optim() and should specify one of options for the 'method' argument of optim().  It is advisable to try multiple methods: Nelder-Mead and BFGS are commonly used methods; Nelder-Mead uses only function evaluations, while BFGS is a quasi-Newton method that also uses derivative information.

  # may want to have thresholdByMonth for cases where threshold varies only by stratum and not by observation

  if(!upper.tail){  # modeling exceedances below a threshold is equivalent to modeling the negative of exceedances above the negative of the threshold. Location parameter values will be the negative of those on the original scale, but are corrected before returning parameter values to the user.
    data = -data
    if(!is.null(threshold))
      threshold = -threshold
    if(!is.null(thresholdByYear))
      thresholdByYear = -thresholdByYear
  }

  n <- length(data)
  if(!is.null(day) && length(day) != n)
    stop("'day' must be of same length as 'data', with one value per observation")
  if(!is.null(month) && length(month) != n)
    stop("'month' must be of same length as 'data', with one value per observation")
  if(!is.null(year) && length(year) != n)
    stop("'year' must be of same length as 'data', with one value per observation")
  if(!is.null(threshold))
    if((aggregation == "annual" && length(threshold) != 1) ||
       (aggregation == "seasonal" && length(threshold) != 4) ||
       (aggregation == "monthly" && length(threshold) != 12))
      stop("'threshold' must contain one value for annual, four values for seasonal, or 12 values for montly analysis")

  if(!is.null(multiDayEventHandling) && is.null(day))
    stop("'day' is required when multi-day events are excluded")
  if(aggregation != "annual" && is.null(month))
    stop("'month' is required when monthly or seasonal analyses are requested")

  # determine strata-specific information
  nStrata = 1
  if(aggregation == "monthly"){
    nStrata = 12
    if(length(propMissing) > 1 && !(length(propMissing) %in% (nYears*c(1,12))))
      stop("'propMissing' should be a scalar, a vector of one value per year, or a vector with values for each month and year")
    propMissing = array(propMissing, c(nYears, 12))
    if(length(numPerYear) != 12)
      stop("'numPerYear' should have one value for each month")
  }
  if(aggregation == "seasonal"){
    nStrata = 4
    if(length(propMissing) > 1 && !(length(propMissing) %in% (nYears*c(1,12))))
      stop("'propMissing' should be a scalar, a vector of one value per year, or a vector with values for each month and year")
    propMissing = array(propMissing, c(nYears, 12))
    if(length(numPerYear) != 12)
      stop("'numPerYear' should have one value for each month")
  }
  if(aggregation == "annual"){
    propMissing = array(propMissing, c(nYears, 1))
    if(length(numPerYear) != 1)
      stop("'numPerYear' should be a single value for annual analyses")
  }

  data <- data * dataScaling
  if(!is.null(threshold))
    threshold = threshold * dataScaling
  if(!is.null(thresholdByYear))
    thresholdByYear = thresholdByYear * dataScaling

  # check dimensionality of input arrays
  if(!is.null(covariatesByYear) && !(length(covariatesByYear) %in% (nYears*nCovariates*c(1,nStrata))))
    stop("'covariatesByYear must have covariate values for each covariate for each year (and optionally stratum)")
  if(!is.null(thresholdByYear) && !(length(thresholdByYear) %in% (nYears*c(1,nStrata))))
    stop("'thresholdByYear must have values for each year (and optionally stratum)")
  if(!is.null(newData) && length(newData) %% nCovariates != 0)
    stop("length of newData should be a multiple of 'nCovariates'")
  if(!is.null(rvDifference) && length(rvDifference) != 2*nCovariates)
    stop("length of rvDifference is not equal to two times the number of covariates")

  # manipulate input arrays to have appropriate number of dimensions and get covariate vals for obs
  if(!is.null(covariatesByYear)) {
    covariatesByYear <- array(covariatesByYear, c(nYears, nCovariates, nStrata))
    if(aggregation == "annual")
      covariates <- matrix(covariatesByYear[(year - initialYear + 1), , 1], ncol = nCovariates)
    if(aggregation == "seasonal"){ # move December to next year
      monthToSeason <- c(1,1,2,2,2,3,3,3,4,4,4,1)
      lastDec = year == (initialYear + nYears - 1) & month == 12
      data = data[!lastDec]
      n <- length(data)
      month = month[!lastDec]
      year = year[!lastDec]
      day = day[!lastDec]
      year[month == 12] = year[month == 12] + 1
      covariates <- matrix(covariatesByYear[cbind(
                                       rep((year - initialYear + 1), nCovariates),
                                       rep(1:nCovariates, each = n),
                                       rep(monthToSeason[month], nCovariates))],
                           ncol = nCovariates)
    }
    if(aggregation == "monthly")
      covariates <- matrix(covariatesByYear[cbind(
                                       rep((year - initialYear + 1), nCovariates),
                                       rep(1:nCovariates, each = n),
                                       rep(month, nCovariates))],
                           ncol = nCovariates)
  } else{
    covariates <- NULL
  }
  if(!is.null(thresholdByYear))
    thresholdByYear <- array(thresholdByYear, c(nYears, nStrata))
  if(!is.null(newData)){
    m = length(newData)/nCovariates
    newData <- array(newData, c(m, nCovariates))
  }
  if(!is.null(rvDifference))
    rvDifference <- array(rvDifference, c(2, nCovariates))

  if(nCovariates && is.null(covariatesByYear))
    stop("'covariatesByYear' is required for nonstationary modeling")

  if(is.null(rvInterval) && (!is.null(newData) || !is.null(rvDifference)))
    stop("'rvInterval' must be specified")

  # seasonalize
  if(aggregation == 'seasonal' && !is.null(covariatesByYear)){
    seasons <- c('DJF', 'MAM', 'JJA', 'SON')
    dec = 12
    months = list(DJF = c(1,2,12), MAM = 3:5, JJA = 6:8, SON = 9:11)
    # put propMissing for first year based on missing Dec and shift other years
    propMissing[2:nYears, dec] = propMissing[1:(nYears-1), dec]
    propMissing[1, dec] = 1
    season = rep(1, n)
    for(seas in 2:4)
      season[month %in% months[[seas]]] = seas

    tmp = array(0, c(nYears, 4))
    for(seas in 1:4){
      wgts = numPerYear
      wgts[-months[[seas]]] = 0
      tmp[ , seas] = (propMissing%*%wgts) / sum(wgts)
    }
    propMissing = tmp
    numPerYear = c(sum(numPerYear[months[[1]]]), sum(numPerYear[months[[2]]]), sum(numPerYear[months[[3]]]), sum(numPerYear[months[[4]]]))
  }

  # remove multi-day events
  if(is.character(multiDayEventHandling) && multiDayEventHandling == "noruns")
    data = removeRuns(data, day)
  if(is.numeric(multiDayEventHandling))
    data = withinBlockScreen(data, day, blockLen = multiDayEventHandling)

  if(!is.null(month))
    month = month[!is.na(data)]
  if(!is.null(year))
    year = year[!is.na(data)]

  if(aggregation == "seasonal")
    season = season[!is.na(data)]

  if(nCovariates)
    covariates <- covariates[!is.na(data), , drop = FALSE]
  data = data[!is.na(data)]

  nParam <- 3 + length(locationModel) + length(scaleModel) + length(shapeModel)

  if(!is.null(locationModel) && !validateIndices(locationModel, nCovariates))
    stop("'locationModel' values do not provide legitimate indices of covariates")

  if(!is.null(scaleModel) && !validateIndices(scaleModel, nCovariates))
    stop("'scaleModel' values do not provide legitimate indices of covariates")

  if(!is.null(shapeModel) && !validateIndices(shapeModel, nCovariates))
    stop("'shapeModel' values do not provide legitimate indices of covariates")

  if(nCovariates){
    for(p in 1:nCovariates){ # shift and scale to (-.5, .5) for better numeric properties in estimation
      if(!is.null(newData))
        newData[ , p] <- normalize(newData[, p], mean(covariatesByYear[ , p, ]), min(covariatesByYear[ , p, ]), max(covariatesByYear[ , p, ]))
      if(!is.null(rvDifference))
        rvDifference[ , p] <- normalize(rvDifference[, p], mean(covariatesByYear[ , p, ]), min(covariatesByYear[ , p, ]), max(covariatesByYear[ , p, ]))
      covariates[ , p] <- normalize(covariates[ , p], mean(covariatesByYear[ , p, ]), min(covariatesByYear[ , p, ]), max(covariatesByYear[ , p, ]))
      covariatesByYear[ , p, ] <- normalize(covariatesByYear[ , p, ])
    }
  }
  # do I need to save the original covariates or at least mean and divisor of normalization?

  mulink <- siglink <- shlink <- identity
  link = "c(identity, identity, identity)"
  if(!is.null(scaleModel)){
    siglink <- exp
    link = "c(identity, exp, identity)"
  }

  NAlist <- list(mle = rep(NA, nParam), se = rep(NA, nParam), cov = matrix(NA, nParam, nParam)) #  rep(NA, nParam)

  pot.fit.wrap = function(xdat, threshold, npy, ydat, ydatByYear, propMissing, nYears, thresholdByYear){
    fit = try(pp.fit2(xdat, threshold = threshold, npy = npy,  ydat = ydat, mul = locationModel, sigl = scaleModel, shl = shapeModel, mulink = mulink, siglink = siglink, shlink = shlink, show = FALSE, exceedancesOnly = TRUE, nBlocks = nYears, propMissingByBlock = propMissing, ydatByBlock = ydatByYear, thresholdByBlock = thresholdByYear))
    if(!is(fit, 'try-error') && !fit$flag && !fit$conv){
      return(fit[c("mle", "se", "cov")])
    } else{
      return(NAlist)
    }
  }

  mle <- se <- array(NA, c(nParam, nStrata))
  covmat <- array(NA, c(nParam, nParam, nStrata))

  for(j in 1:nStrata){
    tmpdata = data
    tmpcovariates = covariates
    tmpcovariatesByYear = covariatesByYear
    if(nCovariates)
      tmpcovariatesByYear = matrix(covariatesByYear[ , , j], nc = nCovariates)
    if(aggregation == "monthly"){
      tmpdata = data[month == j]
      if(nCovariates){
        tmpcovariates = covariates[month == j, , drop = FALSE]
      }
    }
    if(aggregation == "seasonal"){
      tmpdata = data[season == j]
      if(nCovariates){
        tmpcovariates = covariates[season == j, , drop = FALSE]
      }
    }
    if(nCovariates && nReplicates > 1)
      tmpcovariatesByYear = matrix(rep(c(t(tmpcovariatesByYear)), nReplicates), ncol = nCovariates, byrow = TRUE)

    output = pot.fit.wrap(tmpdata, threshold[j], numPerYear[j], tmpcovariates, tmpcovariatesByYear, rep(propMissing[ , j], nReplicates), nYears*nReplicates, rep(thresholdByYear[ , j], nReplicates))
    mle[ , j] <- output$mle
    if(!upper.tail)  # location parameters for lower tail are the negative of those computed based on negative of data values
      mle[1:(length(locationModel)+1), ] <- -mle[1:(length(locationModel)+1), ]
    se[ , j] <- output$se
    covmat[ , , j] <- output$cov
  }

  results <- list()
  numLocScaleParams = 2 + length(locationModel) + length(scaleModel)
  # rescale parameters so on scale of original data
  mle[1:numLocScaleParams, ] <- mle[1:numLocScaleParams, ] / dataScaling
  se[1:numLocScaleParams, ] <- se[1:numLocScaleParams, ] / dataScaling

  if(returnParams){
    if(aggregation == 'seasonal')
      attributes(mle)$dimnames[[2]] <- attributes(se)$dimnames[[2]] <- seasons
    results$mle <- mle[ , , drop = TRUE]
    results$se.mle <- se[ , , drop = TRUE]
  }

  # get return values for newData observations
  # perhaps make this more efficient with an apply, but it needs to pass in both mle and cov
  if(!is.null(newData)){
    rv <- array(0, c(m, nStrata, 2))
    for(i in 1:m)
      for(j in 1:nStrata){
        fit = list(mle = mle[ , j], cov = covmat[ , , j], model = list(locationModel, scaleModel, shapeModel), link = link)
        class(fit) = "pp.fit"
        rv[i, j, ] <- returnValue(fit, rvInterval, newData[i, ])
      }
    if(aggregation == "seasonal")
      attributes(rv)$dimnames[[2]] <- seasons
    results$returnValue <- rv[ , , 1]
    results$se.returnValue <- rv[ , , 2]
  }

  # get stationary return value
  if(is.null(newData) && !is.null(rvInterval) && is.null(covariates)){
    rv <- array(0, c(nStrata, 2))
    for(j in 1:nStrata){
      fit = list(mle = mle[ , j], cov = covmat[ , , j], model = list(locationModel, scaleModel, shapeModel), link = link)
      class(fit) = "pp.fit"
      rv[j, ] <- returnValue(fit, rvInterval, rvCovariates = NULL)
    }
    if(aggregation == "seasonal")
      attributes(rv)$dimnames[[1]] <- seasons
    results$returnValue <- rv[ , 1]
    results$se.returnValue <- rv[ , 2]
  }

  # get return value difference
  if(!is.null(rvDifference)){
    rvDiff <- array(0, c(nStrata, 2))
    for(j in 1:nStrata){
        fit = list(mle = mle[ , j], cov = covmat[ , , j], model = list(locationModel, scaleModel, shapeModel), link = link)
        class(fit) = "pp.fit"
        rvDiff[j, ] <- returnValueDiff(fit, rvInterval, rvDifference)
      }
    if(aggregation == "seasonal")
      attributes(rvDiff)$dimnames[[1]] <- seasons
    results$returnValueDiff <- rvDiff[ , 1]
    results$se.returnValueDiff <- rvDiff[ , 2]
  }

  return(results)
}


cat('\n---Polygenic Burden (PB) - Large Effect Variant (LEV) SCAN (PB-LEV-SCAN)---\n')
cat('---version 1.0---\n')

library('ggplot2')
library("optparse")

options(scipen = 10)

option_list = list(

  #path
  make_option("--plink_path", action="store", default="plink", type='character',
              help="Path to plink1.9 [%default]"),
  make_option("--plink2_path", action="store", default="plink2", type='character',
              help="Path to plink2 [%default]"),
  make_option("--maf_distribution_path", action="store", default=NA, type='character',
              help="Path to the maf distribution file (estimated from empirical data) [required]"),
  make_option("--ldsc_path", action="store", default=NA, type='character',
              help="Path to the ldsc file (estimated from empirical data) [required]"),
  make_option("--tmp_folder", action="store", default=NA, type='character',
              help="tmp folder for intermediate files [required]. Please vary the tmp folder names (e.g., tmp_1; tmp_2; tmp_3; etc.) when you have multiple jobs to run in parallel. Otherwise it will overwrite each other"),
  make_option("--out_folder", action="store", default=NA, type='character',
              help="path for output folder [required]"),
  make_option("--out_prefix", action="store", default=NA, type='character',
              help="prefix for output [required]"),

  #model
  make_option("--genetic_architecture", action="store", default='polygenic', type='character',
              help="polygenic=polygenic architecture \nNegativeSelection=with negative selection \nLDAK=LD-adjusted kinship"),
  make_option("--disease_model", action="store", default='LTM', type='character',
              help="LTM=liability threshold model\nlogit=logit model"),

  #parameter
  make_option("--n_simu", action="store", default=500, type='integer',
              help="simulation times"),
  make_option("--sample_size", action="store", default=10000, type='integer',
              help="number of sample size"),
  make_option("--h2_PB", action="store", default=0.3, type='double',
              help="heritability due to common variant based polygenicity"),
  make_option("--h2_LEV", action="store", default=NA, type='double',
              help="heritability due to large effect variant(s). Use h2_LEV or OR_LEV. If both h2_LEV and OR_LEV are provided, OR_LEV will be ignored"),
  make_option("--OR_LEV", action="store", default=NA, type='double',
              help="OR of large effect variant. Use h2_LEV or OR_LEV. If both h2_LEV and OR_LEV are provided, OR_LEV will be ignored"),
  make_option("--freq_LEV", action="store", default=0.01, type='double',
              help="allele frequency of large effect variant(s)"),
  make_option("--prevalence", action="store", default=0.01, type='double',
              help="disease prevalence in population"),
  make_option("--pi0", action="store", default=0, type='double',
              help="proportion of non-causal common, small effect variants"),
  make_option("--seed", action="store", default=1, type='integer',
              help="seed for sampling"),

  #other options
  make_option("--generate_a_figure", action="store_true", default=TRUE,
              help="Generate a figure comparsion the number of LEV-carriers among patients with different polygenic burdens [default: %default]"),
  make_option("--clean_tmp", action="store_true", default=TRUE,
              help="Delete the tmp folder and all temporary files [default: %default]")

)

opt = parse_args(OptionParser(option_list=option_list))

#input
plink_path = opt$plink_path
plink2_path = opt$plink2_path
maf_distribution_path = opt$maf_distribution_path
ldsc_path = opt$ldsc_path
tmp_folder = opt$tmp_folder
out_folder = opt$out_folder
out_prefix = opt$out_prefix

genetic_architecture = opt$genetic_architecture
disease_model = opt$disease_model

N_simulation = opt$n_simu
N_samples = opt$sample_size
h2_PB = opt$h2_PB
freq_LEV = opt$freq_LEV
k = opt$prevalence
seed = opt$seed
pi0 = opt$pi0
generate_a_figure = opt$generate_a_figure
clean_tmp = opt$clean_tmp

if(is.na(opt$h2_LEV) & is.na(opt$OR_LEV)){
  h2_LEV = 0.01
  beta_LEV = sqrt(h2_LEV/2/freq_LEV/(1-freq_LEV))
}else if(!is.na(opt$h2_LEV) & is.na(opt$OR_LEV)){
  h2_LEV = opt$h2_LEV
  beta_LEV = sqrt(h2_LEV/2/freq_LEV/(1-freq_LEV))
}else if(is.na(opt$h2_LEV) & !is.na(opt$OR_LEV)){
  #r2=var(ln(OR)*G)/(var(ln(OR)*G)+3.29)  ref Hong S. Lee, Gen Epi
  h2_LEV = (log(opt$OR_LEV,2.718)^2 * 2 * freq_LEV * (1-freq_LEV)) / (log(opt$OR_LEV,2.718)^2 * 2 * freq_LEV * (1-freq_LEV) + 3.29)
  beta_LEV = sqrt(h2_LEV/2/freq_LEV/(1-freq_LEV))
}else if(!is.na(opt$h2_LEV) & !is.na(opt$OR_LEV)){
  h2_LEV = opt$h2_LEV
  beta_LEV = sqrt(h2_LEV/2/freq_LEV/(1-freq_LEV))
  warning('Please only provide h2_LEV or OR_LEV, or OR_LEV will be ignored')
}

#load empirical ldsc
cat('INFO loading ldsc from empirical dataset\n')
ldsc_raw<-read.table(ldsc_path,header = T,stringsAsFactors = F)

#make tmp dir
if(!dir.exists(tmp_folder)){dir.create(tmp_folder)}
#make output dir
if(!dir.exists(out_folder)){dir.create(out_folder)}

#-----------------------------------------------

#df for simulation results
simu<-data.frame(n_simu=seq(1,N_simulation),wilcox_p=NA,p1=NA,p2=NA,p3=NA,p4=NA,p5=NA,p6=NA,p7=NA,p8=NA,p9=NA,p10=NA)

cat('INFO start simulation\n')

for (i in 1:N_simulation){
  #if(i %in% c(1,seq(1,1000)*10+1)){
    cat(paste0('INFO       ',i,' / ',N_simulation,' \n'))
  #}

  ###------simulate genotype for common causal variants------

  #use plink to simulate genotype data. Note: N_sample/2 doesn't means half cases and half control. See plink website for details.
  cmd=paste0('plink --simulate ',maf_distribution_path,' --simulate-ncases ',N_samples/2,' --simulate-ncontrols ',N_samples/2,' --seed ',seed,' --silent --make-bed --out ',tmp_folder,'/tmp_geno; plink --bfile ',tmp_folder,'/tmp_geno --silent --freq --out ',tmp_folder,'/tmp_freq')
  system(cmd,wait = T,ignore.stdout=T,ignore.stderr=T)

  #10k samples ~30 secs
  #100k samples ~3 mins

  #df of effect size for small effect common variants
  df<-read.table(paste0(tmp_folder,'/tmp_freq.frq'),stringsAsFactors = F,header = T)
  N_causal_SNPs=nrow(df)

  #ldsc, matching the correlation between ldsc and MAF from empirical data
  df$id=seq(1,nrow(df))
  df<-df[order(df$MAF),]
  ldsc<-ldsc_raw[sample(nrow(ldsc_raw),nrow(df),replace = T),]
  ldsc<-ldsc[order(ldsc$MAF),]
  df$ldsc=ldsc$ldscore

  # a Infinitesimal architecture
  #   beta_poly~(0,h2_PB/N_caucal_SNPs)
  if(genetic_architecture=='polygenic'){
    set.seed(i)
    df$effect=(1-pi0)*rnorm(N_causal_SNPs,0,(h2_PB/N_causal_SNPs)^0.5)

    # b Negative selection
    #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)))
  }else if(genetic_architecture=='NegativeSelection'){
    set.seed(i)
    df$effect=df[,'effect']<-sapply(df$MAF,function(f) rnorm(1,mean=0,sd=((f*(1-f))^0.63)^0.5))
    #find k constant
    k_constant=(h2_PB/N_causal_SNPs/var(df[,'effect']))
    #multiply by k constant
    df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)

    # c LD-adjusted kinship
    #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)*(1/(1+ldsc))))
  }else if(genetic_architecture=='LDAK'){
    set.seed(i)
    df$effect=df[,'effect']<-mapply(function(f,ld) rnorm(1,mean=0,sd=(((f*(1-f))^0.75)*1/(1+ld))^0.5), df$MAF, df$ldsc)
    #find k constant
    k_constant=(h2_PB/N_causal_SNPs/var(df[,'effect']))
    #multiply by k constant
    df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)
  }

  #write weight file
  write.table(df[,c('SNP','A1','effect')],paste0(tmp_folder,'/tmp.weight'),row.names = F,col.names = F,sep='\t',quote = F)

  #use plink to calculate the PB (polygenic burden, i.e.,PRS of common variants)
  cmd=paste0('plink2 --bfile ',tmp_folder,'/tmp_geno --score ',tmp_folder,'/tmp.weight variance-standardize  --out ',tmp_folder,'/tmp.score')
  system(cmd,wait = T,ignore.stdout=T,ignore.stderr=T)

  #load PB results (A)
  PB=read.table(paste0(tmp_folder,'/tmp.score.sscore'),stringsAsFactors = F)
  PB$IID=PB$V1
  PB$A=PB$V6*2*N_causal_SNPs
  PB<-PB[,c('IID','A')]

  ###------simulate genotype for the large effect variants (LEV)------
  set.seed(seed+10)
  R_raw_genotype = rbinom(n = N_samples, size = 2, prob = freq_LEV)
  #genetic risk due to LEV (R)
  R<- R_raw_genotype * beta_LEV

  #merge A and R
  LEV<-data.frame(IID=PB$IID,R=R,R_raw_genotype=R_raw_genotype)
  combined<-merge(PB,LEV,by='IID')

  #x=A+R  total genetic risk
  combined$x=combined$A+combined$R

  #h2_e  error/environment
  h2_e=max(1-h2_PB-var(combined$R),0)

  # #
  # print(h2_PB)
  # print(h2_e)
  # print(sum(combined$x))
  # print(nrow(combined))

  #disease liability (L)  L=A+R+e
  set.seed(i+100)
  combined$L=combined$x+rnorm(nrow(combined),0,h2_e^0.5)

  #threshold for liability-threshold model (LTM)
  t=quantile(combined$L,1-k)[[1]]

  #disease probability
  combined$prob=pnorm(-(t-combined$x)/h2_e^0.5)

  #generate binary trait
  if(disease_model=='LTM'){
    combined$y_binary<-ifelse(combined$L>t,1,0)
  }else if (disease_model=='logit'){
    set.seed(i*10)
    combined$y_binary<-sapply(combined$prob,function(x) rbinom(1,1,x))
  }else{
    stop('unknown disease model, please provide "LTM" or "logit"')
  }

  #LEV carrier
  combined$carrier<-ifelse(combined$R_raw_genotype!=0,1,0)

  #check the 2 by 2 table
  table_check<-table(combined$y_binary,combined$carrier)

  #simulated cases (patients)
  cases<-combined[combined$y_binary==1,]

  #test PB-LEV in cases only
  if(length(which(combined$y_binary==1 & combined$carrier==1))>0 & length(which(combined$y_binary==1 & combined$carrier==0))>0){
    #test PB-LEV correlation, one side
    ans_inverse<-wilcox.test(cases[cases$carrier==1,'A'],cases[cases$carrier==0,'A'],alternative = c("less"))
    simu[i,'wilcox_p']<-ans_inverse$p.value
  }else{
    #not enough samples in the 2 by 2 table
    simu[i,'wilcox_p']<-1
  }

  #group cases in to 10 equally sized bins based on their PB risk
  cases$group <- as.numeric(cut(cases$A, 10))

  #pool cases from each simulation
  if(i==1){
    cases_pool=cases
  }else{
    cases_pool=rbind(cases_pool,cases)
  }

  #number of LEV-carriers for each bin
  tmp_c<-data.frame(Group.1=seq(1,10))
  tmp_c<-merge(tmp_c,as.data.frame(aggregate(cases$carrier,list(cases$group),sum)),all=T)
  #number of samples in each bin
  tmp_n<-as.data.frame(table(cases$group))
  #merge
  tmp_c<-merge(tmp_c,tmp_n,by=1,all=T)
  tmp_c[is.na(tmp_c)]<-0
  colnames(tmp_c)<-c('group','x','n')  #'group'; # of carriers; # of cases
  #number of LEV-carriers per 1000 cases
  simu[i,3:12]<-round(tmp_c$x/tmp_c$n*1000,2)

}

cat(paste0('INFO simulation finished\n'))

cat(paste0('INFO saving results\n'))

#save cases results
write.table(cases_pool,paste0(out_folder,'/',out_prefix,'_cases.txt'),quote = F,sep='\t',row.names = F)

#save simu results
write.table(simu,paste0(out_folder,'/',out_prefix,'_simu.txt'),quote = F,sep='\t',row.names = F)

#result df
output<-data.frame(genetic_architecture=genetic_architecture,
                   disease_model=disease_model,
                   h2_PB=h2_PB,
                   OR_LEV=2.718^beta_LEV,
                   freq_LEV=freq_LEV,
                   prevalence=k,
                   pi0=pi0,
                   N_samples=N_samples,
                   N_simulation=N_simulation,
                   seed=seed,
                   utility=length(which(simu[,'wilcox_p']<0.05))/nrow(simu)
)

#mean and sd for the number of LEV-carriers per 1000 cases
for(j in 1:10){
  output[1,paste0('mean_p',j)]<-mean(simu[,paste0('p',j)],na.rm = T)
  output[1,paste0('sd_p',j)]<-sd(simu[,paste0('p',j)],na.rm = T)
}

#save result
write.table(output,paste0(out_folder,'/',out_prefix,'.txt'),quote = F,sep='\t',row.names = F)

#---figure generator (LEV_carriers_per_1000_cases_comparison)---

if(generate_a_figure){

  cat(paste0('INFO figure generating\n'))

  #get the x-coordinates for each cSEV-PB bins
  p_tmp<-ggplot(data=cases_pool,aes(x=A))+  #use the A from last simulation
    geom_histogram(bins = 10)

  #df for # carriers in each bin
  carrier_info<-data.frame(pos=ggplot_build(p_tmp)$data[[1]]$x,
                           mean=as.numeric(output[1,paste0('mean_p',seq(1,10))]),
                           sd=as.numeric(output[1,paste0('sd_p',seq(1,10))]))
  carrier_info$lower=carrier_info$mean-carrier_info$sd
  carrier_info$upper=carrier_info$mean+carrier_info$sd
  carrier_info$lower=ifelse(carrier_info$lower<0,0,carrier_info$lower)
  carrier_info$upper=ifelse(carrier_info$upper>1000,1000,carrier_info$upper)

  #find ylim (the highest density)
  y_density_max<-max(ggplot_build(p_tmp)$data[[1]]$density)*1.2

  #coeff for adjusting dual y-axis
  coeff=max(carrier_info$upper,na.rm = T)/y_density_max

  #plot
  p<-ggplot(data=carrier_info)+

    #cSEV-PB distribution
    geom_histogram(data=cases_pool,aes(x=A,y=..density..), colour="black", fill="white",bins=10)+
    geom_density(data=cases_pool,aes(x=A),alpha=.2, fill="#FF6666",bw=0.2)+

    #mean of 'number of LEV-carriers per 1000 cases'
    geom_point(aes(x=carrier_info$pos,y=carrier_info$mean/coeff),color='dodgerblue3')+

    #error bar for 'number of LEV-carriers per 1000 cases' (+- 1sd)
    geom_pointrange(aes(x=carrier_info$pos,y=carrier_info$mean/coeff,ymin=carrier_info$lower/coeff, ymax=carrier_info$upper/coeff),color='dodgerblue3')+

    scale_y_continuous(
      # Features of the first axis
      name = "density",
      #limits for density
      limits = c(0,y_density_max),
      # Add a second axis and specify its features
      sec.axis = sec_axis(~.*coeff, name="number of LEV-carriers per 1000 cases")
    )+

    xlab('polygenic burden (PB)')+

    theme(legend.title = element_blank(),
          panel.grid =element_blank(),
          panel.background = element_blank(),
          panel.border = element_blank(),
          axis.line = element_line(colour = "black"),
          legend.position = 'none',
          axis.title.y.right = element_text(color = 'dodgerblue3'),
          axis.text.y.right = element_text(color = 'dodgerblue3'))

  #figure
  pdf(paste0(out_folder,'/',out_prefix,'_LEV_carriers_per_1000_cases_comparison_figure.pdf'),height = 5,width = 5)
  suppressWarnings(print(p))
  dev.off()

}

if(clean_tmp){
  cat(paste0('INFO cleaning up tmp folder\n'))
  cmd=paste0('rm -r ',tmp_folder)
  system(cmd,wait = F)
}

cat(paste0('INFO finished.\n'))


petsc_matprinter_fmt <- function(fmt="default")
{
  fmt_choices <- c("default", "matlab", "dense", "impl", "info", "info_detail", "common", "index", "symmodu", "vtk", "native", "basic", "lg", "contour")
  fmt <- match.arg(tolower(fmt), fmt_choices)

  fmt_int <- .Call(sbase_petsc_printer_lookup_code, fmt)
  .Call(sbase_petsc_matprinter_fmt, as.integer(fmt_int))

  invisible()
}

petsc_matprinter <- function(dim, ldim, data, row_ptr, col_ind, fmt="default")
{
  petsc_matprinter_fmt(fmt=fmt)

  .Call(sbase_petsc_matprinter, dim, ldim, data, row_ptr, col_ind)

  invisible()
}


#mtcars is a cars dataset
# Print the first observations of mtcars
head(mtcars)

# Print the last observations of mtcars
tail(mtcars)

# Print the dimensions of mtcars
dim(mtcars)

# Investigate the structure of the mtcars data set
str(mtcars)


# whitinga-selection: whitinga-selection
# Authors: Amy Marshall, Jason Gush
# whitinga-selection.r 2021-03-08 09:01:01Z

whitinga_selection <- function(dataframe, ma = 5, pa = 3, ff = 15, fe = 30){
	# draw Māori fellows, i.e. Ethnicity is flagged as Māori or Māori/Pacific Nations
	maori_fellows <- dataframe %>% filter(str_detect(Ethnicity, "Ma")) %>% slice_sample(n = ma) %>% mutate(ballot = "M\u101ori")

	# exclude already drawn fellows from the pool
	pool <- dataframe %>% anti_join(maori_fellows, by = c("Gender", "Ethnicity", "id"))

	# draw Pacific Nations fellows, i.e. Ethnicity is flagged as Pacific Nations or Māori/Pacific Nations
	pacific_fellows <- pool %>% filter(str_detect(Ethnicity, "Pa")) %>% slice_sample(n = pa) %>% mutate(ballot = "Pacific")

	fellows <- bind_rows(maori_fellows, pacific_fellows)
	pool <- pool %>% anti_join(fellows, by = c("Gender", "Ethnicity", "id"))

	# determine how many more female fellows are needed
	count_female = fellows %>% filter(Gender == "F") %>% nrow()
	female_fellows_to_select = ff - count_female

	# randomly sort remaining applicant pool
	shuffled_rows <- sample(nrow(pool))
	pool_sorted <- pool[shuffled_rows,]

	# select top sorted female and gender diverse applicants until the minimum target
	# of female fellows  has been drawn
	priv_pool <- pool_sorted %>% filter(Gender == "F" | Gender == "GD")
	head_counter = female_fellows_to_select
	females_drawn = 0

	while (females_drawn < female_fellows_to_select && nrow(fellows) + head_counter < fe) {
		new_fellows <- priv_pool %>% slice_head(n = head_counter) %>% mutate(ballot = "Pool")
		females_drawn <- new_fellows %>% filter(Gender == "F") %>% nrow()
		# if the slice is too small, i.e., as one or more gender diverse fellows were drawn
		# in slice, increase the slice size by one and redraw
		head_counter = head_counter + 1
	}

	fellows <- bind_rows(fellows, new_fellows)

	pool_sorted <- pool_sorted %>% anti_join(new_fellows, by = c("Gender", "Ethnicity", "id"))

	# draw from the top of the sort (now largely/exclusively male or non-reponse) all remaining fellows
	fellows_still_to_draw = fe - nrow(fellows)
	new_new_fellows <- pool_sorted %>% slice_head(n = fellows_still_to_draw) %>% mutate(ballot = "Pool")

	fellows <- bind_rows(fellows, new_new_fellows)

	return(fellows)
}


Sys.setlocale("LC_ALL", "C")

require(ggplot2)
library(scales)

area <- function(){

    set.seed(3)

    df = data.frame(
        VisitWeek = rep(as.Date(seq(Sys.time(),
        length.out = 7, by = "1 day")), 4),
        ThingAge = rep(1:4, each = 7),
        MyMetric = c(sample(80,7)/10 ,sample(8,7)/10 ,sample(8,7)/10, sample(8,7)/10) )

    print(df)

    plt <- ggplot(df, aes(x = VisitWeek, y = MyMetric)) +
            geom_area(aes(fill = factor(ThingAge)), alpha=0.7,  position = "fill") +
            #scale_x_continuous(breaks=df$VisitWeek, labels= df$VisitWeek)  +
            xlab("日期") +
            scale_x_date(breaks = unique(df$VisitWeek)) +

            ylab("时长百分比(%)") +
            scale_y_continuous(labels = percent) +

            ggtitle("重点试验设备一周状态汇总") +
            theme(plot.title = element_text(lineheight=3, face="bold", color="black", size=12) )+

            scale_fill_manual(values=c("#2ECC40", "#FFDC00", "#FF4136", "#85144B"),
                                        labels=c("试验中","闲置","故障","维护"),
                                        guide = guide_legend(title = "图例"))  +
            theme(axis.text.x = element_text(angle=15, hjust=1, vjust=1, size=7),
                      axis.title=element_text(size=10,face="bold") )

    ggsave("output/status_sum_area1.png", width=6, height=3.5)

}

area()


#! /usr/bin/Rscript
args <- commandArgs(trailingOnly = TRUE)

headersTXT = c(
"Miranda_score",
"miR_ID",
"mRNA_ID",
"Start_position",
"End_position",
"Seed_match_6mer2",
"miR_match_P01",
"Seed_match_7mer2",
"Seed_match_7mer1",
"Seed_MFE",
"X3p_MFE",
"Target_UC_comp",
"miR_match_P09",
"miR_match_P02",
"Seed_GU",
"miR_match_P07",
"miR_match_P19",
"miR_match_P15"
)

read.table(args[1],sep="\t", header=TRUE) -> features
features = subset(features, select = headersTXT)

#library(seqinr)
#read.fasta(file=args[2], as.string=TRUE) -> fa
#fa=fa[which(!duplicated(names(fa)))]
#utr_length = t(sapply(names(fa), function(i) {
#	c(i, nchar(fa[[i]][1]))
#}))

#remove records with UTRs not in fasta file
#features = subset(features, mRNA_ID %in% names(fa))

attach(features)
features_numeric = subset(features, select = -c(miR_ID,mRNA_ID))
aggregate(features_numeric, by=list(miR_ID,mRNA_ID), sum) -> features_sum
aggregate(1:dim(features_numeric)[1], by=list(miR_ID,mRNA_ID), length) -> number_sites
colnames(number_sites)[3] <- "number_sites"
aggregate(features_numeric, by=list(miR_ID,mRNA_ID), mean) -> features_mean
aggregate(features_numeric, by=list(miR_ID,mRNA_ID), max) -> features_max
aggregate(features_numeric, by=list(miR_ID,mRNA_ID), min) -> features_min
detach(features)

features_sum2 = features_sum
features_mean2 = features_mean
features_max2 = features_max
features_min2 = features_min

colnames(features_sum2) <- paste0(colnames(features_sum2), ".sum")
colnames(features_mean2) <- paste0(colnames(features_mean2), ".mean")
colnames(features_max2) <- paste0(colnames(features_max2), ".max")
colnames(features_min2) <- paste0(colnames(features_min2), ".min")
output = merge(number_sites, features_sum2, by=c(1,2))
output = merge(output, features_mean2, by=c(1,2))
output = merge(output, features_max2, by=c(1,2))
output = merge(output, features_min2, by=c(1,2))

selected_features =
c("Group.1",
"Group.2",
"Miranda_score.max",
"Seed_match_6mer2.mean",
"miR_match_P01.min",
"Seed_match_7mer2.max",
"Seed_match_7mer1.mean",
"Seed_MFE.min",
"X3p_MFE.mean",
"Target_UC_comp.mean",
"miR_match_P09.mean",
"miR_match_P02.min",
"Seed_GU.mean",
"miR_match_P07.mean",
"Start_position.min",
"miR_match_P19.min",
"miR_match_P15.min"
)

output2 <- output[,selected_features]
write.table(output2, file=paste0(args[2], ".csv"), sep=",", row.names=FALSE)


#' Rand seq
#'
#' Rand seq.
#'
#' @param BSgenome BSgenome object.
#' @param nsamp Numeric number of samples.
#' @param flank Numeric length of flank on each side of region.
#' @inheritParams ezlimma::roast_contrasts

sample_bsgenome_regions <- function(BSgenome, nsamp, flank, seed = 123){
  bed.samp <- vector("list", nsamp)
  set.seed(seed)
  for(samp.ind in seq_along(bed.samp)){
    prob <- BSgenome@seqinfo@seqlengths / sum(as.numeric(BSgenome@seqinfo@seqlengths))
    idx <- sample(length(BSgenome@seqinfo), 1, prob = prob)
    chr <- BSgenome@seqinfo@seqnames[idx]
    seqlength <- BSgenome@seqinfo@seqlengths[idx]
    start <- sample(seqlength - 2*flank, 1)
    end <- start + 2*flank
    name <- paste0("random_seq_", samp.ind)
    bed.samp[[samp.ind]] <- data.frame(chr=chr, start = start, end = end, name = name)
  }
  bed.samp <- Reduce(rbind, bed.samp)
  rownames(bed.samp) <- bed.samp$name
  gr.samp <- methods::as(bed.samp, "GRanges")

  # test
  seqs.samp <- BSgenome::getSeq(BSgenome, gr.samp)
  stopifnot(names(seqs.samp) == names(gr.samp))

  return(seqs.samp)
}


library(dplyr)
library(tidyr)
library(splitstackshape)
library(lubridate)

### dane wejściowe (???):
### wyszukiwanie plików:
path <- "."
file <- "s_1.csv"
sep <- ","
header <- TRUE
### filtrowanie danych z pliku:
col_1 <- "sequence"
col_2 <- "protein.id"
col_3 <- "percolator.q.value"
q_value <- 0.01
### separowanie danych w kolumnie:
col <- col_2
sep_2 <- ","

###==(sposób F.1)=== funckja wybierająca  plik/pliki i przypisująca dane
load_file <- function(path, file, sep, header){
  lst_file <- list.files(path, pattern = file)
  lst_table <- lapply(lst_file, read.table, header = header, sep = sep, stringsAsFactors = FALSE)
  do.call(rbind, lst_table)
}

# ##==(sposób F.2)=== funckja pozwalająca użytkownikowi wybierać jeden plik z okna i przypisująca dane
# load_file_2 <- function(sep, header){
#   file_ <- file.choose()
#   table_all <- read.table(file_, header = header, sep = sep)
# }

table_all <- load_file(path, file, sep, header)

### funckja filtruje po col_3 dla wartości mniejszej od q_value i wybierania kolumny col_1 i col_2
filter_table <- function(table_all, col_1, col_2, col_3, q_value){
  table_filtr <- filter(table_all, table_all[[col_3]] < q_value)
  table_filtr <- select(table_filtr, col_1, col_2)
}

table_filtr <- filter_table(table_all, col_1, col_2, col_3, q_value)

### funckja rozseparowuje dane w kolumnie
separate_table <- function(table, col, sep){
  table_separate <- cSplit(table, col, sep)
}

table_separate <- separate_table(table_filtr, col, sep_2)

### funckja łącząca powstałe nowe kolumny w jedną tabelkę o dwóch kolumnach
### oraz odrzuca wiersze z wartością <NA>
connect_table <- function(table_separate){
  table_protein <- table_separate[,1:2]
  for (i in seq(from = 3, to = dim(table_separate)[2])){
    table_protein <- rbind(table_protein,
                           filter(select(table_separate, 1, i),
                                  table_separate[[colnames(table_separate)[i]]] != "<NA>"),
                           use.names = FALSE)
  }
  table_protein
}

table_protein <- connect_table(table_separate)

### usuwanie powtórzonych wierszy
unique_table <- function(table_protein){
  table_protein <- unique(table_protein)
}

table_protein <- unique_table(table_protein)

### zmiana nazw kolumn
change_name_cols <- function(table, name_cols){
  colnames(table) <- name_cols
  table
}

table_protein <- change_name_cols(table_protein, c("peptides", "proteins"))

### tabela peptyd-białko posortowana po danej nazwie kolumny
sort_table <- function(table_protein, name_col){
  table_sort <- arrange(table_protein, table_protein[[name_col]])
}

table_peptide_protein <- sort_table(table_protein, "proteins")

#========================(start: sposób T.1)================================================================
### tworzenie data frame ilości występowania danego peptydu w danym białku
### zamiana klasy kolumn z factor na wektor
table_0_1 <- function(table_protein){
  table_protein[[colnames(table_protein)[1]]] <- as.vector(table_protein[[colnames(table_protein)[1]]])
  table_protein[[colnames(table_protein)[2]]] <- as.vector(table_protein[[colnames(table_protein)[2]]])
  table_protein_0_1 <- as.data.frame.matrix(table(table_protein))
}

table_protein_0_1 <- table_0_1(table_protein)

# ###======(sposób T.1.1 z macierzą 0 i 1):
# ### zamiana data frame na macierz
# matrix_0_1 <- function(table_protein_0_1){
#   matrix_protein_0_1 <- as.matrix(table_protein_0_1)
# }
#
# matrix_protein_0_1 <- matrix_0_1(table_protein_0_1)
#
# ### funckja obliczająca iloczyn macierzy
# matrix_diag <- function(matrix_protein_0_1){
#   t(matrix_protein_0_1) %*% matrix_protein_0_1
# }
#
# matrix_qty_peptide <- matrix_diag(matrix_protein_0_1)
#
# ### zamiana macierzy peptydów na tabelę ilości peptydów
# qty_table <- function(matrix_qty){
#   table_qty <- data.frame(rownames(matrix_qty), diag(matrix_qty))
#   rownames(table_qty) <- NULL
#   table_qty
# }
#
# table_qty_peptide <- qty_table(matrix_qty_peptide)
#
# ### zmiana nazw kolumn
# table_qty_peptide <- change_name_cols(table_qty_peptide, c("proteins", "qty_peptide"))
#
# ### iloczyn macierzy dla ilości białek
# matrix_qty_protein <- matrix_diag(t(matrix_protein_0_1))
#
# ### tabela ilości białek
# table_qty_protein <- qty_table(matrix_qty_protein)
#
# ### zmiana nazw kolumn
# table_qty_protein <- change_name_cols(table_qty_protein, c("peptides", "qty_protein"))

###========(sposób T.1.2 bez macierzy 0 i 1):
### funckja tworząca tabelę ilości peptydów dla danego białka
qty_peptide <- function(table_protein_0_1){
  table_qty_peptide <- data.frame(colnames(table_protein_0_1), as.vector(apply(table_protein_0_1, 2, sum)))
}

table_qty_peptide <- qty_peptide(table_protein_0_1)

### zmiana nazw kolum
table_qty_peptide <- change_name_cols(table_qty_peptide, c("proteins", "qty_peptides"))

### funckja tworząca tabelę ilości białek dla danego peptydu
qty_protein <- function(table_protein_0_1){
  table_qty_peptide <- data.frame(rownames(table_protein_0_1), as.vector(apply(table_protein_0_1, 1, sum)))
}

table_qty_protein <- qty_protein(table_protein_0_1)

### zmiana nazw kolumn
table_qty_protein <- change_name_cols(table_qty_protein, c("peptides", "qty_proteins"))

### podsumowanie (tabele wynikowe):
head(table_qty_peptide)
head(table_qty_protein)
head(table_peptide_protein)

### funckja znajdowania wspólnych peptydów / filtrowanie po białkach ???

    ### niebardzo rozumiemy jak to ma działać

# ###=========================(koniec: sposób T.1)=======================================================
#
# ###=========================(start: sposób T.2)========================================================
# ### sztuczne stworzenie kolumny zawierania peptydów w białkach
# include_col <- function(table_protein){
#   table_protein <- mutate(table_protein, include = rep(1, dim(table_protein)[1]))
# }
#
# table_protein_include <- include_col(table_protein)
#
# ### tworzenie data.frame zawierania, gdzie nazwami kolumn są nazwy białek,
# ### posortowane
# data_0_1 <-function(table_protein_include){
#   data_protein_0_1 <- as.data.frame(spread(table_protein_include, colnames(table_protein)[2], include, fill = 0))
# }
#
# data_protein_0_1 <- data_0_1(table_protein_include)
#
# ### usuwamy pierwszą kolumnę oraz usuwamy nazwy kolumn,
# ### aby otrzymać macierz 0 i 1 jako liczby
# matrix_0_1 <- function(data_protein_0_1){
#   matrix_protein_0_1 <- data_protein_0_1[,2:dim(data_protein_0_1)[2]]
#   colnames(matrix_protein_0_1) <- NULL
#   matrix_protein_0_1 <- as.matrix(matrix_protein_0_1)
# }
#
# matrix_protein_0_1 <- matrix_0_1(data_protein_0_1)
#
#
# ### funcja iloczyn macierzy i transpozycji macierzy
# matrix_diag <- function(matrix_protein_0_1){
#   t(matrix_protein_0_1) %*% matrix_protein_0_1
# }
#
# matrix_qty_peptide_2 <- matrix_diag(matrix_protein_0_1)
#
# ### zamiana macierzy na tabelę ilości peptydow/ilości białek
# table_qty <- function(matrix, table_peptide_protein, name_col){
#   table_peptide_protein <- sort_table(table_peptide_protein, name_col)
#   col_sort <- table_peptide_protein[[name_col]]
#   table_qty <- data.frame(unique(col_sort), diag(matrix))
# }
#
# table_qty_peptide_2 <- table_qty(matrix_qty_peptide_2, table_peptide_protein, "proteins")
#
# ### zmiana nazwy kolumn
# table_qty_peptide_2 <- change_name_cols(table_qty_peptide_2, c("proteins", "qty_peptides"))
#
# ### macierz ilości białek, korzystamy z funckji matrix_diag:
# matrix_qty_protein_2 <- matrix_diag(t(matrix_protein_0_1))
#
# ### zamiana macierzy ilości białek na tabelę ilości białek
# table_qty_protein_2 <- table_qty(matrix_qty_protein_2, table_peptide_protein, "peptides")
#
# ### zmiana nazwy kolumn
# table_qty_protein_2 <- change_name_cols(table_qty_protein_2, c("peptides", "qty_proteins"))
#
# ### podsumowanie T.2 (tabele wynikowe):
# head(table_peptide_protein)
# head(table_qty_peptide_2)
# head(table_qty_protein_2)
#
# ###============(koniec: sposób T.2)=================================================================================


# Using Tidyverse to explore data

# A. Import
# 1. Read csv file
# Load readr
library(readr)

# Create bakeoff but skip first row
bakeoff <- read_csv("bakeoff.csv", skip = 1)

# Print bakeoff
bakeoff

# 2. Assign missing values
# Load dplyr
library(dplyr)

# Filter rows where showstopper is UNKNOWN
bakeoff %>%
    filter(showstopper == "UNKNOWN")

# Edit to add list of missing values
bakeoff <- read_csv("bakeoff.csv", skip = 1,
                    na = c("", "NA", "UNKNOWN"))

# Filter rows where showstopper is NA
bakeoff %>%
    filter(is.na(showstopper))

# B. Know your data
# 1. Arrange and glimpse.
bakeoff %>%
    arrange(us_airdate) %>%
    glimpse()

# 2. Summarize the data
# Load skimr
library(skimr)

# Edit to filter, group by, and skim
bakeoff %>%
  filter(!is.na(us_season)) %>%
  group_by(us_season)  %>%
  skim()

# C. Count with your data
# 1. Distinct and count
# View distinct results
bakeoff %>%
    distinct(result)

# Count rows for each result
bakeoff %>%
  count(result)

# Count whether or not star baker
bakeoff %>%
  count(result == "SB")

# 2. Count episodes
# Count the number of rows by series and episode
bakeoff %>%
    count(series, episode)

# Add second count by series
bakeoff %>%
  count(series, episode) %>%
  count(series)

# 3. Count bakers
# Count the number of rows by series and baker
bakers_by_series <- bakeoff %>%
  count(series, baker)

# Print to view
bakers_by_series

# Count again by series
bakers_by_series %>%
  count(series)

# Count again by baker
bakers_by_series %>%
  count(baker, sort = TRUE)

# 4. Plot counts
ggplot(bakeoff, aes(episode)) +
    geom_bar() +
    facet_wrap(~series)


# install packages from CRAN
p_needed <- c("readr", # imports spreadsheet data
              "haven", # imports SPSS, Stata and SAS files
              "labelled", # helpers to work with variable labels
              "dplyr",  # provides neat functions for data frame manipulation,
              "tidyr", # suite for tidying data
              "ggplot2", # advanced graphics suite
              "gridExtra", # more functionality for ggplot2 plot
              "stargazer", # nice formatting of regression table output
              "babynames", # US baby names provided by the SSA
              "nycflights13", # dataset on all 336776 flights departing from NYC in 2013
              "wooldridge", # datasets used in Wooldridge
              "car", # functions from "Compaion to Applied Regression"
              "lmtest", # functions for additional regression diagnostics (including RESET test),
              "broom", # tidying model output
              "interplot", # plot effects of interaction terms
              "margins", # calculate and visualize marginal effects
              "interflex", # interaction diagnostics and flexible estimation
              "xts", # working with time-series data
              "tseries", # functions for time series analysis
              "lubridate", # working with dates and times
              "plm", # panel data econometrics
              "pcse", # panel-corrected standard errors à la Beck and Katz (1995)
              "readxl", # import Excel data
              "ggthemes",
              "Zelig",
              "ISLR",
              "janitor"
)
packages <- rownames(installed.packages())
p_to_install <- p_needed[!(p_needed %in% packages)]
if (length(p_to_install) > 0) {
  install.packages(p_to_install)
}
lapply(p_needed, require, character.only = TRUE)


#' @useDynLib rotp R_totp
totp_wrapper = function(key, interval=30L, digits=6L)
{
  .Call(R_totp, key, interval, digits)
}

#' totp
#'
#' Implementation of the Time-based One-Time Password algorithm.
#'
#' @param key
#' The secret key.
#' @param interval
#' The interval of time in seconds.
#' @param digits
#' The number of digits of the return.
#'
#' @return
#' An integer with \code{digits} digits.
#'
#' @examples
#' rotp::totp("asdf")
#'
#' @references \url{https://en.wikipedia.org/wiki/Time-based_One-time_Password_algorithm}
#' @export
totp = function(key, interval=30, digits=6)
{
  check.is.string(key)
  check.is.posint(interval)
  check.is.posint(digits)

  if (ndigits(digits) > 10)
    stop("argument 'digits' too large")

  interval = as.integer(interval)
  digits = as.integer(digits)

  totp_wrapper(key, interval, digits)
}


# Install Packages
install.packages('wbstats')
install.packages('gganimate')
install.packages('viridis')
install.packages('tidyverse')
devtools::install_github("tidyverse/tidyr")
install.packages('gifski')
install.packages('png')

# libraries needed

library(tidyverse)
library(ggplot2)
library(viridis)
library(gganimate)
library(wbstats)
library(tidyr)

# Sample World Bank Data
data = wbstats::wb(indicator = c("SP.DYN.LE00.IN", "NY.GDP.PCAP.CD", "SP.POP.TOTL"),
                       country = "countries_only", startdate = 1960, enddate = 2019)

# pull the country data down from the World Bank - three indicators
anim = wbstats::wb(indicator = c("SP.DYN.LE00.IN", "NY.GDP.PCAP.CD", "SP.POP.TOTL"),
                       country = "countries_only", startdate = 1960, enddate = 2019)  %>%
  # pull down mapping of countries to regions and join
  dplyr::left_join(wbstats::wbcountries() %>%
                     dplyr::select(iso3c, region)) %>%
  # spread the three indicators
  tidyr::pivot_wider(id_cols = c("date", "country", "region"), names_from = indicator, values_from = value) %>%
  # plot the data
  ggplot2::ggplot(aes(x = log(`GDP per capita (current US$)`), y = `Life expectancy at birth, total (years)`,
                      size = `Population, total`)) +
  ggplot2::geom_point(alpha = 0.5, aes(color = region)) +
  ggplot2::scale_size(range = c(.1, 16), guide = FALSE) +
  ggplot2::scale_x_continuous(limits = c(2.5, 12.5)) +
  ggplot2::scale_y_continuous(limits = c(30, 90)) +
  viridis::scale_color_viridis(discrete = TRUE, name = "Region", option = "viridis") +
  ggplot2::labs(x = "Log GDP per capita",
                y = "Life expectancy at birth") +
  ggplot2::theme_classic() +
  ggplot2::geom_text(aes(x = 30, y = 60, label = date), size = 14, color = 'black', family = 'Oswald') +
  # animate it over years
  gganimate::transition_states(date, transition_length = 1, state_length = 1) +
  gganimate::ease_aes('cubic-in-out')

gganimate::anim_save(animation=anim, 'xp-rosling-2019-v2.gif')


#  This function deconvolves the azimuth as stored in the

get_angle_IN <- function(bearings, degrees, dists) {
  #  This function is used in 'step.one.clean.bind_v1.1.R', it converts the
  #  text azimuth strings to numeric, 360 degree values.
  #  This is the vector that will store the values.
  angl <- degrees

  #  This is a special case, generally where the tree is plot center.
  angl[degrees == '0' & dists =='0'] <- 0

  #  This is a short function that takes cares of NAs in boolean functions, it's
  #  just a simple wrapper for the boolean function that sets the NA values in
  #  the vector to FALSE.
  fx.na <- function(x) { x[ is.na( x ) ] <- FALSE; x }

  #  Given the text azimuths in the dataset, return the quadrant values.
  #  This gives a boolean index of the quadrant

  north <- fx.na(bearings == 'NNA'| bearings == 'NAN' | bearings =='N'|bearings =='N99999'|bearings =='N88888')
  east <- fx.na(bearings == 'NAE' | bearings =="ENA" | bearings =='E'|bearings =='99999E'|bearings =='88888E')
  south <- fx.na(bearings == 'SNA' | bearings =="NAS"| bearings == 'S'|bearings =='S99999'|bearings =='S88888')
  west <- fx.na(bearings == 'NAW' | bearings =="WNA" | bearings == 'W'|bearings =='99999W'|bearings =='88888W')
  #north <- fx.na( regexpr('N', bearings) > 0 )
  #east  <- fx.na( regexpr('E', bearings) > 0 | bearings == 'EAST')
  #south <- fx.na( regexpr('S', bearings) > 0 | bearings == 'SOUTH')
  #west <-  fx.na( regexpr('W', bearings) > 0 | bearings == 'WEST')

  ne <- fx.na( (north & east) | bearings == 'NE')
  se <- fx.na( (south & east) | bearings == 'SE')
  sw <- fx.na( (south & west) | bearings == 'SW')
  nw <- fx.na( (north & west) | bearings == 'NW')

  #  The cell is in a quadrant, regardless of which.
  quad <- ne | se | sw | nw

  #  Special case of the trees with a unidirectional direction.
  uni  <- (!quad) & (north | south | east | west)

  angl[ uni & north ] <- 0
  angl[ uni & south ] <- 180
  angl[ uni & east  ] <- 90
  angl[ uni & west  ] <- 270

  #  The problem is that some notes have either N04E, N 4E or N4E, or NE!
  #strlen <- nchar(bearings)
  #strlen[is.na(bearings)] <- NA

  #######not sure if I need this section

  #angl[quad & strlen == 2] <- 45
  #angl[quad & strlen == 3] <- as.numeric(substr(azimuth[ quad & strlen == 3 ], 2, 2))
  #angl[quad & strlen == 4 & !substr(azimuth, 2, 3) == '  '] <-
   # as.numeric(substr(azimuth[quad & strlen == 4 & !substr(azimuth, 2, 3) == '  '], 2, 3))

  # Special case of double spaces in the azimuth.
  #angl[quad & strlen == 4 & substr(azimuth, 2, 3) == '  '] <- 45

  ##########

  #  Another set of special cases:
  angl[ fx.na(bearings == 'NORT') ] <- 0
  angl[ fx.na(bearings == 'EAST') ] <- 90
  angl[ fx.na(bearings == 'WEST') ] <- 270
  angl[ fx.na(bearings == 'SOUT') ] <- 180

  angl[ ne ] <- angl[ ne ]
  angl[ se ] <- 180 - angl[ se ]
  angl[ sw ] <- 180 + angl[ sw ]
  angl[ nw ] <- 360 - angl [ nw ]

  return(angl)

}


## Unit conversion

convert <- function(data, unitCol, values){

## convert units to character vector from factor
data[,unitCol] <- as.character(data[,unitCol])

data <- data[!is.na(data[,values]),] ## omit missing values

## Switch text of mg/m2 to mg/m3
data[data[,unitCol]=="mg/m2",unitCol] <- "mg/m3"

## Switch text ppm to mg/L because equivalent
data[data[,unitCol]=="ppm",unitCol] <- "mg/L"

## Switch text mg/m3 to mg/L
data[data[,unitCol]=="mg/m3",unitCol] <- "ug/L"

## Convert  ug/L to mg/L
data[data[,unitCol]=="ug/L",values] <-  data[data[,unitCol]=="ug/L",values]/1000
data[data[,unitCol]=="ug/L",unitCol] <- "mg/L" ## switch text

## Round ug/L values to the 10,000th because accuracy below a microgram unlikely
data[,values] <- round(data[,values],5)

## Omit other units
data <- data[data[,unitCol] == "mg/L",]

data <- data[,c("uniqueID",unitCol,values)]

return(data)
}


args <- commandArgs(trailingOnly = TRUE)
xyz <- read.csv(file=args[1])
pdf(args[2])
scatterplot3d::scatterplot3d(xyz, color="blue", pch=19, xlab="Statistical Distance", ylab="Sample Size", zlab="Match Percentage", type="h")


test_that("define_level_slope_variances",{
  result <- define_level_slope_variances("variable_of_interest_name")
  expect_equal(result, 'variable_of_interest_name_level ~~ variable_of_interest_name_level')
})

test_that("define_level_slope_variances - with include_slopes true",{
  result <- define_level_slope_variances("pop", TRUE)
  pasteResult <- paste(
    'pop_level ~~ pop_level',
    'pop_level ~~ pop_slope',
    'pop_slope ~~ pop_slope',
    sep = "\n"
  )
  expect_equal(result, pasteResult)
})

test_that("define_level_slope_variances - with include_slopes true and constrain_group_variances_to_be_equal is TRUE",{
  result <- define_level_slope_variances("pop", TRUE, TRUE)
  pasteResult <- paste(
    'pop_level ~~ c(LV,LV)*pop_level',
    'pop_level ~~ c(LSV,LSV)*pop_slope',
    'pop_slope ~~ c(SV,SV)*pop_slope',
    sep = "\n"
  )
  expect_equal(result, pasteResult)
})