library(data.table)
source('R/extract_from_db.r')
source('R/tree_changepoints.r')

tree.segments <- function(gp, breakpoints.v, breakpoints.h){
  # Return the segments (subgraphs) of g according to its changepoints
  cat("\nCOMPUTE SEGMENTS OF TREE\n")
  segs <- list()
  processed <- c()
  cat("breakpoints:", breakpoints.v)
  for (i in 1:vcount(gp)){
    # check if already in some segment
    if (V(gp)[i] %in% processed){
      cat('\n next')
      next
    }
    cat('\nnode: ', i)
    # detect neighbourhood
    gs <- neighborhood.temporal(gp, i, 10, breakpoints.v, breakpoints.h)
    cat('\nsegment: ', as.numeric(V(gp)[V(gs)$name]))

    # plot it
    V(gp)[breakpoints.v]$color <- 'green'
    V(gp)[breakpoints.h]$color <- 'blue'
    V(gp)[V(gs)$name]$color <- "red"
    plot.tree(gp, labels = 'id')
    V(gp)[V(gs)$name]$color <- "white"

    segs[[length(segs)+1]] <- gs
    # add them to processed list
    processed <- union(processed, V(gp)[V(gs)$name])
    #plot.tree.breakpoints(gp, breakpoints.v, breakpoints.h)
  }
  segs
}

count_motifs_by_usersegment <- function(threads,
                                 database='reddit',
                                 rad=2,
                                 max.neighbors=4,
                                 chunk.id=0){

  con <- dbConnect(dbDriver("SQLite"), dbname = paste0("./data/", database, ".db"))

  # For every thread, recontruct its graph. Then count
  # if neighborhood at distance 1 and binary tree, max nodes is 4
  # if neighborhood at distance 1 and binary tree, max nodes is 10
  # 4   10   22   30   46   62   93  123...
  motifs <- list()
  posts.id <- vector()
  posts.motifs.id <- vector()
  plotted.trees <- 1

  id.process <- Sys.getpid()
  filelog <- paste0("log", id.process, ".csv")

  nthreads <- length(threads)
  posts.motifs <- data.frame()
  for(i in 1:nthreads){

      #Extract the egos of every post
      g <- database.to.graph(threads[i], con, database)
      gp <- g$gp

      size <- vcount(gp)
      cat('\n', i, '/', nthreads, '/', threads[i], ' size: ', size, ' chunk.id: ', chunk.id )
      if(size>1000){
        cat("\n WARNING: skipping thread of size ", size)
        next
      }

      # cast dates to numeric
      dates <- as.numeric(V(gp)$date)
      gp <- remove.vertex.attribute(gp, "date")
      V(gp)$date <- dates

      root.post <- V(gp)[which(degree(gp, mode='out')==0)]$name

      breakpoints <- changepoints.cp(gp, vertical=T, horizontal=T)
      breakpoints.h <- breakpoints$breakpoints.h
      breakpoints.v <- breakpoints$breakpoints.v
      breakpoints.vh <- breakpoints$breakpoints.vh

      V(gp)$bp.v <- FALSE
      V(gp)$bp.h <- FALSE
      V(gp)$bp.vh <- FALSE
      V(gp)[breakpoints.v]$bp.v <- TRUE
      V(gp)[breakpoints.h]$bp.h <- TRUE
      V(gp)[breakpoints.vh]$bp.vh <- TRUE
      segs <- tree.segments(gp, breakpoints.v, breakpoints.h)

      # for every segment (local dynamic)
      for(i in 1:length(segs)){
        gs <- segs[[i]]
        users <- V(gs)$user
        # for every user (not post) in the segment
        for(j in 1:length(users)){
          u <- users[i]
          post.id <- V(gs)$name[V(gs)$user == u] #first user post as reference
          V(gs)$color <- 1 # black by default

              #if(degree(eg, v=u, mode='out')==1){
          #  p.user.name <- neighbors(gs, u, mode='out')$user
          #  V(eg)[V(eg)$user==p.user.name]$color <- 2 # posts writen by parent of ego
          #}

          V(gs)$color[V(gs)$user == u] <- 4  # posts written by ego author
          tryCatch({V(gs)[root.post]$color <- 5}, error = function(e){}) # root (exception if root not in there)

          # Prune neighbourhood to reduce number of possible neighbourhoods
          #gs <- prune(gs)

          # If neighbourhood is too big, sometimes isomorphism check takes too long
          if(vcount(gs)>100){
            cat("\nSkipping neighbourhood isomorphism in thread ", threads[i], "-", vcount(gs))
            next
          }

          # See if it matches any seen motif
          ###################################
          is.new <- TRUE
          if(length(motifs)>0){
            for(motif.id in 1:length(motifs)){
              gmotif <- motifs[[motif.id]]

              # the vf2 does not like graphs of different size
              if(vcount(gs) != vcount(gmotif)){
                next
              }

              if(length(unique(V(gs)$color)) != length(unique(V(gmotif)$color))){
                next
              }

              if(all(table(V(gs)$color) != table(V(gmotif)$color))){
                next
              }

              if(is_isomorphic_to(gs, gmotif, method='vf2')){
                is.new <- FALSE
                break
              }}}

          # If motif is new, add it to the list
          if(is.new){
            motif.id <- length(motifs)+1
            motifs[[motif.id]] <- gs
          }

          posts.motifs <- rbindlist(list(posts.motifs,
                                         data.frame(user=u, postid=post.id, motif=motif.id)))
        } # end users
      } # end segments
  } # end threads

  posts.motifs <- data.frame(posts.motifs)

  if(nrow(posts.motifs)==0){
    cat("No neighbourhoods in this chunk")
    return(list(participation.motifs = NA,
                motifs = NA))
  }

  names(posts.motifs) <- c('postid', 'motif')

  # Sort by frequency (and relabel: 1 for the most frequent and so forth)
  idx <- order(table(posts.motifs$motif), decreasing = TRUE)
  posts.motifs$motif <- match(posts.motifs$motif, idx)
  motifs <- motifs[idx]

  cat("chunk.id: ", chunk.id, " completed!!")
  return(list(participation.motifs = posts.motifs,
              motifs = motifs))
}


needed_packages <- c(
  "tidyverse"
  , "lubridate"
  , "EpiEstim"
  , "incidence"
  , "projections"
  , "epitrix"
  , "distcrete")

lapply(needed_packages, function(x) { if(!require(x,character.only = TRUE)) install.packages(x)} )

cor1<-read_csv('https://docs.google.com/spreadsheets/d/16-bnsDdmmgtSxdWbVMboIHo5FRuz76DBxsz_BbsEVWA/export?format=csv&id=16-bnsDdmmgtSxdWbVMboIHo5FRuz76DBxsz_BbsEVWA&gid=0')

unique(cor1$osm_admin_level_4)

corConf <- cor1 %>% filter( osm_admin_level_4 =="Indeterminado") %>% mutate(fecha=dmy(fecha)) %>% select(tot_casosconf,fecha,transmision_tipo) %>% mutate(localesdia=tot_casosconf - lag(tot_casosconf), fecha=ymd(fecha), dias =as.numeric( fecha - min(fecha)))

corConf <- cor %>% filter( osm_admin_level_4 =="Córdoba") %>% mutate(fecha=dmy(fecha)) %>% select(nue_casosconf_diff,fecha,transmision_tipo)

prov <- estima_Re_from_df(corConf,"Prov. Córdoba",end_date=today())

corConf <- cor %>% filter( osm_admin_level_4 =="Tierra del Fuego", osm_admin_level_8!="Malvinas" | is.na(osm_admin_level_8)) %>% mutate(fecha=dmy(fecha)) %>% select(nue_casosconf_diff,fecha,transmision_tipo,osm_admin_level_8)

estima_Re_from_df(corConf,"Prov. Córdoba")

corConf <- cor %>% filter( osm_admin_level_4 =="CABA") %>% mutate(fecha=dmy(fecha)) %>% select(nue_casosconf_diff,nue_fallecidos_diff,fecha,transmision_tipo,osm_admin_level_8)

corConf <- cor %>% filter( osm_admin_level_4 =="Indeterminado") %>% mutate(fecha=dmy(fecha)) %>% select(tot_casosconf,tot_fallecidos,tot_recuperados,tot_terapia,fecha,transmision_tipo)


# <-- encoding UTF-8 -->
# Empirical study on CHARLS dataset (county level)
# -------------------------------------
## DOC STRING
#
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# -------------------------------------

rm(list=ls())

# -------------------------------------
## SECTION 0: ENVIRONMENT
library(readxl)  # xlsx I/O
library(car)  # VIF
library(sqldf)  # sql api
library(plm)  # panel data models
library(openxlsx)  # easy xlsx IO
library(psych)  # easiser PCA
source("./src/mathtools.r")
# library(plyr)  # sql-like dataframe operations

# environment pars
envCHARLS <- list(
    MicroDat = "./data/CHARLS_CITY.xlsx",  # CHARLS dataset (agent level)
    Output = "./output/proc_1_CHARLS/",  # output directory
    # ----------------------
    Ynames = c( "OUTP1M_RATIO", "CHRONIC_RATIO" ),  # dependents
    Xcore = c( "AVGINDIINCOME_EARN", "AVGEDU" ),  # the two variables we care most
    # ----------------------
    Xnames = c( "" ),  # a name list of selected independents (to regress), filled later
    Xcandidate = c( "" ),  # a name list of potential independents, filled later
    Xcontrol = c(""),  # selected control variables (not includes Xcore)
    Xexpel = c(
        "NONAGRIHUKOU_RATIO",
        # ------------------ outcomes
        "AVGCHRONIC_NUM", "HOSP1Y_RATIO", "AVGHOSP1Y_TIMES", "AVGOUTP1M_TIMES",  "AVGHOSPNOX_LAST",
        # ----------------- verbose
        # "AVGOUTP1M_REALEXP",
        "INSOTH_RATIO",
        "RETIRE_RATIO", "RETIREFORMAL_RATIO", "JOBSTATUS_RETI_RATIO",
        # ------------- asset
        "AVGINDIASSET_CASHSAVE" ,
        "AVGINDIASSET_CAPITAL" ,
        "AVGINDIASSET_GOVBOND" ,
        "AVGINDIASSET_OTHER" ,
        "AVGINDIASSET_TOTAL",
        # ----------------
        "AVGHOUSASSET_TOTAL",

        # "AVGINDIINCOME_EARN" ,
        # ------------- income
        "AVGHOUSINCOME_CAPITAL" ,
        "AVGHOUSINCOME_TOTAL",
        # ------------- income
        "AVGINDIINCOME_TOTAL",
        "AVGINDIINCOME_SELF" ,
        "AVGINDIINCOME_PENSION" ,
        "AVGINDIINCOME_TRANS" ,
        "AVGINDIINCOME_OTHER" ,
        "AVGINDIINCOME_FAMILY" ,
        "AVGTRANSCHILD_AMT",
        # ------------- transfer payment
        "AVGTRANSPAY_TOTAL"

        ),  # variables to drop, usually those almost-singular, or endogeneity etc
    # ----------------------
    flagCity = "city",  # individual flag (county level)
    flagProv = "province",  # individual flag (province level)
    flagT = "year",  # time flag
    flagSampleSize = "SAMPLESIZE",   # sample size of each city, used later to weight plotting data
    # ----------------------
    FigWidth = c( 12, 12, 12 ),  # width candidates for plots: 4:3, 16:9, 1:1
    FigHeight = c( 9, 27/4, 12 )  # heigth candidates
)

# -------------------------------------------------
# SECTION 1:  DATA PROCESSING
# NOTE: in this section, we read in the city-level aggregated dataset of harmonized CHARLS data (2011,2013,2015).
#       because R is quite low-efficient in processing large dataset like CHARLS,
#       we did this job in SAS and just import the aggregated dataset in this section.
#       if you need more information about how we did the data-processing job,
#       please refer to README.md;
#       I also attached the SAS program, two community-city-province index datasets,
#       the codebook of the harmonized CHARLS data, and a detailed data dictionary in "./data/CHARLSdat/".
#       you may just run the "H_CHARLS_Clean.sas", when downloaded the original dataset from CHARLS's website. (too large, not attached)
#       but pls note: because Stata13 data is incompatible to ANGTHING but Stata13 itself,
#       I had to convert the very original CAHRLS dataset to SPSS data (.sav) then read it into SAS. (be easy, no data, tags or labels lost)
#       please do so if you want to re-process our data aggregation process by yourself.
#       other data format, such as .xlsx, .csv may lose format information which records tags & encoding information.
#       and, a direct converting from .dta to .sas7bdat may also lose some information (e.g. variable name may change), if using improper converting tools.
#
# Tianhao Zhao
# Dec 2018
# ------------
# 1.0 read in city-level CHARLS dataset
df_CHARLS_backup <- readxl::read_xlsx( envCHARLS$MicroDat )
names(df_CHARLS_backup)[names(df_CHARLS_backup) == "YEAR"] <- "year"  # for convenient coding later
# 1.1 a copy of original dataset, work on it
df_CHARLS <- df_CHARLS_backup
# 1.2 save the namelist of candidate control variables
tmp <- base::setdiff(names(df_CHARLS),envCHARLS$Ynames)
tmp <- base::setdiff(tmp,envCHARLS$Xcore)
tmp <- base::setdiff(tmp,envCHARLS$flagT)
tmp <- base::setdiff(tmp,envCHARLS$flagProv)
tmp <- base::setdiff(tmp,envCHARLS$flagCity)
tmp <- base::setdiff(tmp,envCHARLS$flagSampleSize)
tmp <- base::setdiff(tmp,envCHARLS$Xexpel)
envCHARLS$Xcandidate <- tmp
# 1.3 print info
cat("The number of candidate X: ",length(envCHARLS$Xcandidate), "\n\n" )
cat("They are: ", envCHARLS$Xcandidate, "\n\n")
# 1.4 re-sort the columns
df_CHARLS <- df_CHARLS[,c( envCHARLS$flagSampleSize,
                           envCHARLS$flagCity, envCHARLS$flagT, envCHARLS$flagProv,
                           envCHARLS$Ynames, envCHARLS$Xcore, envCHARLS$Xcandidate )]
# 1.5 drop NA obs
df_CHARLS <- na.omit(df_CHARLS)

# ---------------------------------------
# SECTION 2: solve the problem of collinearty between the two core vars (income & edu)
cat("\nSection 2: COLLINEARITY BETWEEN INCOME & EDU\n-----------------------------------------------\n")
# NOTE: in CHARLS, agents are over 45 years old, they had finished education when interviewed,
#       and were receiving working inocmes or retired.
#       both working & retirement have incomes, e.g. salary when working and pension benefites when retired.
#       Therefore, edu may affect income, but income cannot affect edu.
#       there is collinearity between the two, but the channel is one-way & clear (edu -> income).
#       Thus, We use edu to regress income, then use the residuals to replace income.
#       Then, the collinearity is solved, and we can clearly discuss the "pure" effect of income & edu
# NOTE: different from CHARLS, we have multiple candidates about incomes now.
#       but we care the INDIVIDUAL TOTAL incomes, and drop other kinds of incomes
#       i.e. we, for now, do not distinguish different kinds of income sources
# ------------

# # 2.1 the correlation coef between income & edu:
# cat("Corr(AVGINDIINCOME_EARN,AVGEDU) = ", cor(df_CHARLS[,envCHARLS$Xcore] ), "\n" )
# # 2.2 regression
# tmp <- lm( AVGINDIINCOME_EARN ~ AVGEDU, df_CHARLS )
# # 2.3 replace income with the residuals
# df_CHARLS$AVGINDIINCOME_EARN <- residuals(tmp)
# # 2.4 print info
# cat("Corr(resid(AVGINDIINCOME_EARN ~ AVGEDU), AVGEDU) = ", cor(df_CHARLS[,envCHARLS$Xcore] ), "\nPossible Collinearity Solved\n" )
#

# ---------------------------------------
# SECTION 3: select background/control variables through single-variable regression
cat("\nSection 3: SELECT BACKGROUND/CONTROL VARIABLES\n-----------------------------------------------\n")
# NOTE: We use alpha = 0.05;
# --------------
# 3.1 prepare a df to save significance of single-variable regressions
df_SignifSingle <- data.frame(
    IndicatorName = base::setdiff(envCHARLS$Xcandidate,envCHARLS$Xcore),  # we regress all indicators other than the core variables (income & edu)
    OUTP1M_RATIO = Inf,  # the p-val of the current indicator in model (illnessratio ~ 1 + CurrentIndicator)
    CHRONIC_RATIO = Inf # the same
)

# 3.2 do single-variable regressions, fill the df
for(tmpYname in envCHARLS$Ynames ){
    for(tmpXname in df_SignifSingle$IndicatorName ){
        # 3.2.1 regression
        eval(parse(text=paste(sep="",
                              "tmp <- summary(lm(", tmpYname, "~", tmpXname, ", data = df_CHARLS ))"
        )))
        # 3.2.2 get p-val
        eval(parse(text=paste(sep="",
                              "df_SignifSingle[df_SignifSingle$IndicatorName == \"", tmpXname, "\",\"", tmpYname, "\"] <- tmp$coefficients[2,4]"  # extract p-value
        )))
    }
}

# 3.3 check significance
df_SignifSingle[,envCHARLS$Ynames] <- df_SignifSingle[,envCHARLS$Ynames] < 0.05  # alpha = 0.05
df_SignifSingle$FlagSelected <- apply(df_SignifSingle[,envCHARLS$Ynames], 1, sum) > 0  # if significant on, at least, one health outcome indicator, then marked as selected (TRUE)

# 3.4 update envCHARLS.Xcontrol (no envCHARLS.Xcore, only selected control vars kept)
envCHARLS$Xcontrol <- as.character(df_SignifSingle$IndicatorName[df_SignifSingle$FlagSelected])

# 3.5 print info
cat("Drop these control variables through single-variable regressions:\n",
    setdiff(df_SignifSingle$IndicatorName, envCHARLS$Xcontrol ), "\n" )
cat("because they show no statistical significance on any health outcome indicators.\n")
cat("these control variables remain:\n",envCHARLS$Xcontrol,"\n")

# 3.6 recycling df_SignifSingle, delete dropped variables/rows
# NOTE: now it is used to save if a variable is selected as a control variable in the AIC-selected specification of each health outcome
#       (each column marks which control vars are selected by AIC criteria);
#       Meanwhile, envCHARLS.Xcores (incoem & edu) are forcely kept in the final specification;
df_SignifSingle$FlagSelected <- NULL  # not needed anymore, if kept, may be misleading
df_SignifSingle <- df_SignifSingle[df_SignifSingle$IndicatorName %in% envCHARLS$Xcontrol,  ]  # drop those dorpped vars

# ---------------------------------------
# SECTION 3: MODEL SELECTION: PCA
# -------
# 3.1 a list to save PCA results generated by prcomp()
li_PCAres_CHARLS <- list(
    OUTP1M_RATIO = 0,
    CHRONIC_RATIO = 0
)
# 3.2 PCA analysis
# a vector to set max k components for each dependent
li_PCAk_CHARLS <- list(
    OUTP1M_RATIO = 4,
    CHRONIC_RATIO = 4
)
# 3.2.1 run
for(tmpYname in envCHARLS$Ynames){
    # estimate using psych library
    tmp <- as.character(df_SignifSingle$IndicatorName[ df_SignifSingle[,tmpYname] ] )  # index
    tmp <- psych::principal( df_CHARLS[,tmp], nfactors = li_PCAk_CHARLS[[tmpYname]], rotate = "varimax", scores = TRUE )  # rotate
    li_PCAres_CHARLS[[tmpYname]] <- tmp
        # # estimate (using build-in function prcomp() )
        # tmp <- as.character(df_SignifSingle$IndicatorName[ df_SignifSingle[,tmpYname] ] )  # index
        # li_PCAres_CHARLS[[tmpYname]] <- prcomp( df_CHARLS[,tmp], center = TRUE, scale. = TRUE, retx = TRUE, rank. = li_PCAk_CHARLS[[tmpYname]]  )
        # varmax()  # rotating
    # print
    cat("Dependent: ",tmpYname,"\n")
    print(  li_PCAres_CHARLS[[tmpYname]]  )
    cat("\n----------------------\n")
}
# 3.2.2 output (openxlsx can make every element in a list as a sheet in excel)
tmp <- list()  # eigen values
tmp1 <- list()  # loading matrix
for(tmpYname in envCHARLS$Ynames){
    tmp[[tmpYname]] <- li_PCAres_CHARLS[[tmpYname]]$values   # output eigen values
    tmp1[[tmpYname]] <- func_Load2Mat(  li_PCAres_CHARLS[[tmpYname]]$loadings  )  # loading matrix
}
openxlsx::write.xlsx(  tmp  , paste(sep="",envCHARLS$Output,"PCAresult_CHARLS.xlsx"),  rowNames = TRUE  )
openxlsx::write.xlsx(  tmp1  , paste(sep="",envCHARLS$Output,"PCAloading_CHARLS.xlsx"),  rowNames = TRUE  )

# 3.2.3 scree plots and output
# NOTE: for convenience, we plot it in excel! :)

# 3.2 construct a list to save the namelists of independents (Xcore + Pca) for every specification
li_Xnames_CHARLS <- list()
for(tmpYname in envCHARLS$Ynames){
    li_Xnames_CHARLS[[tmpYname]] <- c( envCHARLS$Xcore, paste(sep="","RC", 1:li_PCAk_CHARLS[[tmpYname]]  )  )
}

# 3.3 construct final specifications
li_Eq_CHARLS <- list()
for(tmpYname in envCHARLS$Ynames){
    # final specifications: y ~ income + edu + PC1 + ...
    li_Eq_CHARLS[[tmpYname]] <- func_GetEq( tmpYname,  li_Xnames_CHARLS[[tmpYname]]  ,
                                          Intercept = TRUE, KeepStr = FALSE
    )
    # print final specifications
    print(li_Eq_CHARLS[[tmpYname]]); cat("------------------------\n")
}

# 3.4 construct corresponding datasets
li_Dat_CHARLS <- list()  # general dataset
li_DatPlm_CHARLS <- list()  # plm indexed dataset
for(tmpYname in envCHARLS$Ynames){
    # extract principle components of current Y
    tmp <- li_PCAres_CHARLS[[tmpYname]]$scores
    # merge it with Y, Xcore, tags (indi, time)
    li_Dat_CHARLS[[tmpYname]] <- data.frame( df_CHARLS[,c( envCHARLS$flagT, envCHARLS$flagCity, tmpYname, envCHARLS$Xcore )] , tmp )
    li_DatPlm_CHARLS[[tmpYname]] <- plm::pdata.frame( li_Dat_CHARLS[[tmpYname]], index = c( envCHARLS$flagCity, envCHARLS$flagT ) )
}

# ---------------------------------------
# SECTION 4: VIF computing
cat("\nSection 4: VIF OF FINAL SPECIFICATIONS\n-----------------------------------------------\n")
# NOTE: up to now, we have finished the variable selection for CHARLS dataset;
#       the results are saved in li_PCAk_CHARLS, li_PCAres_CHARLS, li_Eq_CHARLS etc;
#       then we compute VIF for each specification and print:
cat("up to now, we have finished the variable selection for CHARLS dataset.")
cat("then we compute VIF for each specification and print:\n")
# -------
li_VIF_CHARLS <- list()  # a list to save VIF results
for(tmpYname in envCHARLS$Ynames){
    # get temp dataset
    tmp <- li_Dat_CHARLS[[tmpYname]]
    # compute VIF
    li_VIF_CHARLS[[tmpYname]] <- car::vif( lm( li_Eq_CHARLS[[tmpYname]], tmp ) )
    # print
    print(li_VIF_CHARLS[[tmpYname]]); cat("----------------------------\n")
}
# output to xlsx
openxlsx::write.xlsx( li_VIF_CHARLS, paste(sep="",envCHARLS$Output,"VIF_CHARLS.xlsx") )

# --------------------------------
# SECTION 6: GARBAGE COLLECTION
rm( tmp, tmpXname, tmpYname, df_SignifSingle )


#st xt

library(RColorBrewer)
library(ggrepel)
library(ggplot2)
#display.brewer.all(type = "qual")

#---colors---
dark_col<-brewer.pal(12, "Paired")[c(8,2,4)]  #orange blue green
light_col<-brewer.pal(12, "Paired")[c(7,1,3)]  #orange blue green
names(dark_col)<-names(light_col)<-c('st','ut','xt')

#---load_annotation---
gencode<-read.table('~/../Dropbox/annotation/encode/gencode.v32.GRCh38.txt',header = T,stringsAsFactors = F)
gencode<-gencode[,c('geneid','chr','left','right','genename')]

#---load_associations---
st<-read.csv('~/../Dropbox/DansPaper/data/apply_gwas/LDLq_st_Liver.csv',header = T,stringsAsFactors = F)
xt<-read.csv('~/../Dropbox/DansPaper/data/apply_gwas/LDLq_xt_Liver.csv',header = T,stringsAsFactors = F)

pvalue.extreme <- function(z) {
  log.pvalue <- log(2) + pnorm(abs(z), lower.tail = FALSE, log.p = TRUE)
  log10.pvalue <- log.pvalue/log(10) ## from natural log to log10
  mantissa <- 10^(log10.pvalue %% 1)
  exponent <- log10.pvalue %/% 1

  logp<-log10.pvalue*-1
  return(logp)
  ##return(sprintf("p value is %1.2f times 10^(%d)",mantissa,exponent))
}

st$plog<-pvalue.extreme(st$zscore)
xt$plog<-pvalue.extreme(xt$zscore)

st<-st[,c(1,ncol(st))];colnames(st)<-c('geneid','plog')
st$know_col=dark_col[1];st$add_col=light_col[1];st$order=3;st$model='PrediXcan'
xt<-xt[,c(1,ncol(xt))];colnames(xt)<-c('geneid','plog')
xt$know_col=dark_col[3];xt$add_col=light_col[3];xt$order=1;xt$model='XT-SCAN'

df<-rbind(st,xt)
df<-merge(gencode,df,by='geneid')

df$pos<-(df$left+df$right)/2

df$chr=as.numeric(sapply(df$chr,function(x) sub('^...','',x)))

#---generate_pos---
chr_box<-as.data.frame(matrix(data=NA,nrow=22,ncol=3))
chr_df<-df[df$chr==1,]
chr_box[1,1]<-max(chr_df$pos)
chr_box[1,2]<-0
chr_box[1,3]<-chr_box[1,1]/2

for (i in 2:22){
  chr_df<-df[df$chr==i,]
  chr_box[i,1]<-max(chr_df$pos)
  chr_box[i,2]<-max(chr_df$pos)+chr_box[i-1,2]
  df[which(df$chr==i),'pos']<-df[which(df$chr==i),'pos']+chr_box[i,2]
  chr_box[i,3]<-chr_box[i,2]+chr_box[i,1]/2
}

#---rm_non_sig_genes---
df<-df[df$plog>log(0.05,10)*-1,]

#---load know genes---
know<-read.csv('~/../Dropbox/XTSCAN/glgc/knowgenes.csv',header = T,stringsAsFactors = F)
df[!(df$genename %in% know$genename),'genename']<-'ZZZ'
df$col=ifelse(df$genename %in% know$genename,df$know_col,df$add_col)

#---order---
df<-df[order(df$genename,df$order,decreasing = T),]
df$genename<-ifelse(df$genename=='ZZZ',NA,df$genename)

#---name---
df$group<-ifelse(!(df$genename %in% know$genename),paste0('Additional ',df$model),paste0('Known ',df$model))
df$group<-as.factor(df$group)

#---reorder legend---
df$group <- factor(df$group, levels = rev(levels(df$group)))

#---ggplot---

png('~/../Dropbox/DansPaper/figures/tmp/ukbb_ldl_man.png',width = 2200,height = 1000,res=250)

set.seed(1)
ggplot(df, aes(x=pos, y=plog, label=genename)) +
  scale_x_continuous(breaks=chr_box$V3, labels = c(as.character(seq(1,15)),' ','17','','19','','21','')) +  #x axis

  scale_y_continuous(breaks=c(1,2,3,5,10,20,30,50,100,200,300,500),trans='log10') +  #x axis

  #scale_y_continuous(trans='log10') +  #y axis log
  geom_point(data = df, aes(x = pos, y = plog, color = group, shape=group,fill=group)) + #points
  scale_fill_manual(values = c("Known PrediXcan"=as.character(dark_col[1]), 'Known XT-SCAN'=as.character(dark_col[3]),"Additional PrediXcan"=as.character(light_col[1]), 'Additional XT-SCAN'=as.character(light_col[3]))) +
  scale_color_manual(values = c("Known PrediXcan"='black', 'Known XT-SCAN'='black',"Additional PrediXcan"=as.character(light_col[1]),'Additional XT-SCAN'=as.character(light_col[3]))) +
  scale_shape_manual(values = c("Known PrediXcan"=21, 'Known XT-SCAN'=21,"Additional PrediXcan"=20, 'Additional XT-SCAN'=20)) +

  labs(x = "Chromosome", y = "-log(P)", title = "") +
  theme_bw() +  #rm background
  theme(panel.grid =element_blank()) +  #rm grids
  theme(legend.position= "right",legend.title = element_blank()) + #set legend
  geom_label_repel( #non overlapped labels
    size=2,
    fill=rgb(255, 255, 255, 200, maxColorValue=255),
    colour = df$col,
    direction='y', #only work on Y-axis
    nudge_x=1.5e8, #shift to the right
    segment.alpha = 0.2,  #transparent of segment
    min.segment.length = 0.5,
    fontface='bold.italic'
  )

dev.off()

#bar

png('~/../Dropbox/DansPaper/figures/tmp/ukbb_bar.png',width = 600,height = 1000,res=180)
par(mfcol=c(1,2),mar=c(5,4,3,1),mgp=c(2.5,0.75,0.25))

#known
known<-as.numeric(table(df$group))[c(2,1)]

bar<-barplot(known, border=F,
             names.arg=c('PrediXcan','XT-SCAN'),cex.names = 0.8,
             las=2,
             col=c(dark_col['st'],dark_col['xt']),
             main=paste0("Known \n genes"),cex.main=1,
             ylim = c(0,max(known)*1.3),
             ylab = 'N of genes',
             cex.axis = 0.8)

#text
text(bar,known+max(known)/15,labels = known,cex = 0.8)

#additional
additional<-as.numeric(table(df$group))[c(4,3)]

bar<-barplot(additional, border=F,
             names.arg=c('PrediXcan','XT-SCAN'),cex.names = 0.8,
             las=2,
             col=c(light_col['xt'],light_col['st']),
             main=paste0("Additional \n genes"),cex.main=1,
             ylim = c(0,max(additional)*1.3),
             ylab = 'N of genes',
             cex.axis = 0.8)

#text
text(bar,additional+max(additional)/15,labels = additional,cex = 0.8)

dev.off()


# ggplot-01.r
# RBLandau 20150923
# Try ggplot2 to see if it makes prettier pictures than vanilla plot.

dall <- data.frame(read.table("dataforndsa-00.txt",header=TRUE))
d <- dall[dall$lifem>=10,]
c1 <- d[d$copies==1,]
c2 <- d[d$copies==2,]
c3 <- d[d$copies==3,]
c4 <- d[d$copies==4,]
c5 <- d[d$copies==5,]
safelog <- function(x){return(log10(x+1)) }
safe    <- function(x){return(x+0.5)}

#qplot(x=lifem,y=loss.a0,data=c3) + scale_x_log10() + scale_y_log10() + annotation_logticks()

makeplot <- function(ncopies,cdata,titlelines,a0x,a0y,ayx,ayy,aqx,aqy) {
    p <- ggplot(data=cdata,aes(x=lifem,y=safe(loss.a0)))
    p <- p + scale_x_log10() + scale_y_log10()
    p <- p + annotation_logticks()
    # Axis labels and title.
    p <- p + labs(
            x="sector lifetime (megahours)",
            y="permanent document losses from 10,000 docs",
            title=titlelines
            )
    p <- p + theme(
            axis.text=element_text(size=12),
            axis.title=element_text(size=18),
            plot.title=element_text(size=22,face="bold"),
            panel.border = element_rect(color = "black", fill=NA, size=1)
            )
    # Unaudited points.
    p <- p+geom_point(color="black",size=4) + geom_line(linetype="dashed",color="black",size=1)
    if (ncopies > 1)
    {
        # Quarterly audit points
        p <- p+geom_point(data=cdata,aes(x=lifem,y=safe(loss.aq)),color="blue",size=4)
        p <- p+geom_line(data=cdata,aes(x=lifem,y=safe(loss.aq)),color="blue",size=1)
        # Annual audit points
        p <- p+geom_point(data=cdata,aes(x=lifem,y=safe(loss.ay)),color="red",size=4)
        p <- p+geom_line(data=cdata,aes(x=lifem,y=safe(loss.ay)),color="red",size=1)
    } #endif ncopies>1
    # Annotations
    p <- p+annotate("text",x=a0x,y=a0y,label="Unaudited",size=7)
    if (ncopies > 1)
    {
        p <- p+annotate("text",x=ayx,y=ayy,label="Annual audit",color="red",size=7)
        p <- p+annotate("text",x=aqx,y=aqy,label="Quarterly audit",color="blue",size=7)
    } #endif ncopies>1
    gplot <- p
    return(gplot)
} #endfunction

# C1
g1plot <- makeplot(1,c1,"Copies = 1 \n All losses are permanent losses", 35,500,0,0,0,0)
png(filename="g1.png",width=860,height=452,pointsize=16)
g1plot
dev.off()

# C2
g2plot <- makeplot(2,c2,"Copies = 2 \n Losses decline a lot with increased auditing", 35,500,19,200,15,9)
png(filename="g2.png",width=860,height=452,pointsize=16)
g2plot
dev.off()

# C3
g3plot <- makeplot(3,c3,"Copies = 3 \n Losses decline slightly with increased auditing", 21,300,16,12,13,1.0)
png(filename="g3.png",width=860,height=452,pointsize=16)
g3plot
dev.off()

# C4
g4plot <- makeplot(4,c4,"Copies = 4 \n Losses decline only very slightly with increased auditing", 20,100,16,1.8,13,0.8)
png(filename="g4.png",width=860,height=452,pointsize=16)
g4plot
dev.off()

# C5
g5plot <- makeplot(5,c5,"Copies = 5 \n Losses are probably negligible with any auditing", 21,20,12,1.2,13,0.8)
png(filename="g5.png",width=860,height=452,pointsize=16)
g5plot
dev.off()

#END


#------------------------------------------------------------------------------
#' Create new ogawa forest plot
#'
#' Create new plot for ogawa forest plot map.
#'
#' @param xmin
#' a minimum value of x coordinate.
#' @param xmax
#' a maximum value of x coordinate.
#' @param ymin
#' a minimum value of y coordinate.
#' @param ymax
#' a maximum value of y coordinate.
#' @param label.pos.x
#' a numeric vector with two elements. The first element denotes distance
#' (% of shorter axis) between small X axis labels and the grid and the
#' second denotes distance between large X axis labels and the grid.
#' @param label.pos.y
#' a numeric vector with two elements. The first element denotes distance
#' (% of shorter axis) between small Y axis labels and the grid and the
#' second denotes distance between large Y axis labels and the grid.
#'
#' @return an \code{ogara.plot} object which can be passed to other functions.
#'
#' @examples
#' x <- create.ogawa.plot()
#' add.grid(x)
#'
#' @export
#------------------------------------------------------------------------------
create.ogawa.plot <- function(
	xmin = 0, xmax = 300, ymin = 0, ymax = 200,
	label.pos.x = c(0.02, 0.05), label.pos.y = c(0.02, 0.06)
) {
	x <- create.object(xmin, xmax, ymin, ymax, label.pos.x, label.pos.y)
	adjustment <- min(abs(x$xmax - x$xmin), abs(x$ymax - x$ymin))
	x.margin <- adjustment * label.pos.y[2]
	y.margin <- adjustment * label.pos.x[2]
	plot(
		NA, type = "n", xlim = c(x$xmin - x.margin, x$xmax),
		ylim = c(x$ymin, x$ymax + y.margin),
		bty = "n", axes = FALSE, xlab = "", ylab = ""
	)
	return(x)
}

#------------------------------------------------------------------------------
#  Create ogawa.plot object.
#------------------------------------------------------------------------------
create.object <- function(xmin, xmax, ymin, ymax, label.pos.x, label.pos.y) {
	mod5 <- function(x) x - (x %% 5)
	object <- list(
		xmin = mod5(xmin), xmax = mod5(xmax), ymin = mod5(ymin),
		ymax = mod5(ymax), label.pos.x = label.pos.x, label.pos.y = label.pos.y
	)
	class(object) <- "ogawa.plot"
	return(object)
}

#------------------------------------------------------------------------------
#' Add grid lines for the plot
#'
#' A low level graphic function draws grid lines for the ogawa plot map.
#'
#' @param x
#' an \code{ogawa.plot} object.
#' @param adds.sq.legend
#' if TRUE, adds an legend for sub-quadrats.
#' @param draws.1.2ha
#' if TRUE, draws the 1.2ha core plot region.
#' @param grid.level
#' an integer representing level of grid line to draw.
#' \code{0}: draw all grid lines, \code{1}: omit 5m grid lines,
#' \code{2}: omit 5m and 10m grid lines, and \code{4}: omit all grid lines.
#'
#' @export
#' @importFrom graphics rect
#' @importFrom graphics segments
#' @importFrom graphics text
#' @importFrom grDevices dev.hold
#' @importFrom grDevices dev.flush
#------------------------------------------------------------------------------
add.grid <- function(
	x, adds.sq.legend = TRUE, draws.1.2ha = TRUE, grid.level = 0
) {
	stopifnot(grid.level %in% 0:3)
	dev.hold()
	do.call(
		draw.grid, c(x, list(grid.level = grid.level))
	)
	do.call(draw.labels, x)
	if (draws.1.2ha) {
		do.call(draw.1.2ha, x)
	}
	if (adds.sq.legend) {
		do.call(draw.sq.legend, x)
	}
	dev.flush()
}

#------------------------------------------------------------------------------
#  Draw grid lines.
#------------------------------------------------------------------------------
draw.grid <- function(xmin, xmax, ymin, ymax, grid.level, ...) {
	# Draw outline.
	rect(xmin, ymin, xmax, ymax, lwd = 2)
	# Prepare grid lines.
	x <- (xmin / 5):(xmax / 5)
	v.lines <- data.frame(
		x1 = x * 5, y1 = ymin, x2 = x * 5, y2 = ymax,
		lwd = ifelse(x %% 4 == 0, 2, 1),
		level = ifelse(x %% 4 == 0, 3, ifelse(x %% 2 == 0, 2, 1))
	)
	y <- (ymin / 5):(ymax / 5)
	h.lines <- data.frame(
		x1 = xmin, y1 = y * 5, x2 = xmax, y2 = y * 5,
		lwd = ifelse(y %% 4 == 0, 2, 1),
		level = ifelse(y %% 4 == 0, 3, ifelse(y %% 2 == 0, 2, 1))
	)
	l <- rbind(v.lines, h.lines)
	# Filter grid lines.
	l <- l[l$level > grid.level, ]
	# Draw lines.
	segments(l$x1, l$y1, l$x2, l$y2, lwd = l$lwd)
}

#------------------------------------------------------------------------------
#  Draw labels.
#------------------------------------------------------------------------------
draw.labels <- function(
	xmin, xmax, ymin, ymax, label.pos.x, label.pos.y, ...
) {
	adjust.x <- abs(xmax - xmin)
	adjust.y <- abs(ymax - ymin)
	# X-axis label (small).
	x <- (xmin / 10):(xmax / 10)
	xs <- data.frame(
		x = x * 10, y = ymax + adjust.y * label.pos.x[1], labels = x + 1,
		cex = 0.7, font = 1
	)
	# X-axis label (large).
	x <- (xmin / 20 + 1):(xmax / 20)
	xl <- data.frame(
		x = x * 20 - 10, y = ymax + adjust.y * label.pos.x[2],
		labels = LETTERS[x], cex = 1.5, font = 2
	)
	# Y-axis label (small).
	y <- (ymin / 10):(ymax / 10)
	ys <- data.frame(
		x = xmin - adjust.x * label.pos.y[1], y = y * 10,
		labels = ymax / 10 - y + 1, cex = 0.7, font = 1
	)
	# Y-axis label (large).
	y <- (ymin / 20 + 1):(ymax / 20)
	yl <- data.frame(
		x = xmin - adjust.x * label.pos.y[2],
		y = ymax + 10 - 2 * y * 10 + ymin, labels = y, cex = 1.5, font = 2
	)
	do.call(text, rbind(xs, xl, ys, yl))
}

#------------------------------------------------------------------------------
#  Draw 1.2ha region.
#------------------------------------------------------------------------------
draw.1.2ha <- function(xmin, xmax, ymin, ymax, ...) {
	rect(
		max(xmin, 120), max(ymin, 60), min(xmax, 220), min(ymax, 180), lwd = 5
	)
}

#------------------------------------------------------------------------------
#  Draw sub-quadrat region.
#------------------------------------------------------------------------------
draw.sq.legend <- function(xmin, xmax, ymin, ymax, ...) {
	for (i in 1:4) {
		text(
			xmin + 5 + (i + 1) %% 2 * 10, ymax - 5 - ((i) %/% 3) * 10,
			letters[i], cex = 1.5, font = 2
		)
		text(
			xmin + 22.5 + (i + 1) %% 2 * 5, ymax + 2.5 - (i + 1) %/% 2 * 5,
			i, cex = 0.9
		)
	}
}

#------------------------------------------------------------------------------
#' Fill quadrats
#'
#' Low-level graphic function fills quadrats specifyied by quadrat codes.
#'
#' @param Q quadrat codes.
#' @param ... graphic parameters passed to \code{\link[graphics]{rect}}.
#'
#' @export
#' @importFrom graphics rect
#------------------------------------------------------------------------------
fill.q <- function(Q, ...) {
	r <- q.to.rect(Q)
	rect(r$x1, r$y1, r$x2, r$y2, ...)
}

#------------------------------------------------------------------------------
#' Create a map of ogawa forest plot with colored quadrats
#'
#' @param Q
#' quadrat codes to be filled.
#' @param adds.sq.legend
#' if TRUE, adds an legend for sub-quadrats.
#' @param draws.1.2ha
#' if TRUE, draws the 1.2ha core plot region.
#' @param ...
#' graphic parameters passed to \code{\link[graphics]{rect}} to draw quadrats.
#'
#' @export
#------------------------------------------------------------------------------
create.quadrat.map <- function(
	Q, adds.sq.legend = TRUE, draws.1.2ha = TRUE, ...
) {
	x <- create.ogawa.plot()
	fill.q(Q, ...)
	add.grid(x, adds.sq.legend, draws.1.2ha)
}


tanimoto_analysis <- function(min.tx, K.values, MW, WT, minimum_threshold, similarity = 'both', filename, blind = FALSE) {
    # -----------------------------------------------------------------------------
    # # PARAMETERS:
    #     filename                name of file under which to same the results of the predictions
    #     min.tx                  minimal number of taxon for empirical food webs to be included in the analysis
    #     K.values                Kc and Kr values to test in the KNN algorithm
    #     MW                      Minimum weight for candidate resources to be included as predictions
    #     WT                      Weights for the two-way Tanimoto algorithm
    #     blind                   Whether the analysis whould be blind, i.e. no a priori information for taxa in catalog
    #     minimum_threshold       Minimum similarity threshold for similar taxa to be considered as candidate resources
    #     similarity              String character either being c('consumer', 'resource', 'both') for the similarity measurements
    #
    # # OUTPUT:
    #     tanimoto_analysis       List of predictions for all parameters tested
    # -----------------------------------------------------------------------------
    load("./RData/Tanimoto_data.RData")
    load("./RData/interactions_source.RData")
    load("./RData/S0_catalog.RData")

    if(similarity == 'both') { # For similarity matrices already evaluated
        suppressMessages(load("./RData/Similarity_consumers.RData"))
        suppressMessages(load("./RData/Similarity_resources.RData"))
    } else if(similarity == 'consumer') {
        suppressMessages(load("./RData/Similarity_consumers.RData"))
    } else if (similarity == 'resource') {
        suppressMessages(load("./RData/Similarity_resources.RData"))
    }

    # setting up the analyses for multiple communities
    # Data for communities on which to test the algorithm
        Cm <- unique(interactions_sources[, 'source'])
        communities <- vector("list", length(Cm))
        names(communities) <- Cm

        # Taxa list per community to predict
            for(i in 1:length(communities)) {
                Ci <- which(interactions_sources[, 'source'] == Cm[i])
                S1 <- unique(c(interactions_sources[Ci, 'consumer'], interactions_sources[Ci, 'resource']))

                if(length(which(!S1 %in% S0_catalog)) > 0) {
                    print('Taxa in C[i] are not all included in taxa list S0')
                    break
                }

                communities[[i]] <- S1
            }

    # Substracting GloBI interactions for this portion
        Cm.lg <- numeric()
        for(i in 1:length(communities)) {
            Cm.lg <- c(Cm.lg,length(communities[[i]]))
        }

        to.delete <- c(which(Cm.lg < min.tx), which(Cm.lg > 1000)) # > 1000 is for GloBI

        Cm <- Cm[-to.delete]
        for(i in rev(to.delete)) {
            communities[[i]] <- NULL
        }
        names(communities) <- Cm

    # Setting up lists to store the results
        wt.init <- c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1)
        wt.remove <- which(!wt.init %in% WT)# selecting a subset of similarity matrices
        for(i in rev(wt.remove)) {
            if(similarity == 'both') { # For similarity matrices already evaluated
                similarity.consumers[[i]] <- NULL
                similarity.resources[[i]] <- NULL
            } else if(similarity == 'consumer') {
                similarity.consumers[[i]] <- NULL
            } else if (similarity == 'resource') {
                similarity.resources[[i]] <- NULL
            }
        }

        sim.wt <- WT
        Tanimoto_analysis <- vector("list",length(sim.wt))
        names(Tanimoto_analysis) <- sim.wt
        for(i in 1:length(sim.wt)) {
            Tanimoto_analysis[[i]] <- vector("list", length(Cm))
            names(Tanimoto_analysis[[i]]) <- Cm
        }

        # List to store results of multiple K values
        K <- vector("list", length(K.values))
        for(i in 1:length(K.values)) {
            K[[i]] <- Tanimoto_analysis
        }
        Tanimoto_analysis <- K
        names(Tanimoto_analysis) <- K.values
        remove(K)

        min.wt <- vector("list", length(MW))
        for(i in 1:length(MW)) {
            min.wt[[i]] <- Tanimoto_analysis
        }
        Tanimoto_analysis <- min.wt
        names(Tanimoto_analysis) <- MW
        remove(min.wt)

    # Initial time save for temporary saving in case analysis fails mid process
    file.to.save <- serialNext("./Analyses/Tanimoto_temp/Tanimoto_analysis.RData")
    save(x = Tanimoto_analysis, file = file.to.save)

    iteration <- 1
    init.time <- Sys.time()
    pb <- txtProgressBar(min = 0,max = length(Cm) * length(WT) * length(K.values) * length(MW), style = 3)
    for(n in 1:length(MW)) {
        mw <- MW[n]
        for(m in 1:length(K.values)) {

            # Tanimoto analysis with different weights for different communities
                # Parameters:
                    Kc <- K.values[m]  # Integer, how many neighbors to select for consumers
                    Kr <-  K.values[m]  # Integer, how many neighbors to select for resources
                    # MW = minimum_weight  # Mimimum weight to accept a candidate as a prey
                #   wt  Weight of traits in similarity measurement
                #   S0  A large set of species and their preys, with column structure ['taxon', 'taxonomy', 'resource', 'non-resource']
                #   S1  The subset of S0 where we want to predict new preys, string vector with taxa name

                # Output:
                #   A vector of sets of resources for each taxon
                for(i in 1:length(WT)){ #1st loop for all types of wt values
                    wt <- WT[i]
                    for(j in 1:length(Cm)) { #2nd loop for all C[i]
                        S1 <- communities[[j]]
                        S0 <- S0_catalog

                        if(similarity == 'both') { # For similarity matrices already evaluated
                            similarity.consumer <- similarity.consumers[[i]]
                            similarity.resource <- similarity.resources[[i]]
                        } else if(similarity == 'consumer') {
                            similarity.consumer <- similarity.consumers[[i]]
                        } else if (similarity == 'resource') {
                            similarity.resource <- similarity.resources[[i]]
                        }

                        # Two choices here:
                        #   1. The analysis is blind, which means we remove all the information available in the catalogue for all species in S1
                        #   2. The analysis takes into account preexisting information already contained in the catalogue

                        # 1. Blind analysis, removing all information on taxa in S1 from S0 (rownames need to == taxa name)
                        if(blind == TRUE) {
                            for(k in 1:length(S1)) {
                              S0[S1[k], 'resource'] <- ""
                              S0[S1[k], 'non-resource'] <- ""
                              S0[S1[k], 'consumer'] <- ""
                              S0[S1[k], 'non-consumer'] <- ""
                            }

                        # 2. Preexisting information kept to inform algorithm
                        } else { # blind == FALSE

                            interactions <- interactions_sources[-which(interactions_sources[, 'source'] == Cm[j]), 1:3]

                            # Only modifying those that are loosing data from the catalogue, less time
                                to.change <- numeric()
                                for(k in 1:length(S1)) {
                                    to.change <- c(to.change, which(interactions[, 'consumer'] == S1[k]), which(interactions[, 'resource'] == S1[k]))
                                }
                                to.change <- unique(to.change)

                            # Modifying sets of resources and non-resources for taxa in S1
                                interactions <- interactions[to.change, ]
                                rownames(interactions) <- seq(1,nrow(interactions))
                                resource_set <- consumer_set_of_resource(consumer = interactions[, 'consumer'],
                                                                          resource = interactions[, 'resource'],
                                                                          inter_type = interactions[, 'inter'])

                                consumer_set <- resource_set_of_consumer(consumer = interactions[, 'consumer'],
                                                                        resource = interactions[, 'resource'],
                                                                        inter_type = interactions[, 'inter'])

                            # From binary interactions catalogue with consumer, resources, interaction or non-interaction (rownames need to == taxa name)
                                for(k in 1:nrow(resource_set)) {
                                  S0[resource_set[k, 'consumer'], 3] <- resource_set[k, 'resource']
                                  S0[resource_set[k, 'consumer'], 4] <- resource_set[k, 'non-resource']
                                }
                                for(k in 1:nrow(consumer_set)) {
                                  S0[consumer_set[k, 'resource'], 5] <- consumer_set[k, 'consumer']
                                  S0[consumer_set[k, 'resource'], 6] <- consumer_set[k, 'non-consumer']
                                }
                            remove(interactions, resource_set, to.change)
                        } #if blind or not blind

                        # Recalculate similarity
                            similarity.consumer <- similarity_taxon_predict(S0 = S0,
                                                                                S1 = S1,
                                                                                wt = wt,
                                                                                similarity.matrix = similarity.consumer,
                                                                                taxa = 'consumer')

                            similarity.resource <- similarity_taxon_predict(S0 = S0,
                                                                                S1 = S1,
                                                                                wt = wt,
                                                                                similarity.matrix = similarity.resource,
                                                                                taxa = 'resource')

                        # Predicting interactions
                            Tanimoto_analysis[[n]][[m]][[i]][[j]] <- two_way_tanimoto_predict(Kc = Kc,
                                                                                Kr = Kr,
                                                                                S0 = S0,
                                                                                S1 = S1,
                                                                                MW = mw,
                                                                                similarity.consumer = similarity.consumer,
                                                                                similarity.resource = similarity.resource,
                                                                                minimum_threshold = minimum_threshold)

                        save(x = Tanimoto_analysis, file = file.to.save)
                        remove(S0, S1, similarity.consumer, similarity.resource)
                        iteration <- iteration + 1
                        setTxtProgressBar(pb, iteration)
                    }#2nd loop for all C[i]

                    save(x = Tanimoto_analysis, file = file.to.save)
                    remove(wt)

                }#1st loop for all types of wt values

        }#m
    }#n
    close(pb)
    print(Sys.time() - init.time)

    save(x = Tanimoto_analysis, file = paste('./Analyses/',filename,'.RData',sep=''))

    return(Tanimoto_analysis)
}


#####################################################################################
#
# Mark Cembrowski, Janelia Farm, January 28 2014
#
# The following script returns a barplot of expression for a given gene, with
# confidence intervals as error bars.
#
# 1011515: updated to include options on CPM-based, rather than FPKM-based, data.
#
# INPUTS:
#  theGene: character.  Name of gene to plot.
# OPTIONAL INPUTS:
#  replicates=F: logical.  Display data points of replicates?
#  mask=c(): character.  Mask particular samples from being plotted?  Should not be
#	used in conjunction with unmask option.
#  unmask=c(): character.  Include only particular samples on plot?  Should not be
# 	used in conjunction with mask option.
#  rMax=-1: variable.  Send the max range on the graph.
#
#####################################################################################

geneBarplot <- function(theGene,replicates=F,mask=c(),unmask=c(),rMax=-1,doFpkm=T){
	if(length(mask)*length(unmask)>0.1){
		stop('Cannot use mask and unmask options at same time.')
	}

	if(!isGeneId(theGene)){
		# Transform to Ensembl ID.
		theGene <- symToId(theGene)[[1]] # Successful hits.
	}

	# Get FPKM value for gene.
	if(doFpkm){
		df <- subset(fpkmPool,gene_id==theGene)
	}else{
		df <- subset(cpmPool,gene_id==theGene)
	}

	# Get replicates.
	if(doFpkm){
		dfRep <- subset(fpkmRep,gene_id==theGene)
	}else{
		dfRep <- subset(cpmRep,gene_id==theGene)
	}

	# Mask samples, if selected.
	if(length(mask)>0.1){
		toMask <- grep(paste(mask,collapse='|'),df$sample_name)
		if(length(toMask)<0.1){
			stop('All requested masked sample(s) not found.')
		}

		df <- df[-toMask,]

		if(replicates){
			toMask <- grep(paste(mask,collapse='|'),dfRep$sample_name)
			dfRep <- dfRep[-toMask,]
		}
	}

	# Show only unmasked samples, if selected.  This operation is the opposite
	# of mask; ie, only the unmasked samples will be shown.
	if(length(unmask)>0.1){
		toUnmask <- grep(paste(unmask,collapse='|'),df$sample_name)
		if(length(toUnmask)<0.1){
			stop('All requested unmasked sample(s) not found.')
		}

		df <- df[toUnmask,]

		if(replicates){
			toUnmask <- grep(paste(unmask,collapse='|'),dfRep$sample_name)
			dfRep <- dfRep[toUnmask,]
		}
	}

	# Generalise column 'fpkm' or 'cpm' name to 'metric'.
	if(doFpkm){
		metricColPool <- grep('fpkm',colnames(df))
		metricColRep <- grep('fpkm',colnames(dfRep))
	}else{
		metricColPool <- grep('cpm',colnames(df))
		metricColRep <- grep('cpm',colnames(dfRep))
	}
	colnames(df)[metricColPool] <- 'metric'
	colnames(dfRep)[metricColRep] <- 'metric'

	# Plot.
	p <- ggplot(df,aes(x=sample_name,y=metric,fill=sample_name))
	p <- p + geom_bar(stat='identity')
	if(replicates){
		p <- p + geom_point(aes(x=sample_name,y=metric),size=3,
			shape=18,colour='black',data=dfRep)
	}

	if(doFpkm){
		p <- p + geom_errorbar(aes(ymin=conf_lo,ymax=conf_hi,group=1),width=0.5)
	}else{
		# No CI for CPM.
	}

	if(rMax>0){
		p <- p + ylim(c(0,rMax))
	}

	p <- p + xlab('Cell type')
	if(doFpkm){
		p <- p + ylab('FPKM')
	}else{
		p <- p + ylab('CPM')
	}
	p <- p + ggtitle(idToSym(theGene))
	p <- p + theme_bw() + theme(legend.position='none')

	print(p)
}


library(scoringutils)
library(covidHubUtils)
library(dplyr)
library(tidyr)
library(lubridate)
library(here)
library(readr)
library(EuroForecastHub)

data_types <- get_hub_config("target_variables")

## only evaluate if the last 4 weeks hae been submitted
restrict_weeks <- 4

suppressWarnings(dir.create(here::here("evaluation")))

## load forecasts --------------------------------------------------------------
forecasts <- load_forecasts(
  source = "local_hub_repo",
  hub_repo_path = here(),
  hub = "ECDC"
) %>%
  # set forecast date to corresponding submission date
  mutate(forecast_date = ceiling_date(forecast_date, "week", week_start = 2) - 1) %>%
  filter(forecast_date >= "2021-03-08") %>%
  rename(prediction = value)

## load truth data -------------------------------------------------------------
raw_truth <- load_truth(truth_source = "JHU",
                        temporal_resolution = "weekly",
                        hub = "ECDC")
# get anomalies
anomalies <- read_csv(here("data-truth", "anomalies", "anomalies.csv"))
truth <- anti_join(raw_truth, anomalies) %>%
  mutate(model = NULL) %>%
  rename(true_value = value)

# remove forecasts made directly after a data anomaly
forecasts <- forecasts %>%
  mutate(previous_end_date = forecast_date - 2) %>%
  left_join(anomalies %>%
              rename(previous_end_date = target_end_date),
            by = c("target_variable",
                   "location", "location_name",
                   "previous_end_date")) %>%
  filter(is.na(anomaly)) %>%
  select(-anomaly, -previous_end_date)

data <- scoringutils::merge_pred_and_obs(forecasts, truth,
                                         join = "full")

latest_date <- today()
wday(latest_date) <- get_hub_config("forecast_week_day")

message("Scoring all forecasts.")

scores <- score_forecasts(
  forecasts = data,
  quantiles = get_hub_config("forecast_type")$quantiles
)

write_csv(scores, here::here("evaluation", "scores.csv"))

## can modify manually if wanting to re-run past evaluation
re_run <- FALSE
if (re_run) {
  start_date <- as.Date("2021-03-08") + 4 * 7
} else {
  start_date <- latest_date
}
report_dates <- seq(start_date, latest_date, by = "week")

for (chr_report_date in as.character(report_dates)) {
  report_date <- as.Date(chr_report_date)
  eval_filename <-
    here::here("evaluation", paste0("evaluation-", report_date, ".csv"))

  message("Summarising scores as of ", report_date, ".")

  table <- summarise_scores(
    scores = scores,
    report_date = report_date,
    restrict_weeks = restrict_weeks
  )

  write_csv(table, eval_filename)
}


# Author:  Patrick Reidy
# Purpose: Demo multitaper spectral analysis for Jane Stuart-Smith.
# Date:    2018-05-23

# Modified by:  Michael Goodale
# Purpose: ISCAN Token import/export tutorial
# Date:    2019-05-23

# modifed by: Jane Stuart-Smith
# Purpose: first of all to create stripped script to produce only a few measures for piloting purposes. Have removed a lot of the explanatory stuff from Pat Reidy for me.  Have recorded tips and wrinkles, futher work to do, plus initial comments for protocol here.
# Date: 2020-04-09

# modified by: James Tanner
# Purpose: process input data as command-line arguments
# Date: 2020-09-29

# modified by: James Tanner
# Purpose: convert to functions
# Data: 2021-03-28

started_at <- date()

library(ggplot2)
library(magrittr)
library(multitaper)
library(tibble)
library(tuneR)
library(doParallel)
library(foreach)
library(argparse)
library(stringr)
library(svMisc)

## Process comamand-line arguments
parser <- ArgumentParser(description = "Generate multitaper sibilant measurements")
parser$add_argument("input_file", help = "CSV file containing sibilants observations to measure")
parser$add_argument("sound_dir", help = "Path to the top-level directory containg the audio files")
parser$add_argument("output_dir", help = "Directory to write the mts-measured CSV file")
parser$add_argument("--directories", "-d", help = "The audio file contains speaker-level subdirectories", action = "store_true", default = FALSE)
parser$add_argument("--numbers", "-n", help = "Speaker names are defined with numbers (integers) instead of letters", action = "store_true", default = FALSE)
parser$add_argument("--speakers", "-s", help = "Use speaker codes for audio file names", action = "store_true", default = FALSE)
args <- parser$parse_args()

# The R files in the ./auxiliary subdirectory of this demo define a handful of
# S4 classes, generics, and methods that wrap functionality from the tuneR and
# multitaper packages.
# You'll need to source the R files in this order because, e.g., definitions
# in later files depend on S4 classes defined in earlier files.
source('./auxiliary/Waveform.R') # For reading .wav files.
source('./auxiliary/Spectrum.R') # Base methods shared by all spectrum-like objects.
source('./auxiliary/Periodogram.R') # For estimating spectra using the periodogram.
source('./auxiliary/DPSS.R') # Windowing functions for multitaper spectra.
source('./auxiliary/Multitaper.R') # For estimating spectra using multitaper method.

# JM: to rebuild most of the Multitaper S4 object for using Pat's measurement functions at a later time:
rebuildMultitaper <- function(token_id, corpus_data, all_multitapers){
    new(Class = 'Multitaper',
        values   = as.numeric(all_multitapers$values[corpus_data$phone_id==token_id,]),
        binWidth = all_multitapers$binWidth,
        nyquist  = all_multitapers$nyquist,
        k        = all_multitapers$k,
        nw       = all_multitapers$nw)
        # tapers   = .dpss)
}

rebuildMultitaperByRow <- function(row, all_multitapers){
    new(Class = 'Multitaper',
        values   = as.numeric(all_multitapers$values[row,]),
        binWidth = all_multitapers$binWidth,
        nyquist  = all_multitapers$nyquist,
        k        = all_multitapers$k,
        nw       = all_multitapers$nw)
        # tapers   = .dpss)
}

get_file_path <- function(corpus_data, row, sound_file_directory, subdirs){

    if (args$speakers){
        sound_file <- paste0(corpus_data[row, "speaker"], '.wav')
    }else if ('sound_file_name'%in%names(corpus_data)){
        sound_file <- paste0(gsub(".WAV", "", corpus_data[row, "sound_file_name"]), '.wav')
    }else if ('recording'%in%names(corpus_data)){
        sound_file <- paste0(corpus_data[row, "recording"], '.wav')
    }else{
        sound_file <- paste0(corpus_data[row, "discourse"], '.wav')
    }
    sound_file <- gsub('.wav.wav','.wav',sound_file) # because some of them already have .wav at the end
    if (subdirs){
       file.path(sound_file_directory, corpus_data[row, "speaker"], sound_file)
    }else{
       file.path(sound_file_directory, sound_file)
    }
}

read_dataset <- function(filepath, sound_dir) {
	## extract corpus name from dataset filename
	cat("File: ", filepath, "\n")
    corpus_name <- str_match(filepath, "([A-Za-z0-9_-]*)\\_sibilants\\.csv")[,2]
    cat("Corpus name:", "\t", corpus_name, "\n")

	# get the directory of the sound file and
	# read in the CSV
    sound_file_directory <- sound_dir
    corpus_data <- read.csv(filepath)

    if (args$numbers){
        corpus_data$discourse <- sprintf("%03d",corpus_data$discourse)
    }
	return(list(corpus_data, corpus_name, sound_file_directory))
}

get_phone_time <- function(data, time, row) {
	t <- data[row, time]
	return(t)
}

# https://stackoverflow.com/questions/7824912/max-and-min-functions-that-are-similar-to-colmeans
colMax <- function (colData) {
    apply(colData, MARGIN=c(2), max)
}

colSD <- function (colData) {
    apply(colData, MARGIN=c(2), sd)
}

parallelized <- TRUE
n_cores <- 20

measuring <- TRUE

if (measuring){

    ## Get the corpus name from the input file
	dataset = read_dataset(args$input_file, args$sound_dir)
	corpus_data = dataset[[1]]
	corpus_name = dataset[[2]]
	sound_file_directory = dataset[[3]]

    if(parallelized) {
        registerDoParallel(n_cores)
    }else{
        n_cores = 1
    }
    #JM: open the first token to gather information
    file_path <- get_file_path(corpus_data, row=1, sound_file_directory, args$directories)

    begin <- get_phone_time(corpus_data, "phone_begin", 1)
    end <- get_phone_time(corpus_data, "phone_end", 1)
    file_midpoint <- begin + (end-begin) / 2

    sock.x <- readWave(filename = file_path, from = file_midpoint - 0.0125, to = file_midpoint + 0.0125, units='seconds')
    sock.x <- downsample(sock.x, 22050)
    sock <- Waveform(sock.x)
    sock_spectrum <- sock %>% Multitaper(k = 8, nw = 4)

    #JM: save all the multitaper values
    all_multitapers <- list(values = NULL,
                            frequencies = seq(from = 0, to = sock_spectrum@nyquist, by = sock_spectrum@binWidth),
                            binWidth = sock_spectrum@binWidth,
                            nyquist = sock_spectrum@nyquist,
                            k = sock_spectrum@k,
                            nw = sock_spectrum@nw)
    n_values <- length(sock_spectrum@values)
    mts_colnames <- paste0('S',1:n_values)

    corpus_data[,mts_colnames] <- NA

    #Split 0:nrows into (roughly) equal sized batches that are in order
    batch_indices <- rep(0:(n_cores-1), each=(nrow(corpus_data) %/% n_cores))
    batch_indices <- c(rep(0, nrow(corpus_data)-length(batch_indices)), batch_indices)

    batches <- split(1:nrow(corpus_data), batch_indices)

    # corpus_data <- subset(corpus_data, !discourse %in% c('ntn0290b','ntn0200a','ntn0370b','ntn0240a'))

    corpus_data <- foreach(batch=batches, .combine=rbind) %dopar% {
        corpus_data <- corpus_data[batch, ]
        # print(corpus_data)
        for (row in 1:nrow(corpus_data)){
        # for (row in 1:200){

            cat(round(row/nrow(corpus_data),6), "\r")
            #To use for non-speaker directory corpora, just remove the speaker name and "/" from the paste function here.
            #sound_file <- paste(corpus_data[row, "speaker_name"], "/", corpus_data[row, "sound_file_name"], '.wav', sep="")

            # sound_file <- paste(corpus_data[row, "sound_file_name"], '.wav', sep="")
            #JM: to handle column names of csv files made by sibilant.py:

            file_path <- get_file_path(corpus_data, row, sound_file_directory, args$directories)

            begin <- corpus_data[row, "phone_begin"]
            end <- corpus_data[row, "phone_end"]

            file_midpoint <- begin + (end-begin) / 2

            # print(file_path)
            # print(begin)
            # print(end)
            # print(file_midpoint)

            # Read the contents of the wav file.

        	if(!file.exists(file_path)){
        		next
        	}

            # print('a')
            # print(file_path)
            # print (corpus_data[1,1:23])
            #JM: this seems like a more straightforward way to open and downsample, but I may be misunderstanding why it was originally done differently
            # print (paste0("sock.x <- readWave(filename = ",file_path,", from = ",file_midpoint," - 0.0125, to = ",file_midpoint," + 0.0125, units='seconds')"))
            sock.x <- readWave(filename = file_path, from = file_midpoint - 0.0125, to = file_midpoint + 0.0125, units='seconds')
            # print('a1')
            sock.x <- downsample(sock.x, 22050)
            # print('a2')
            sock <- Waveform(sock.x)
            # print('b')

        	#want to run first of all without downsampling. IcE-Can apparently is 44100Hz sampling rate

        	# sock <- Waveform(waveform = file_path, from = file_midpoint - 0.020, to = file_midpoint + 0.020)

        	## this hopefully will downsample for me... NOTE this will also take the 25ms window which is as per K et al.

            #sockb = downsample(socka[length(socka@left)/2+seq(-socka@samp.rate*0.0125,socka@samp.rate*0.0125)], 22050)
            #sockc = Waveform(waveform = sockb)
            #sock = sockc

           #Estimate the spectrum of sock using the multitaper method. no preemphasis or zeropadding.
              sock_spectrum <-
              sock %>%
              #PreEmphasize(alpha = 0.5) %>% # optional
              #ZeroPad(lengthOut = sampleRate(sock)) %>% # again, optional
              Multitaper(k = 8, nw = 4)

        # print('c')
    ## measures for pilot1: cog, peak_full, peak_mid

    ## measures intended:
    ## cog: taken across whole range, so lower cutoff 550Hz, as K et al, to nyquist
    ## spread; taken across whole range, so lower cutoff 550Hz, as K et al, to nyquist [not skew and kurtosis ?]
    ## peak_full: across whole range, so lower cutoff 550Hz to nyquist
    ## peak_mid: the mid-range peak (freqM), K et al 2013
    ##peak_adjusted_mid: 2000 - 9000; i.e. edited ranges so that they can capture the actual high peaks of female speakers, and the possible sh productions by some male speakers. The intention is to measure realisations of /s/, which could a) be well-formed [s] but higher freq than assumed by K et al, since these do actually exist in the wild, b) other productions used for /s/, which are needed in order to demonstrate the range of possible, likely, and actual, acoustic realizations of /s/ (and also /sh/) in the wild. This is different from K et al, who seek to capture well-formed /s/, i.e. the acoustics of assumed alveolar fricative [s].
    # ampdiff: ampDM-LMin, which captures difference in amplitude from lowest amp within the low range (550-3000) and highest amp in the mid range (3000-7000), K et al 2013
    ## ampdiff_adjusted: adjusted so mid range is 3000-9000.
    ## slope: from ampLmin to peaksensible rangemid. Need to do more work on script to get this working, before trying out in ISCAN.

    ## [NOT: Leveldiff, which was designed to track differences across the course of /s/, and doesn't mean much on its own - level = soundlevel]

                ## Measures: For description, discussion and justification of measures, see Protocol for sibilants revised 13 May 2020

                # 1. full range peak and COG, where the range is 1000-11000Hz.
                #    This will capture the high PEAK for /s/, and generally capture /sh/ PEAK quite well (with the proviso that there are the odd cases of /sh/ which show a prominence >6000Hz).

                corpus_data[row, "spectral_peak_full"] <- peakHz(sock_spectrum, minHz = 1000, maxHz = 11000)

                corpus_data[row, "spectral_cog"] <- centroid(sock_spectrum, scale = "decibel", minHz = 1000, maxHz=11000)

                # 2. a mid-frequency range peak: which serves for both /s sh/, 2000-7000Hz.
                #    For /sh/ the spectral maximum will generally coincide with the PEAK;
                #    for /s/ the spectral maximum will coincide with the PEAK for some, but not all (female) speakers.
                #    I would be loath to increase the range to >7000Hz, since then this really stops being anything near 'mid-frequency' range.

        # print('d')
                corpus_data[row, "spectral_peak_mid"] <- peakHz(sock_spectrum, minHz = 2000, maxHz = 7000)
                corpus_data[row, "spectral_peak_2k8k"] <- peakHz(sock_spectrum, minHz = 2000, maxHz = 8000)
                corpus_data[row, "spectral_peak_2k9k"] <- peakHz(sock_spectrum, minHz = 2000, maxHz = 9000)

                # 3. spectral peak within the 2000-5000Hz range, as a general sibilant measure. This may capture the peak ~ front cavity resonance.

                corpus_data[row, "spectral_peak_lower_mid"] <- peakHz(sock_spectrum, minHz = 2000, maxHz = 5000)

                # 4. spread/stdev (2nd moment) - full range
                corpus_data[row, "spectral_spread"] <- variance(sock_spectrum, scale = "decibel", minHz = 1000, maxHz= 11000)

                # 5. ampdiff: for s and sh, measured for all sibilants, to be separated out afterwards. s_range assumes anti-resonance <3000; sh_range assumes it's lower. These are pilot measures, to look at, against troughs/peak/PEAKS. Very likely to reformulate this, given that antiresonance can shift quite a lot, by speaker, especially for /s/. Certainly, some speakers have their main antiresonance above 3000Hz in Raleigh.

        # print('e')
                minamp_low_s <- minAmp(sock_spectrum, scale = "dB", minHz = 1000, maxHz = 3000)
                maxamp_mid_s <- maxAmp(sock_spectrum, scale = "dB", minHz= 3000, maxHz=7000)
                corpus_data[row, "spectral_ampdiff_s"] <- maxamp_mid_s - minamp_low_s

                minamp_low_sh <- minAmp(sock_spectrum, scale = "dB", minHz = 1000, maxHz = 2000)
                maxamp_mid_sh <- maxAmp(sock_spectrum, scale = "dB", minHz= 2000, maxHz=6000)
                corpus_data[row, "spectral_ampdiff_sh"] <- maxamp_mid_sh - minamp_low_sh

                ## 6. front slope, low-range (1000-4000Hz). This is again, just for Jane to have a look at. Proper slopes, ending on an appropriate higher upper-bound, relating to speaker peaks, will be calculated from Multitaper spectra, later.

        # print('f')
                spectralSlope <- function(mts, minHz = -Inf, maxHz = Inf) {
                    .indices <- (function(.f) {which(minHz < .f & .f < maxHz)})(frequencies(mts))
                    .freqs <- frequencies(mts)[.indices] %>% (function(.x) {(.x - mean(.x)) / sd(.x)})
                    .values <- ((function(.v) {10 * log10(.v)})(values(mts)))[.indices] %>%
                        (function(.x) {(.x - mean(.x)) / sd(.x)})
                    .spec <- data.frame(x = .freqs, y = .values)
                    .coeffs <- coef(lm(data = .spec, formula = y ~ x))
                    return(coef(lm(data = .spec, formula = y ~ x))[2])
                }

                corpus_data[row, "spectral_lower_slope"] <- spectralSlope(sock_spectrum, minHz = 1000, maxHz = 4000)
                corpus_data[row, "spectral_cog_8k"] <- centroid(sock_spectrum, scale = "decibel", minHz = 1000, maxHz=8000)

        # print('g')
            #JM: store the multitaper
            if (length(sock_spectrum@values) < length(mts_colnames)){
                sock_spectrum@values <- c(sock_spectrum@values, rep(0,length(mts_colnames)-length(sock_spectrum@values)))
                # print (sock_spectrum@values)
            }
            corpus_data[row,mts_colnames] <- sock_spectrum@values
            #JM: how to get frequencies and values out
            # frequencies <- seq(from = 0, to = sock_spectrum@nyquist, by = sock_spectrum@binWidth)
            # values <- sock_spectrum@values

        # print('h')
        }
        corpus_data
    }

    stopImplicitCluster()

    all_multitapers$values <- corpus_data[,mts_colnames]
    corpus_data <- corpus_data[,setdiff(colnames(corpus_data),mts_colnames)]

    write.csv(corpus_data, paste0(args$output_dir, corpus_name,"_mts_sibilants",".csv"))

    save(all_multitapers, file=paste0(args$output_dir, corpus_name,"_all_multitapers",".RData"))
}

finished_at <- date()
print (paste('started', started_at))
print (paste('finished', finished_at))


library(GenomicRanges)
library(rtracklayer)
library(dplyr)

#20180525_modification: See commented out code with Views(). Upgrading to R version 5.0 will cause RangesList to become deprecated and GRangesList is not compatible with this function. In order to circumvent, a newer updated version of splitting a GRanges into GRangesList was added.
#20180625_modification: added check_chromosome_boundary function in order to determine which peaks interfere with the chromosome boundaries of the assemblies you want to obtain a metapeak from. This will help you with exo_metapeak_matrix function errors.

apply_seqlengths <- function(gr, genome=Mmusculus) {
  seqlengths(gr) <- seqlengths(genome)[seqlevels(gr)]
  gr
}

check_coverage_argument <- function(cvg, regions=NULL) {
  if(class(cvg) == "character") {
    if(is.null(regions)) {
      cvg <- import(cvg, as="RleList")
    } else {
      stopifnot(file.exists(cvg))
      cvg <- import(cvg, which=regions, as="RleList")
    }
  }
  cvg
}

regionApply <- function(regions, cvg, func, ...) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(unlist(
           viewApply(
             #Views(cvg, as(regions, "GRangesList")),
             Views(cvg, split(regions, seqnames(regions))),
             function(x) { func(as.numeric(x)) },
             simplify=FALSE
           ), use.names=FALSE), use.names=FALSE)
  ans
}

regionApply_list <- function(regions, cvg, func) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
           viewApply(
             #Views(cvg, as(regions, "GRangesList")),
             Views(cvg, split(regions, seqnames(regions))),
             function(x) { func(as.numeric(x)) },
             simplify=FALSE
           ), use.names=FALSE)
  ans
}

regionSums <- function(regions, cvg) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
           viewSums(
             #Views(cvg, as(regions, "GRangesList"))
             Views(cvg, split(regions, seqnames(regions)))
           ), use.names=FALSE)
  ans[oo] <- ans  # restore original order
  ans
}

regionMeans <- function(regions, cvg) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
           viewMeans(
             #Views(cvg, as(regions, "GRangesList"))
             Views(cvg, split(regions, seqnames(regions)))
           ), use.names=FALSE)
  ans[oo] <- ans  # restore original order
  ans
}

regionWhichMaxs <- function(regions, cvg) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
           viewWhichMaxs(
             #Views(cvg, as(regions, "GRangesList"))
             Views(cvg, split(regions, seqnames(regions)))
           ), use.names=FALSE)
  ans[oo] <- ans  # restore original order
  ans
}

regionWhichMins <- function(regions, cvg) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
    viewWhichMins(
      #Views(cvg, as(regions, "GRangesList"))
      Views(cvg, split(regions, seqnames(regions)))
    ), use.names=FALSE)
  ans[oo] <- ans  # restore original order
  ans
}

regionMaxs <- function(regions, cvg) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
           viewMaxs(
             #Views(cvg, as(regions, "GRangesList"))
             Views(cvg, split(regions, seqnames(regions)))
           ), use.names=FALSE)
  ans[oo] <- ans  # restore original order
  ans
}

regionMins <- function(regions, cvg) {
  cvg <- check_coverage_argument(cvg, regions)
  seqlevels(regions) <- names(cvg)
  oo <- order(regions)
  regions <- regions[oo]
  ans <- unlist(
           viewMins(
             #Views(cvg, as(regions, "GRangesList"))
             Views(cvg, split(regions, seqnames(regions)))
           ), use.names=FALSE)
  ans[oo] <- ans  # restore original order
  ans
}

total_signal <- function(cov) {
  if(class(cov) == "character") {
    cache.file <- paste0(cov, ".ts.rds")
    if(file.exists(cache.file)) {
      return(readRDS(cache.file))
    } else {
      cov <- check_coverage_argument(cov)
      ts <- sum(as.numeric(sapply(cov, function(x) sum(as.numeric(x)))))
      saveRDS(ts, file=cache.file)
      return(ts)
    }
  } else {
    return(sum(as.numeric(sapply(cov, function(x) sum(as.numeric(x))))))
  }
}

nexus_regionSums <- function(gr, sample){
  signal <- regionSums(gr, sample$pos) + abs(regionSums(gr, sample$neg))
  signal
}

#FXN: Check Chromosome Boundaries

#Inputs: (1) gr=regions of interest for exo_metapeak_matrix, (2)) resize_boundary=the extensions created by the "downstream" input command and "upstream" input command on exo_metapeak_matrix.

#Outputs: Returns an vector of indices that oversteps the designated chromosome boundaries and are therefore incompatible with matrix computation. Use indices WRT "gr" input.

#Example: Input: Granges called "example.ranges" of 100 regions from the dm6 genome that we want to plot +/- 500bp from the center.
#         Use Case: library(BSgenome.Dmelanogaster.UCSC.dm6)  <-call library of genome you want to check across
#                   bad_spots<-check_chromosome_boundaries(gr=example.ranges, genome=BSgenome.Dmelanogaster.UCSC.dm6, resize_boundary=1001) <-apply the function to find if you have any bad regions
#                   if(length(bad_spots>0){example.ranges<-example.ranges[-bad_spots]} <- IF the bad regions exist, remove them from your GRanges. ****Make sure to always wrap this in an IF statement. Calling a variable of length=0 as a negative will erase the entire contents of the variable.

check_chromosome_boundaries<-function(gr, resize_boundary, genome=NULL){

  if(!is.null(genome)){
    seqlevels(gr)<-seqlevels(genome)
    seqinfo(gr)<-seqinfo(genome)
  }

  key<-data.frame(seqlength_filler=seqlengths(gr), seqnames=names(seqlengths(gr)))
  gr_merged<-merge(as.data.frame(gr), key, by.x="seqnames", by.y="seqnames") %>% makeGRangesFromDataFrame(keep.extra.columns = T)
  gr_merged$end_distance<-gr_merged$seqlength_filler-(end(gr_merged)+resize_boundary) #distance from end
  gr_merged$start_distance<-start(gr_merged)-resize_boundary #distance from start

  flagged_indexes<-which(gr_merged$end_distance<=0 | gr_merged$start_distance<=0)
  if(length(flagged_indexes)>0){
    gr_merged<-gr_merged[-flagged_indexes]
  }
  message("Returning GRanges with metadata. We removed ", length(flagged_indexes), " regions.")
  return(gr_merged)
}

#FXN: Augment GRanges

#Purpose: Intended to provide augmentation for BPNet training of a GRanges. Augmentation is when you offset and distort your data in order for the network to get a more robust sense of its scope. In this case, translation across a genome is the only augmentation this supports.

#Inputs:
#(1) gr=regions of interest,
#(2) augmentation_repeat_limits = the range of repeated regions for variable augmentation. If you desire only 1 region ever, please select a scalar input of 1.
#(3) augmentation_window_limits = the range of offset centers that you translate the windows across.
#(4) desired_window_width = how wide you would like the GRanges extended to post-augmentation for BPNet training.
#(5) output_bed_file = if not NA, then writes GRanges to an output BED file at the specified path.
#(6) seed = if not NA, then selects seed to control randomization for reproducibility

#Outputs: Returns a GRanges from the function with the desired augmentation applied. If output_bed_file is not NA, also write this GRanges to specified BED path.

augment_granges<-function(gr, augmentation_repeat_limits=1:5, augmentation_window_limits=-100:100, desired_window_width=1000, output_bed_file=NA, seed=NA){
  #set seed if desired
  if(!is.na(seed)){
    set.seed(seed)
  }

  #Determine augmentation repeats
  augmentation_repeats<-sample(augmentation_repeat_limits, length(gr), replace=T)
  gr_idx<-rep(1:length(gr), augmentation_repeats)
  gr_exp<-gr[gr_idx] %>% resize(width=1, fix="start")
  gr_aug<-gr_exp %>% IRanges::shift(shift=sample(augmentation_window_limits, length(gr_exp), replace=T))

  #Resize to desired window width
  gr_final<-gr_aug %>% resize(width=desired_window_width, fix="center")

  #write to BED if desired
  if(!is.na(output_bed_file)){
    export(gr_final, output_bed_file)
    return(gr_final)
  }
  else{return(gr_final)}
}


# load libraries
require(tidyr)
require(dplyr)
require(ggplot2)
require(svglite)

# setwd to this file's directory
setwd(dirname(parent.frame(2)$ofile))

# load data
# specify filepath to csv
fp <- "/Volumes/Data/Research/CDB/openSMILE/adults_speak/adults_speak.csv"
# read csv into `adults` variable as Boolean matrix
adults <- gather(read.csv(fp, header = TRUE, colClasses =
          c(NA, "logical", "logical", "logical", "logical", "logical")),
          cond, adults_speaking, -c(X, SM.dx))
# remove `fp` variable
remove(fp)

# reshape data
colnames(adults)[1] = "URSI"
adults = separate(data=adults, col=cond, into=c("vocal", "stranger"), remove=TRUE)
adults["stranger"] = adults["stranger"] == "w"
adults["vocal"] = adults["vocal"] == "vocal"

# ANOVAs
summary(aov(SM.dx ~ adults_speaking + Error(URSI), data=adults))
summary(aov(vocal ~ adults_speaking + Error(URSI), data=adults))
summary(aov(stranger ~ adults_speaking + Error(URSI), data=adults))
summary(aov(SM.dx ~ (vocal * stranger * adults_speaking) + Error(URSI), data=adults))
summary(aov(adults_speaking ~ (vocal * stranger * SM.dx) + Error(URSI), data=adults))

# Visualize
adults %>%
  group_by(stranger, vocal) %>%
  filter(adults_speaking == TRUE) %>%
  ggplot(aes(x=factor(vocal, labels=c("button press", "vocal")), fill=factor(stranger))) + geom_bar(position="dodge") + guides(fill=guide_legend(title="Stranger Presence")) + labs(title="Adult Vocalizations by Experimental Condition and Stranger Presence", x = "Experimental Condition", y="number of cases in which adults vocalized")
ggsave("images/adults_by_vocal_by_stranger.svg")

adults %>%
  group_by(stranger, vocal) %>%
  filter(adults_speaking == TRUE) %>%
  ggplot(aes(x=factor(stranger), fill=factor(vocal, labels=c("button press", "vocal")))) + geom_bar(position="dodge") + guides(fill=guide_legend(title="Experimental Condition")) + labs(title="Adult Vocalizations by Stranger Presence and Experimental Condition", x = "Stranger Presence", y="number of cases in which adults vocalized")
ggsave("images/adults_by_stranger_by_vocal.svg")


code 'cf_reprice_liquid_gap_cross'
name '重定价、流动性缺口交叉'
dimensions {
	accbook {
		subDimension 'liquidGap'
		appendSubHeadCallback { thisHead,subHead->
			thisHead.model?.hasTerm
		}
	}
	repriceGap null
}
dataRequest {
	table 'crossGap'
	contextParams (['date','organ','currency','staticModel'])
}
dataGrids {
	apply selectRows({children!=null}),{
		formula {sumChildren()}
	}
}


suppressMessages(library(fmlr))

if (fml_gpu()){
  m = 2
  n = 3
  c = card()
  x = gpumat(c, m, n)

  source("internals/common.r")
  source("internals/mat.r")
}


```R

#### FIGURE 3 #####
### Behavior Donut ###
######
#     Files for input into the for loop are in the format X(int), behaviors(char),
#     subject(char), days(int), hours(int), count(int), sex(char). This data was
#     collated by aggregating the sum or count of the predicted data over behavior,
#     days and hours for each subject.
######
library(ggplot2)

### Female ####
setwd("H:/Chapter 3/Beh_Agg/Female") #Set working directory
filenames<- Sys.glob("*.csv") #load in filenames for processing
femdf <- data.frame() #create a temporary dataframe

## Loop that reads in files and binds them into a megafile ##
for (ii in 1:length(filenames)) {
  dat <- read.csv(filenames[ii])
  femdf <- rbind(femdf,dat)
}

## aggregate the count into a mean ##
totmean <- aggregate(femdf$x, by=list(behaviors = femdf$behaviors), FUN = mean)
levels(as.factor(totmean$behaviors)) # check levels to make sure all are represented

## order the behaviors to present nicely in the donut ##
totmean$behaviors <- factor(totmean$behaviors,
                            levels = c("Lying.Resting","Sitting","Vigilance","Standing Vig",
                                       "Vig Walking","Walking","Turning","Gallop","Bounds","Jumping"))

pie(totmean$x, totmean$behaviors) # preliminary pie chart

## GGplot code to produce the behavior donut ##
fempie <- ggplot(totmean, aes(x=2, y=x, fill = behaviors))+
  geom_bar(width = 1.9, stat = "identity", color = "#222222", size = 1.05) +# color and size of outlines
  coord_polar(theta = "y", start = 0, direction = 1)+ # direction of order
  theme_void()+
  theme(legend.title = element_blank(), legend.text = element_text(size = 12, color = "black"))+ # legend
  scale_fill_manual(values = c("#A08BDD","#829DED","#76cff2","#7addc1","#96ca71",
                               "#d4c974","#eeae79","#fa9088","#f887b2","#e48cce"))+ # colors of figure
  annotate("text", x=0,y=0,label=" ",colour="#000000", size=16)

plot(fempie) # Plot the figure created above

```


#' @export
#' @title get.asp
#' @description gets the aspect ratio
#' @family  plotting
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
get.asp <- function() {
  pin <- par("pin")
  usr <- par("usr")
  asp <- (pin[2]/(usr[4] - usr[3]))/(pin[1]/(usr[2] - usr[1]))
  return(asp)
}


#!/usr/bin/Rscript

library(extrafont)
data <- read.csv(file="output/tagcount.csv",sep=",",header=TRUE)

# pie chart
png(
    filename="output/tagcount-pie.png",
    width=2000,
    height=2000,
    pointsize=16,
    family="Ubuntu Light"
)
pie(
    data$COUNT,
    labels=data$TAG,
    main="Most Popular Tags",
    edges=666,
    radius=0.9
)
dev.off()

# top 10 bar chart (excluding "other")
rows <- nrow(data)
data_cropped <- data[c((rows-10):(rows-1)),]
png(
    filename="output/tagcount-top10-bar.png",
    width=2000,
    height=600,
    pointsize=21,
    family="Ubuntu Light"
)
barplot(
    data_cropped$COUNT,
    names=data_cropped$TAG,
    main="Frequencies of Most Popular Tags (excluding \"other\")",
    ylab="Frequency",
    xlab="Tag",
    col=cm.colors(10),
)
dev.off()